Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -22,18 +22,18 @@
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm margs.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
- ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
+ http-transport.scm tdb.scm client.scm mt.scm \
+ ezsteps.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES =
-# ftail.scm rmtmod.scm commonmod.scm removed
+# rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
@@ -108,11 +108,10 @@
env.o \
http-transport.o \
items.o \
keys.o \
launch.o \
- lock-queue.o \
margs.o \
mt.o \
ods.o \
portlogger.o \
process.o \
@@ -157,25 +156,25 @@
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
tests.o db.o launch.o runs.o dashboard-tests.o \
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \
-monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
+dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
-db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
+db.o ezsteps.o keys.o launch.o megatest.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
-runs.o : test_records.scm
-
megatest.o : megatest-fossil-hash.scm megatest-version.scm
-rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
+rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
+
+runs.o tests.o : test_records.scm
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
vg.o dashboard.o : vg_records.scm megatest-version.scm
@@ -216,14 +215,10 @@
chmod a+x $(PREFIX)/bin/megatest
$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
-$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
- utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
- chmod a+x $(PREFIX)/bin/newdashboard
-
# mtutil
$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut
@@ -345,13 +340,10 @@
$(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
-# $(PREFIX)/bin/.$(ARCHSTR)/ndboard
-
-# $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
@@ -369,15 +361,15 @@
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
tcmt readline-fix.scm serialize-env dboard *.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o \
mofiles/*.o vg.o cookie.o dashboard-main.o \
- ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o \
+ ducttape-lib.o mutils.o pkts.o rmtmod.o stml2.o \
tcmt.o *.import.scm *.import.o
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
- tcmt ftail.import.scm readline-fix.scm serialize-env \
+ tcmt readline-fix.scm serialize-env \
dboard dboard.o megatest.o dashboard.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
rm -rf share
#======================================================================
@@ -454,12 +446,12 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -396,18 +396,10 @@
(if (not success)
(debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
(if (> *api-process-request-count* *max-api-process-requests*)
(set! *max-api-process-requests* *api-process-request-count*))
(set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
- ;; (rmt:dat->json-str
- ;; (if (or (string? res)
- ;; (list? res)
- ;; (number? res)
- ;; (boolean? res))
- ;; res
- ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
(db:obj->string res transport: 'http)))
(begin
(debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params)
(db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -31,11 +31,11 @@
;;
;;======================================================================
;; NOT CURRENTLY USED
;;
-(define (archive:main linktree target runname testname itempath options)
+#;(define (archive:main linktree target runname testname itempath options)
(let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
(flavor 'plain) ;; type of machine to run jobs on
(maxload 1.5) ;; max allowed load for this work
(adisks (archive:get-archive-disks)))
;; get testdir size
@@ -389,11 +389,11 @@
(debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds)))))))
(else
(debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
(debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))
-(define (archive:restore-db archive-path ts)
+#;(define (archive:restore-db archive-path ts)
(let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
(bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
(debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
ADDED attic/fdb_records.scm
Index: attic/fdb_records.scm
==================================================================
--- /dev/null
+++ attic/fdb_records.scm
@@ -0,0 +1,36 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;; Single record for managing a filedb
+;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
+;; Filedb record
+(define (make-filedb:fdb)(make-vector 5))
+(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
+(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
+(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
+(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
+(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
+(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
+(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
+(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
+(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
+(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
+
+;; children records, should have use something other than "child"
+(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
+(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
+(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
ADDED attic/filedb.scm
Index: attic/filedb.scm
==================================================================
--- /dev/null
+++ attic/filedb.scm
@@ -0,0 +1,255 @@
+;; Copyright 2006-2011, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
+(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit filedb))
+
+(include "fdb_records.scm")
+;; (include "settings.scm")
+
+(define (filedb:open-db dbpath)
+ (let* ((fdb (make-filedb:fdb))
+ (dbexists (common:file-exists? dbpath))
+ (db (sqlite3:open-database dbpath)))
+ (filedb:fdb-set-db! fdb db)
+ (filedb:fdb-set-dbpath! fdb dbpath)
+ (filedb:fdb-set-pathcache! fdb (make-hash-table))
+ (filedb:fdb-set-idcache! fdb (make-hash-table))
+ (filedb:fdb-set-partcache! fdb (make-hash-table))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = OFF;")
+ (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
+ (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
+ ;; NB// We store a useful subset of file attributes but do not attempt to store all
+ (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
+ path TEXT,
+ parent_id INTEGER,
+ mode INTEGER DEFAULT -1,
+ uid INTEGER DEFAULT -1,
+ gid INTEGER DEFAULT -1,
+ size INTEGER DEFAULT -1,
+ mtime INTEGER DEFAULT -1);")
+ (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
+ (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
+ ;; close the sqlite3 db and open it as needed
+ (filedb:finalize-db! fdb)
+ (filedb:fdb-set-db! fdb #f)
+ fdb))
+
+(define (filedb:reopen-db fdb)
+ (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
+ (filedb:fdb-set-db! fdb db)
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
+
+(define (filedb:finalize-db! fdb)
+ (sqlite3:finalize! (filedb:fdb-get-db fdb)))
+
+(define (filedb:get-current-time-string)
+ (string-chomp (time->string (seconds->local-time (current-seconds)))))
+
+(define (filedb:get-base-id db path)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:get-path-id db path parent)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path parent)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:add-base db path)
+ (let ((existing (filedb:get-base-id db path)))
+ (if existing #f
+ (begin
+ (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
+
+;; index value field notes
+;; 0 inode number st_ino
+;; 1 mode st_mode bitfield combining file permissions and file type
+;; 2 number of hard links st_nlink
+;; 3 UID of owner st_uid as with file-owner
+;; 4 GID of owner st_gid
+;; 5 size st_size as with file-size
+;; 6 access time st_atime as with file-access-time
+;; 7 change time st_ctime as with file-change-time
+;; 8 modification time st_mtime as with file-modification-time
+;; 9 parent device ID st_dev ID of device on which this file resides
+;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
+;; 11 block size st_blksize
+;; 12 number of blocks allocated st_blocks
+
+(define (filedb:add-path-stat db path parent statinfo)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
+ (sqlite3:execute stmt
+ path
+ parent
+ (vector-ref statinfo 1) ;; mode
+ (vector-ref statinfo 3) ;; uid
+ (vector-ref statinfo 4) ;; gid
+ (vector-ref statinfo 5) ;; size
+ (vector-ref statinfo 8) ;; mtime
+ )
+ (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
+
+(define (filedb:add-path db path parent)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
+ (sqlite3:execute stmt path parent)
+ (sqlite3:finalize! stmt)))
+
+(define (filedb:register-path fdb path #!key (save-stat #f))
+ (let* ((db (filedb:fdb-get-db fdb))
+ (pathcache (filedb:fdb-get-pathcache fdb))
+ (stat (if save-stat (file-stat path #t)))
+ (id (hash-table-ref/default pathcache path #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if id id
+ (let ((plist (string-split path "/")))
+ (let loop ((head (car plist))
+ (tail (cdr plist))
+ (parent 0))
+ (let ((id (filedb:get-path-id db head parent))
+ (done (null? tail)))
+ (if id ;; we'll have a id if the path is already registered
+ (if done
+ (begin
+ (hash-table-set! pathcache path id)
+ id) ;; return the last path id for a result
+ (loop (car tail)(cdr tail) id))
+ (begin ;; add the path and then repeat the loop with the same data
+ (if save-stat
+ (filedb:add-path-stat db head parent stat)
+ (filedb:add-path db head parent))
+ (loop head tail parent)))))))))
+
+(define (filedb:update-recursively fdb path #!key (save-stat #f))
+ (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
+ (print "processed 0 files...")
+ (let loop ((l (read-line p))
+ (lc 0)) ;; line count
+ (if (eof-object? l)
+ (begin
+ (print " " lc " files")
+ (close-input-port p))
+ (begin
+ (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
+ (if (= (modulo lc 100) 0)
+ (print " " lc " files"))
+ (loop (read-line p)(+ lc 1)))))))
+
+(define (filedb:update fdb path #!key (save-stat #f))
+ ;; first get the realpath and add it to the bases table
+ (let ((real-path path) ;; (filedb:get-real-path path))
+ (db (filedb:fdb-get-db fdb)))
+ (filedb:add-base db real-path)
+ (filedb:update-recursively fdb path save-stat: save-stat)))
+
+;; not used and broken
+;;
+(define (filedb:get-real-path path)
+ (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
+ (pth (read-line p)))
+ (if (eof-object? pth) path
+ (begin
+ (close-input-port p)
+ pth))))
+
+(define (filedb:drop-base fdb path)
+ (print "Sorry, I don't do anything yet"))
+
+(define (filedb:find-all fdb pattern action)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
+ (result '()))
+ (sqlite3:for-each-row
+ (lambda (num)
+ (action num)
+ (set! result (cons num result))) stmt pattern)
+ (sqlite3:finalize! stmt)
+ result))
+
+(define (filedb:get-path-record fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (partcache (filedb:fdb-get-partcache fdb))
+ (dat (hash-table-ref/default partcache id #f)))
+ (if dat dat
+ (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
+ (result #f))
+ (sqlite3:for-each-row
+ (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
+ (hash-table-set! partcache id result)
+ (sqlite3:finalize! stmt)
+ result))))
+
+(define (filedb:get-children fdb parent-id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
+ parent-id)
+ res))
+
+;; retrieve all that have children and those without
+;; children that match patt
+(define (filedb:get-children-patt fdb parent-id search-patt)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ ;; first get the children that have no children
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
+ (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
+ parent-id search-patt)
+ res))
+
+(define (filedb:get-path fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (idcache (filedb:fdb-get-idcache fdb))
+ (path (hash-table-ref/default idcache id #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if path path
+ (let loop ((curr-id id)
+ (path ""))
+ (let ((path-record (filedb:get-path-record fdb curr-id)))
+ (if (not path-record) #f ;; this id has no path
+ (let* ((parent-id (list-ref path-record 1))
+ (pname (list-ref path-record 0))
+ (newpath (string-append "/" pname path)))
+ (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
+ (begin
+ (hash-table-set! idcache id newpath)
+ newpath)
+ (loop parent-id newpath)))))))))
+
+(define (filedb:search db pattern)
+ (let ((action (lambda (id)(print (filedb:get-path db id)))))
+ (filedb:find-all db pattern action)))
+
ADDED attic/fs-transport.scm
Index: attic/fs-transport.scm
==================================================================
--- /dev/null
+++ attic/fs-transport.scm
@@ -0,0 +1,52 @@
+
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+(require-extension (srfi 18) extras tcp s11n)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(import (prefix sqlite3 sqlite3:))
+
+(use spiffy uri-common intarweb http-client spiffy-request-vars)
+
+(tcp-buffer-size 2048)
+
+(declare (unit fs-transport))
+
+(declare (uses common))
+(declare (uses db))
+(declare (uses tests))
+(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+
+;;======================================================================
+;; F S T R A N S P O R T S E R V E R
+;;======================================================================
+
+;; There is no "server" per se but a convience routine to make it non
+;; necessary to be reopening the db over and over again.
+;;
+
+(define (fs:process-queue-item packet)
+ (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
+ (set! *dbstruct-db* (db:setup-db)))
+ (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
+ (db:process-queue-item *dbstruct-db* packet))
+
ADDED attic/ftail.scm
Index: attic/ftail.scm
==================================================================
--- /dev/null
+++ attic/ftail.scm
@@ -0,0 +1,108 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)
ADDED attic/lock-queue.scm
Index: attic/lock-queue.scm
==================================================================
--- /dev/null
+++ attic/lock-queue.scm
@@ -0,0 +1,253 @@
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+(use (prefix sqlite3 sqlite3:) srfi-18)
+
+(declare (unit lock-queue))
+(declare (uses common))
+(declare (uses tasks))
+
+;;======================================================================
+;; attempt to prevent overlapping updates of rollup files by queueing
+;; update requests in an sqlite db
+;;======================================================================
+
+;;======================================================================
+;; db record, <vector db path-to-db>
+;;======================================================================
+
+(define (make-lock-queue:db-dat)(make-vector 3))
+(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0))
+(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1))
+(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val))
+(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val))
+
+(define (lock-queue:delete-lock-db dbdat)
+ (let ((fname (lock-queue:db-dat-get-path dbdat)))
+ (system (conc "rm -f " fname "*"))))
+
+(define (lock-queue:open-db fname #!key (count 10))
+ (let* ((actualfname (conc fname ".lockdb"))
+ (dbexists (common:file-exists? actualfname))
+ (db (sqlite3:open-database actualfname))
+ (handler (make-busy-timeout 136000)))
+ (if dbexists
+ (vector db actualfname)
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (thread-sleep! 10)
+ (if (> count 0)
+ (lock-queue:open-db fname count: (- count 1))
+ (vector db actualfname)))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:execute
+ db
+ "CREATE TABLE IF NOT EXISTS queue (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ start_time INTEGER,
+ state TEXT,
+ CONSTRAINT queue_constraint UNIQUE (test_id));")
+ (sqlite3:execute
+ db
+ "CREATE TABLE IF NOT EXISTS runlocks (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ run_lock TEXT,
+ CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
+ (sqlite3:set-busy-handler! db handler)
+ (vector db actualfname)))
+
+(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
+ (handle-exceptions
+ exn
+ (if (> remtries 0)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 30)
+ (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
+ (begin
+ (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ #f))
+ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
+ newstate
+ test-id)))
+
+(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
+ ;; no need to wait on journal on read only queries
+ ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
+ (handle-exceptions
+ exn
+ (if (> remtries 0)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 5)
+ (lock-queue:delete-lock-db dbdat)
+ (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
+ (begin
+ (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ #f))
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (tid)
+ ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
+ (if (not (equal? tid test-id))
+ (set! res tid)))
+ (lock-queue:db-dat-get-db dbdat)
+ "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
+ res)))
+
+(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
+ (let* ((res #f)
+ (db (lock-queue:db-dat-get-db dbdat))
+ (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
+ (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
+ (let ((result
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 10)
+ ;; (if (> count 0)
+ ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries
+ ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
+ (lock-queue:delete-lock-db dbdat)
+ #f)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:for-each-row (lambda (tid lockstate)
+ (set! res (list tid lockstate)))
+ lckqry)
+ (if res
+ (if (equal? (car res) test-id)
+ #t ;; already have the lock
+ #f)
+ (begin
+ (sqlite3:execute mklckqry test-id)
+ ;; if no error handled then return #t for got the lock
+ #t)))))))
+ (sqlite3:finalize! lckqry)
+ (sqlite3:finalize! mklckqry)
+ result)))
+
+(define (lock-queue:release-lock fname test-id #!key (count 10))
+ (let* ((dbdat (lock-queue:open-db fname)))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! (/ count 10))
+ (if (> count 0)
+ (begin
+ (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
+ (lock-queue:release-lock fname test-id count: (- count 1)))
+ (let ((journal (conc fname "-journal")))
+ ;; If we've tried ten times and failed there is a serious problem
+ ;; try to remove the lock db and allow it to be recreated
+ (handle-exceptions
+ exn
+ #f
+ (if (common:file-exists? journal)(delete-file journal))
+ (if (common:file-exists? fname) (delete-file fname))
+ #f))))
+ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
+ (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
+
+(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
+ (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 10)
+ (if (> count 0)
+ (lock-queue:steal-lock dbdat test-id count: (- count 1))
+ #f))
+ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
+ (lock-queue:get-lock dbdat test-it))
+
+;; returns #f if ok to skip the task
+;; returns #t if ok to proceed with task
+;; otherwise waits
+;;
+(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
+ (let* ((dbdat (lock-queue:open-db fname))
+ (mystart (current-seconds))
+ (db (lock-queue:db-dat-get-db dbdat)))
+ ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))
+ (thread-sleep! 10)
+ (if (> count 0)
+ (begin
+ (sqlite3:finalize! db)
+ (lock-queue:wait-turn fname test-id count: (- count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
+ (print-call-chain (current-error-port))
+ #f)))
+ ;; wait 10 seconds and then check to see if someone is already updating the html
+ (thread-sleep! 10)
+ (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
+ (begin
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
+ (sqlite3:execute
+ db
+ "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
+ test-id mystart)
+ ;; (thread-sleep! 1) ;; give other tests a chance to register
+ (let ((result
+ (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
+ (if younger-waiting
+ (begin
+ ;; no need for us to wait. mark in the lock queue db as skipping
+ ;; no point in marking anything in the queue - simply never register this
+ ;; test as it is *covered* by a previously started update to the html file
+ ;; (lock-queue:set-state dbdat test-id "skipping")
+ #f) ;; let the calling process know that nothing needs to be done
+ (if (lock-queue:get-lock dbdat test-id)
+ #t
+ (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
+ (lock-queue:steal-lock dbdat test-id)
+ (begin
+ (thread-sleep! 1)
+ (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
+ (sqlite3:finalize! db)
+ result))))))
+
+
+;; (use trace)
+;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
ADDED attic/mlaunch.scm
Index: attic/mlaunch.scm
==================================================================
--- /dev/null
+++ attic/mlaunch.scm
@@ -0,0 +1,33 @@
+;; Copyright 2006-2014, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+;;======================================================================
+;; MLAUNCH
+;;
+;; take jobs from the given queue and keep launching them keeping
+;; the cpu load at the targeted level
+;;
+;;======================================================================
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
+
+(declare (unit mlaunch))
+(declare (uses db))
+(declare (uses common))
+
ADDED attic/monitor.scm
Index: attic/monitor.scm
==================================================================
--- /dev/null
+++ attic/monitor.scm
@@ -0,0 +1,33 @@
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit runs))
+(declare (uses db))
+(declare (uses common))
+(declare (uses items))
+(declare (uses runconfig))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+
ADDED attic/newdashboard.scm
Index: attic/newdashboard.scm
==================================================================
--- /dev/null
+++ attic/newdashboard.scm
@@ -0,0 +1,742 @@
+;;======================================================================
+;; Copyright 2006-2016, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(use format)
+
+(use (prefix iup iup:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
+ (prefix dbi dbi:))
+
+(declare (uses common))
+(declare (uses megatest-version))
+(declare (uses margs))
+
+;; (declare (uses launch))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses server))
+;; (declare (uses synchash))
+(declare (uses dcommon))
+;; (declare (uses tree))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+
+(define help (conc
+"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test testid : control test identified by testid
+ -guimonitor : control panel for runs
+
+Misc
+ -rows N : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-rows"
+ "-run"
+ "-test"
+ "-debug"
+ "-host"
+ )
+ (list "-h"
+ "-guimonitor"
+ "-main"
+ "-v"
+ "-q"
+ )
+ args:arg-hash
+ 0))
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (common:file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+ (let ((i 1)
+ (selected-item (if (null? default) #f (car default))))
+ (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ (for-each (lambda (item)
+ (iup:attribute-set! lb (number->string i) item)
+ (if selected-item
+ (if (equal? selected-item item)
+ (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+ (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+ (hash-table-set! *searchpatts* x val))
+
+
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+ ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
+ ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
+ ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list) ;; list of itemized tests
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+ ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
+ ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
+ ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
+ ((all-test-names '()) : list)
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Run times layout
+ ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
+ (graph-matrix #f)
+ ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
+ ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
+ ((graph-matrix-row 1) : number)
+ ((graph-matrix-col 1) : number)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
+ (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (access-mode (db:get-access-mode)) ;; use cached db or not
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+ ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+ ;; runs-summary tab state
+ ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
+ ((runs-summary-mode-buttons '()) : list)
+ ((runs-summary-mode 'one-run) : symbol)
+ ((runs-summary-mode-change-callbacks '()) : list)
+ (runs-summary-source-runname-label #f)
+ (runs-summary-dest-runname-label #f)
+ ;; runs summary view
+
+ tests-tree ;; used in newdashboard
+ )
+
+
+
+;; mtest is actually the megatest.config file
+;;
+(define (mtest toppath window-id)
+ (let* ((curr-row-num 0)
+ ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
+ (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
+ (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
+ (jobtools-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 3))
+ (validvals-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 2
+ #:numcol-visible 1
+ #:numlin-visible 2))
+ (envovrd-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ (disks-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ )
+ (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+ (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+ (iup:attribute-set! disks-matrix "WIDTH1" "120")
+ (iup:attribute-set! disks-matrix "WIDTH0" "100")
+ (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+
+ ;; fill in existing info
+ (for-each
+ (lambda (mat fname)
+ (set! curr-row-num 1)
+ (for-each
+ (lambda (var)
+ (iup:attribute-set! mat (conc curr-row-num ":0") var)
+ ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+ (set! curr-row-num (+ curr-row-num 1)))
+ '()));; (configf:section-vars rawconfig fname)))
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+ (list "setup" "jobtools" "validvalues" "env-override" "disks"))
+
+ (for-each
+ (lambda (mat)
+ (iup:attribute-set! mat "0:1" "Value")
+ (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+ (iup:attribute-set! mat "WIDTH1" "120")
+ (iup:attribute-set! mat "WIDTH0" "100")
+ )
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
+
+ (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+ (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
+
+ (iup:vbox
+ (iup:hbox
+
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ ;; The required tab
+ (iup:hbox
+ ;; The keys
+ (iup:frame
+ #:title "Keys (required)"
+ (iup:vbox
+ (iup:label (conc "Set the fields for organising your runs\n"
+ "here. Note: can only be changed before\n"
+ "running the first run when megatest.db\n"
+ "is created."))
+ keys-matrix))
+ (iup:vbox
+ ;; The setup section
+ (iup:frame
+ #:title "Setup"
+ (iup:vbox
+ (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
+ "linktree : directory where linktree will be created."))
+ setup-matrix))
+ ;; The jobtools
+ (iup:frame
+ #:title "Jobtools"
+ (iup:vbox
+ (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
+ "useshell : use system to run your launcher\n"
+ "workhosts : spread jobs out on these hosts"))
+ jobtools-matrix))
+ ;; The disks
+ (iup:frame
+ #:title "Disks"
+ (iup:vbox
+ (iup:label (conc "Enter names and existing paths of locations to run tests"))
+ disks-matrix))))
+ ;; The optional tab
+ (iup:vbox
+ ;; The Environment Overrides
+ (iup:frame
+ #:title "Env override"
+ envovrd-matrix)
+ ;; The valid values
+ (iup:frame
+ #:title "Validvalues"
+ validvals-matrix)
+ ))))
+ (iup:attribute-set! tabs "TABTITLE0" "Required settings")
+ (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
+ tabs))
+ ))))
+
+;; The runconfigs.config file
+;;
+(define (rconfig window-id)
+ (iup:vbox
+ (iup:frame #:title "Default")))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+(define (tree-path->test-id path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
+ #f))
+
+(define (test-panel window-id)
+ (let* ((curr-row-num 0)
+ (viewlog (lambda (x)
+ (if (common:file-exists? logfile)
+ ;(system (conc "firefox " logfile "&"))
+ (iup:send-url logfile)
+ (message-window (conc "File " logfile " not found")))))
+ (xterm (lambda (x)
+ (if (directory-exists? rundir)
+ (let ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ "")))
+ (system (conc "cd " rundir
+ ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (message-window (conc "Directory " rundir " not found")))))
+ (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
+ (command-launch-button (iup:button "Execute!"
+ ;; #:expand "HORIZONTAL"
+ #:size "50x"
+ #:action (lambda (x)
+ (let ((cmd (iup:attribute command-text-box "VALUE")))
+ (system (conc cmd " &"))))))
+ (run-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
+ " -runtests " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (remove-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
+ " -testpatt " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (run-info-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:scrollbar "YES"
+ #:numcol 1
+ #:numlin 4
+ #:numcol-visible 1
+ #:numlin-visible 4
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status))))
+ (test-info-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 7
+ #:numcol-visible 1
+ #:numlin-visible 7))
+ (test-run-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (meta-dat-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (steps-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 6
+ #:numlin 50
+ #:numcol-visible 6
+ #:numlin-visible 8))
+ (data-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 8
+ #:numlin 50
+ #:numcol-visible 8
+ #:numlin-visible 8))
+ (updater (lambda (testdat)
+ (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
+
+ ;; Set the updater in updaters
+ ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
+ ;;
+ (for-each
+ (lambda (mat)
+ ;; (iup:attribute-set! mat "0:1" "Value")
+ ;; (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "HEIGHT0" 0)
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
+ ;; (iup:attribute-set! mat "WIDTH1" "120")
+ ;; (iup:attribute-set! mat "WIDTH0" "100"))
+ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
+
+ ;; Steps matrix
+ (iup:attribute-set! steps-matrix "0:1" "Step Name")
+ (iup:attribute-set! steps-matrix "0:2" "Start")
+ (iup:attribute-set! steps-matrix "WIDTH2" "40")
+ (iup:attribute-set! steps-matrix "0:3" "End")
+ (iup:attribute-set! steps-matrix "WIDTH3" "40")
+ (iup:attribute-set! steps-matrix "0:4" "Status")
+ (iup:attribute-set! steps-matrix "WIDTH4" "40")
+ (iup:attribute-set! steps-matrix "0:5" "Duration")
+ (iup:attribute-set! steps-matrix "WIDTH5" "40")
+ (iup:attribute-set! steps-matrix "0:6" "Log File")
+ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
+ ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
+ ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
+
+ ;; Data matrix
+ ;;
+ (let ((rownum 1))
+ (for-each
+ (lambda (x)
+ (iup:attribute-set! data-matrix (conc "0:" rownum) x)
+ (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
+ (set! rownum (+ rownum 1)))
+ (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
+ (iup:attribute-set! data-matrix "REDRAW" "ALL")
+
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (keys (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (iup:attribute-set! mat (conc rownum ":0") key)
+ (set! rownum (+ rownum 1)))
+ keys)
+ (iup:attribute-set! mat "REDRAW" "ALL")))
+ (list
+ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
+ (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
+ (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
+ (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
+
+ (iup:split
+ #:orientation "HORIZONTAL"
+ (iup:vbox
+ (iup:hbox
+ (iup:vbox
+ run-info-matrix
+ test-info-matrix)
+ ;; test-info-matrix)
+ (iup:vbox
+ test-run-matrix
+ meta-dat-matrix))
+ (iup:vbox
+ (iup:vbox
+ (iup:hbox
+ (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
+ (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
+ (iup:hbox
+ (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
+ (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
+ (iup:hbox
+ ;; hiup:split ;; hbox
+ ;; #:orientation "HORIZONTAL"
+ ;; #:value 300
+ command-text-box
+ command-launch-button)))
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ steps-matrix
+ data-matrix)))
+ (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
+ (iup:attribute-set! tabs "TABTITLE1" "Test Data")
+ tabs)))))
+
+;; Test browser
+(define (tests window-id)
+ (iup:split
+ (let* ((tb (iup:treebox
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (test-id (tree-path->test-id (cdr run-path))))
+ ;; (if test-id
+ ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
+ ;; window-id test-id))
+ (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
+ (iup:attribute-set! tb "VALUE" "0")
+ (iup:attribute-set! tb "NAME" "Runs")
+ ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
+ ;; (dboard:data-tests-tree-set! *data* tb)
+ tb)
+ (test-panel window-id)))
+
+;; The function to update the fields in the test view panel
+(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
+ ;; get test-id
+ ;; then get test record
+ (if testdat
+ (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
+ (test-data (hash-table-ref/default testdat test-id #f))
+ (run-id (db:test-get-run_id test-data))
+ (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
+ run-id
+ '()))
+ (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
+ (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
+ (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
+
+ (if test-data
+ (begin
+ ;;
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (vals (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (let ((cell (conc rownum ":1")))
+ (if (not (equal? (iup:attribute mat cell)(conc key)))
+ (begin
+ ;; (print "setting cell " cell " in matrix " mat " to value " key)
+ (iup:attribute-set! mat cell (conc key))
+ (iup:attribute-set! mat "REDRAW" cell)))
+ (set! rownum (+ rownum 1))))
+ vals)))
+ (list
+ (list run-info-matrix
+ (if test-id
+ (list (db:test-get-run_id test-data)
+ target
+ runname
+ "n/a")
+ (make-list 4 "")))
+ (list test-info-matrix
+ (if test-id
+ (list test-id
+ (db:test-get-testname test-data)
+ (db:test-get-item-path test-data)
+ (db:test-get-state test-data)
+ (db:test-get-status test-data)
+ (seconds->string (db:test-get-event_time test-data))
+ (db:test-get-comment test-data))
+ (make-list 7 "")))
+ (list test-run-matrix
+ (if test-id
+ (list (db:test-get-host test-data)
+ (db:test-get-uname test-data)
+ (db:test-get-diskfree test-data)
+ (db:test-get-cpuload test-data)
+ (seconds->hr-min-sec (db:test-get-run_duration test-data)))
+ (make-list 5 "")))
+ ))
+ (dcommon:populate-steps steps-dat steps-matrix))))))
+ ;;(list meta-dat-matrix
+ ;; (if test-id
+ ;; (list (
+
+
+;; db:test-get-id
+;; db:test-get-run_id
+;; db:test-get-testname
+;; db:test-get-state
+;; db:test-get-status
+;; db:test-get-event_time
+;; db:test-get-host
+;; db:test-get-cpuload
+;; db:test-get-diskfree
+;; db:test-get-uname
+;; db:test-get-rundir
+;; db:test-get-item-path
+;; db:test-get-run_duration
+;; db:test-get-final_logf
+;; db:test-get-comment
+;; db:test-get-fullname
+
+
+;;======================================================================
+;; R U N C O N T R O L
+;;======================================================================
+
+;; Overall runs browser
+;;
+(define (runs window-id)
+ (let* ((runs-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:fittosize "YES"
+ #:scrollbar "YES"
+ #:numcol 100
+ #:numlin 100
+ #:numcol-visible 7
+ #:numlin-visible 7
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+
+ (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
+ (iup:attribute-set! runs-matrix "WIDTH0" "100")
+
+ ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
+ (iup:hbox
+ (iup:frame
+ #:title "Runs browser"
+ (iup:vbox
+ runs-matrix)))))
+
+;; Browse and control a single run
+;;
+(define (runcontrol window-id)
+ (iup:hbox))
+
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+;; Main Panel
+(define (main-panel window-id)
+ (iup:dialog
+ #:title "Megatest Control Panel"
+ #:menu (dcommon:main-menu)
+ #:shrink "YES"
+ (let ((tabtop (iup:tabs
+ (runs window-id)
+ (tests window-id)
+ (runcontrol window-id)
+ (mtest *toppath* window-id)
+ (rconfig window-id)
+ )))
+ (iup:attribute-set! tabtop "TABTITLE0" "Runs")
+ (iup:attribute-set! tabtop "TABTITLE1" "Tests")
+ (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
+ (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
+ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
+ tabtop)))
+
+(define *current-window-id* 0)
+
+(define (newdashboard dbstruct)
+ (let* ((data (make-hash-table))
+ (keys '()) ;; (db:get-keys dbstruct))
+ (runname "%")
+ (testpatt "%")
+ (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
+ (states '())
+ (statuses '())
+ (nextmintime (current-milliseconds))
+ (my-window-id *current-window-id*))
+ (set! *current-window-id* (+ 1 *current-window-id*))
+ ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
+ (iup:show (main-panel my-window-id))
+ ;; Yes, running iup:show will pop up a new panel
+ ;; (iup:show (main-panel my-window-id))
+ (iup:callback-set! *tim*
+ "ACTION_CB"
+ (lambda (x)
+ ;; Want to dedicate no more than 50% of the time to this so skip if
+ ;; 2x delta time has not passed since last query
+ (if (< nextmintime (current-milliseconds))
+ (let* ((starttime (current-milliseconds))
+ ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
+ (endtime (current-milliseconds)))
+ (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
+ ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+ )
+ (debug:print-info 11 *default-log-port* "Server overloaded"))))))
+
+;; (dboard:data-updaters-set! *data* (make-hash-table))
+(newdashboard #f) ;; *dbstruct-local*)
+(iup:main-loop)
ADDED attic/records-vs-vectors-vs-coops.scm
Index: attic/records-vs-vectors-vs-coops.scm
==================================================================
--- /dev/null
+++ attic/records-vs-vectors-vs-coops.scm
@@ -0,0 +1,110 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;; (include "vg.scm")
+
+;; (declare (uses vg))
+
+(use foof-loop defstruct coops)
+
+(defstruct obj type fill-color angle)
+
+(define (make-vg:obj)(make-vector 3))
+(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
+(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
+(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
+(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
+(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
+(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
+
+(use simple-exceptions)
+(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
+(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
+(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
+(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
+(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
+(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
+(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
+(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
+
+(define-class <vgc> ()
+ ((type)
+ (fill-color)
+ (angle)))
+
+
+;; first use raw vectors
+(print "Using vectors")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vg:obj)))
+ (vg:obj-set-type! obj 'abc)
+ (vg:obj-set-fill-color! obj "green")
+ (vg:obj-set-angle! obj 135)
+ (let ((a (vg:obj-get-type obj))
+ (b (vg:obj-get-fill-color obj))
+ (c (vg:obj-get-angle obj)))
+ obj))))))
+
+;; first use raw vectors with safe mode
+(print "Using vectors (safe mode)")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vgs:obj)))
+ ;; (badobj (make-vector 20)))
+ (vgs:obj-type-set! obj 'abc)
+ (vgs:obj-fill-color-set! obj "green")
+ (vgs:obj-angle-set! obj 135)
+ (let ((a (vgs:obj-type obj))
+ (b (vgs:obj-fill-color obj))
+ (c (vgs:obj-angle obj)))
+ obj))))))
+
+;; first use defstruct
+(print "Using defstruct")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-obj)))
+ (obj-type-set! obj 'abc)
+ (obj-fill-color-set! obj "green")
+ (obj-angle-set! obj 135)
+ (let ((a (obj-type obj))
+ (b (obj-fill-color obj))
+ (c (obj-angle obj)))
+ obj))))))
+
+
+;; first use defstruct
+(print "Using coops")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make <vgc>)))
+ (set! (slot-value obj 'type) 'abc)
+ (set! (slot-value obj 'fill-color) "green")
+ (set! (slot-value obj 'angle) 135)
+ (let ((a (slot-value obj 'type))
+ (b (slot-value obj 'fill-color))
+ (c (slot-value obj 'angle)))
+ obj))))))
ADDED attic/rmtdb.scm
Index: attic/rmtdb.scm
==================================================================
--- /dev/null
+++ attic/rmtdb.scm
@@ -0,0 +1,20 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
ADDED attic/test_records.scm
Index: attic/test_records.scm
==================================================================
--- /dev/null
+++ attic/test_records.scm
@@ -0,0 +1,36 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+;; make-vector-record tests testqueue testname testconfig waitons priority items
+(define (make-tests:testqueue)(make-vector 7 #f))
+(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0))
+(define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
+(define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2))
+(define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3))
+;; items: #f=no items, list=list of items remaining, proc=need to call to get items
+(define-inline (tests:testqueue-get-items vec) (vector-ref vec 4))
+(define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
+(define-inline (tests:testqueue-get-item_path vec) (vector-ref vec 6))
+
+(define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
+(define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
+(define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
+(define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
+(define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
+(define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
+(define-inline (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
+
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -31,37 +31,20 @@
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(include "common_records.scm")
(include "db_records.scm")
-;; client:get-signature
-(define (client:get-signature)
+;; client:get-signature, not used right now but likely needed
+#;(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
-;; Not currently used! But, I think it *should* be used!!!
-#;(define (client:logout serverdat)
- (let ((ok (and (socket? serverdat)
- (cdb:logout serverdat *toppath* (client:get-signature)))))
- ok))
-
-#;(define (client:connect iface port)
- (http-transport:client-connect iface port)
- #;(case (server:get-transport)
- ((rpc) (rpc:client-connect iface port))
- ((http) (http:client-connect iface port))
- ((zmq) (zmq:client-connect iface port))
- (else (rpc:client-connect iface port))))
(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
- (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
- #;(case (server:get-transport)
- ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
- ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
- (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
+ (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios.
@@ -101,24 +84,19 @@
(if server-info
(begin
(remote-server-url-set! *runremote* (server:record->url server-info))
(remote-server-id-set! *runremote* (server:record->id server-info)))))))
(if (and host port server-id)
- (let* ((start-res (case *transport-type*
- ((http)(http-transport:client-connect host port server-id))))
- (ping-res (case *transport-type*
- ((http)(rmt:login-no-auto-client-setup start-res)))))
(if (and start-res
ping-res)
(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
(remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
(debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
start-res)
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
- (case *transport-type*
- ((http)(http-transport:close-connections)))
+ (http-transport:close-connections)
(remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
(thread-sleep! 1)
(client:setup-http areapath remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
DELETED codescanlib.scm
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-;; gotta compile with csc, doesn't work with csi -s for whatever reason
-
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
-
-;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
-(define (load-scm-file scm-file)
- ;;(print "load "scm-file)
- (handle-exceptions
- exn
- '()
- (with-input-from-string
- (conc "("
- (with-input-from-file scm-file read-all)
- ")" )
- read)))
-
-;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
-;; -- be advised:
-;; * this may be fooled by macros, since this code does not take them into account.
-;; * this code does only checks for form (define (<procname> ... ) <body>)
-;; so it excludes from reckoning
-;; - generated functions, as in things like foo-set! from defstructs,
-;; - define-inline, (
-;; - define procname (lambda ..
-;; - etc...
-(define (get-toplevel-procs+file+args+body filename)
- (let* ((scm-tree (load-scm-file filename))
- (procs
- (filter identity
- (map
- (match-lambda
- [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
- [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
- [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
- [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
- (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
- (list defname filename args body)
- #f)]
- [else #f] ) scm-tree))))
- procs))
-
-
-;; given a sexp, return a flat list of atoms in that sexp
-(define (get-atoms-in-body body)
- (cond
- ((null? body) '())
- ((atom? body) (list body))
- (else
- (apply append (map get-atoms-in-body body)))))
-
-;; given a file, return a list of procname, file, list of atoms in said procname
-(define (get-procs+file+atoms file)
- (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
- (res
- (map
- (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (args (caddr item))
- (body (cadddr item))
- (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
- (list proc file atoms)))
- toplevel-proc-items)))
- res))
-
-;; uniquify a list of atoms
-(define (unique-atoms lst)
- (let loop ((lst (flatten lst)) (res '()))
- (if (null? lst)
- (reverse res)
- (let ((c (car lst)))
- (loop (cdr lst) (if (member c res) res (cons c res)))))))
-
-;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
-;; returning alist mapping procname to procname that calls said procname
-(define (get-callers-alist all-procs+file+calls)
- (let* ((all-procs (map car all-procs+file+calls))
- (caller-ht (make-hash-table)))
- ;; let's cross reference with a hash table
- (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
- (for-each (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (calls (caddr item)))
- (for-each (lambda (callee)
- (hash-table-set! caller-ht callee
- (cons proc
- (hash-table-ref caller-ht callee))))
- calls)))
- all-procs+file+calls)
- (map (lambda (x)
- (let ((k (car x))
- (r (unique-atoms (cdr x))))
- (cons k r)))
- (hash-table->alist caller-ht))))
-
-;; create a handy cross-reference of callees to callers in the form of an alist.
-(define (get-xref all-scm-files)
- (let* ((all-procs+file+atoms
- (apply append (map get-procs+file+atoms all-scm-files)))
- (all-procs (map car all-procs+file+atoms))
- (all-procs+file+calls ; proc calls things in calls list
- (map (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (atoms (caddr item))
- (calls
- (filter identity
- (map
- (lambda (x)
- (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
- (member x all-procs))
- x
- #f))
- atoms))))
- (list proc file calls)))
- all-procs+file+atoms))
- (callers (get-callers-alist all-procs+file+calls)))
- callers))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -1,6 +1,6 @@
-;;======================================================================
+;get-u;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
@@ -663,16 +663,16 @@
;;======================================================================
;; L O C K E R S A N D B L O C K E R S
;;======================================================================
;; block further accesses to databases. Call this before shutting db down
-(define (common:db-block-further-queries)
+#;(define (common:db-block-further-queries)
(mutex-lock! *db-access-mutex*)
(set! *db-access-allowed* #f)
(mutex-unlock! *db-access-mutex*))
-(define (common:db-access-allowed?)
+#;(define (common:db-access-allowed?)
(let ((val (begin
(mutex-lock! *db-access-mutex*)
*db-access-allowed*
(mutex-unlock! *db-access-mutex*))))
val))
@@ -2278,95 +2278,10 @@
effective-normalized-load " continuing."))
(debug:print 0 *default-log-port* "Load on " effective-host ", "
first" could not be retrieved. Giving up and continuing."))))))
;;======================================================================
-;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
-;;
-;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
-;; (let* ((loadavg (common:get-cpu-load remote-host))
-;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again
-;; (common:get-num-cpus remote-host)
-;; numcpus-in))
-;; (maxload (if force-maxload
-;; maxload-in
-;; (if (number? maxload-in)
-;; (max maxload-in 0.5)
-;; 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
-;; (first (car loadavg))
-;; (next (cadr loadavg))
-;; (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
-;; ;; numcpus (or could be
-;; ;; maxload) is zero,
-;; ;; crude fallback is to
-;; ;; at least use 1
-;; (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
-;; 0
-;; next))) ;; we will force a conservative calculation any time next is large.
-;; (first-next-avg (/ (+ first next) 2))
-;; ;; add some randomness to the time to break any alignment
-;; ;; where netbatch dumps many jobs to machines simultaneously
-;; (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)
-;; (/ (- 1000 count) 10)
-;; waitdelay)
-;; (- first adjmaxload) ))))
-;; (load-jump-limit (configf:lookup-number *configdat* "setup" "load-jump-limit"))
-;; ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
-;; ;; etc.
-;; (effective-load (common:get-intercept first next))
-;; (effective-host (or remote-host "localhost"))
-;; (normalized-effective-load (/ effective-load numcpus))
-;; (will-wait (> normalized-effective-load maxload)))
-;;
-;; ;; let's let the user know once in a long while that load checking
-;; ;; is happening but not constantly report it
-;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
-;; (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
-;; ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
-;;
-;; (debug:print-info 1 *default-log-port*
-;; "On host: " effective-host
-;; ", effective load: " effective-load
-;; ", numcpus: " numcpus
-;; ", normalized effective load: " normalized-effective-load
-;; )
-;;
-;; (cond
-;; ;; bad data, try again to get the data
-;; ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
-;; (> num-tries 0))
-;; (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
-;; (thread-sleep! 10)
-;; (common:wait-for-cpuload maxload-in numcpus-in waitdelay
-;; count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
-;; ;; need to wait for load to drop
-;; ((and will-wait ;; (> first adjmaxload)
-;; (> count 0))
-;; (debug:print-info 0 *default-log-port*
-;; "Delaying " 15 ;; adjwait
-;; " seconds due to normalized effective load " normalized-effective-load ;; first
-;; " exceeding max of " adjmaxload
-;; " on server " (or remote-host (get-host-name))
-;; " (normalized load-limit: " maxload ") " (if msg msg ""))
-;; (thread-sleep! 15) ;; adjwait)
-;; (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
-;; ((and (> loadjmp (cond
-;; (load-jump-limit load-jump-limit)
-;; ((> numcpus 8)(/ numcpus 2))
-;; ((> numcpus 4)(/ numcpus 1.2))
-;; (else 0.5)))
-;; (> count 0))
-;; (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". "
-;; (if msg msg ""))
-;; (thread-sleep! adjwait)
-;; (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
-;; (else
-;; (if (> num-tries 0)
-;; (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost")))
-;; (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing."))
-;; (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
-;;
(define (get-uname . params)
(let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
(uname #f))
(if (null? (car uname-res))
"unknown"
@@ -2374,24 +2289,10 @@
;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)
- ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
- ;; (let-values
- ;; (((inp oup pid) (process "readlink" (list "-f" inpath))))
- ;; (with-input-from-port inp
- ;; (let loop ((inl (read-line))
- ;; (res #f))
- ;; (print "inl=" inl)
- ;; (if (eof-object? inl)
- ;; (begin
- ;; (close-input-port inp)
- ;; (close-output-port oup)
- ;; ;; (process-wait pid)
- ;; res)
- ;; (loop (read-line) inl))))))
(with-input-from-pipe (conc "readlink -f " inpath) read-line))
;;======================================================================
;; D I S K S P A C E
;;======================================================================
@@ -2627,11 +2528,11 @@
;;======================================================================
;; E N V I R O N M E N T V A R S
;;======================================================================
-(define (bb-check-path #!key (msg "check-path: "))
+#;(define (bb-check-path #!key (msg "check-path: "))
(let ((path (or (get-environment-variable "PATH") "none")))
(debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
(if (string-match "^.*/isoenv-core/.*" path)
(debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
(debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))
@@ -3147,81 +3048,10 @@
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
((equal? status "ABORT") "brown")
(else "black")))
-;;======================================================================
-;; N A N O M S G C L I E N T
-;;======================================================================
-;;
-;;
-;;
-;; (define (common:send-dboard-main-changed)
-;; (let* ((dashboard-ips (mddb:get-dashboards)))
-;; (for-each
-;; (lambda (ipadr)
-;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
-;; (msg (conc "main " *toppath*))
-;; (res (common:nm-send-receive-timeout soc msg)))
-;; (if (not res) ;; couldn't reach that dashboard - remove it from db
-;; (print "ERROR: couldn't reach dashboard " ipadr))
-;; res))
-;; dashboard-ips)))
-;;
-;;
-;; ;;======================================================================
-;; ;; D A S H B O A R D D B
-;; ;;======================================================================
-;;
-;; (define (mddb:open-db)
-;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
-;; (set-busy-handler! db (busy-timeout 10000))
-;; (for-each
-;; (lambda (qry)
-;; (exec (sql db qry)))
-;; (list
-;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
-;; "CREATE TABLE IF NOT EXISTS dashboards (
-;; id INTEGER PRIMARY KEY,
-;; pid INTEGER,
-;; username TEXT,
-;; hostname TEXT,
-;; ipaddr TEXT,
-;; portnum INTEGER,
-;; start_time TIMESTAMP DEFAULT (strftime('%s','now')),
-;; CONSTRAINT hostport UNIQUE (hostname,portnum)
-;; );"
-;; ))
-;; db))
-;;
-;; ;; register a dashboard
-;; ;;
-;; (define (mddb:register-dashboard port)
-;; (let* ((pid (current-process-id))
-;; (hostname (get-host-name))
-;; (ipaddr (server:get-best-guess-address hostname))
-;; (username (current-user-name)) ;; (car userinfo)))
-;; (db (mddb:open-db)))
-;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
-;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
-;; pid username hostname ipaddr port)
-;; (close-database db)))
-;;
-;; ;; unregister a monitor
-;; ;;
-;; (define (mddb:unregister-dashboard host port)
-;; (let* ((db (mddb:open-db)))
-;; (print "Register unregister monitor, host:port=" host ":" port)
-;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
-;; (close-database db)))
-;;
-;; ;; get registered dashboards
-;; ;;
-;; (define (mddb:get-dashboards)
-;; (let ((db (mddb:open-db)))
-;; (query fetch-column
-;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;======================================================================
;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
;;======================================================================
;;
@@ -3611,14 +3441,14 @@
#t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
(thread-join! thread))
)))
(hash-table-keys *common:thread-punchlist*)))
-;;======================================================================
-;; (define *common:telemetry-log-state* 'startup)
+#;(define *common:telemetry-log-state* 'startup)
+#;(define *common:telemetry-log-socket* #f)
;; (define *common:telemetry-log-socket* #f)
-;;
+#;(define (common:telemetry-log-open)
;; (define (common:telemetry-log-open)
;; (if (eq? *common:telemetry-log-state* 'startup)
;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
;; (serverport (configf:lookup-number *configdat* "telemetry" "port"))
;; (user (or (get-environment-variable "USER") "unknown"))
@@ -3634,11 +3464,11 @@
;; ;;(udp-bind! s #f 0)
;; (udp-connect! s serverhost serverport)
;; (set! *common:telemetry-log-socket* s)
;; 'open)
;; 'not-needed))))))
-;;
+#;(define (common:telemetry-log event #!key (payload '()))
;; (define (common:telemetry-log event #!key (payload '()))
;; (if (eq? *common:telemetry-log-state* 'startup)
;; (common:telemetry-log-open))
;;
;; (if (eq? 'open *common:telemetry-log-state*)
@@ -3661,11 +3491,11 @@
;; (z3:encode-buffer
;; (with-output-to-string (lambda () (pp payload))))))
;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
;; toppath":"payload-serialized)))
;; (udp-send *common:telemetry-log-socket* msg))))))
-;;
+#;(define (common:telemetry-log-close)
;; (define (common:telemetry-log-close)
;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
;; (handle-exceptions
;; exn
;; (begin
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -146,13 +146,14 @@
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
+;; Useful stuff. Do not remove - commented and removed to trim mem usage for now (might make no difference).
;; Brandon's debug printer shortcut (indulge me :)
-(define *BB-process-starttime* (current-milliseconds))
-(define (BB> . in-args)
+#;(define *BB-process-starttime* (current-milliseconds))
+#;(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location "??"))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
@@ -168,20 +169,20 @@
(list 0 *default-log-port*
(conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
in-args)))
(apply debug:print dp-args))))
-(define *BBpp_custom_expanders_list* (make-hash-table))
+#;(define *BBpp_custom_expanders_list* (make-hash-table))
;; register hash tables with BBpp.
-(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
(cons hash-table? hash-table->alist))
;; test name converter
-(define (BBpp_custom_converter arg)
+#;(define (BBpp_custom_converter arg)
(let ((res #f))
(for-each
(lambda (custom-type-name)
(let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
(custom-type-test (car custom-type-info))
@@ -189,11 +190,11 @@
(when (and (not res) (custom-type-test arg))
(set! res (custom-type-converter arg)))))
(hash-table-keys *BBpp_custom_expanders_list*))
(if res (BBpp_ res) arg)))
-(define (BBpp_ arg)
+#;(define (BBpp_ arg)
(cond
;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
((hash-table? arg)
(let ((al (hash-table->alist arg)))
@@ -202,11 +203,11 @@
;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
-(define (BBpp arg)
+#;(define (BBpp arg)
(pp (BBpp_ arg)))
;(use define-macro)
(define-syntax inspect
(syntax-rules ()
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -126,17 +126,15 @@
(debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
"(lambda (ht) #f)")))
((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
- ;; (print "fullcmd=" fullcmd)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- ;; (print "exn=" (condition->list exn))
(set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
(if (or allow-system
(not (member cmdtype '("system" "shell" "sh"))))
(with-input-from-string fullcmd
(lambda ()
@@ -265,17 +263,10 @@
;;
(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
(sections #f) (settings (make-hash-table)) (keep-filenames #f)
(post-section-procs '()) (apply-wildcards #t) )
(debug:print 9 *default-log-port* "START: " path)
-;; (if *configdat*
-;; (common:save-pkt `((action . read-config)
-;; (f . ,(cond ((string? path) path)
-;; ((port? path) "port")
-;; (else (conc path))))
-;; (T . configf))
-;; *configdat* #t add-only: #t))
(if (and (not (port? path))
(not (common:file-exists? path))) ;; for case where we are handed a port
(begin
(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
ADDED danglers-to-ignore.txt
Index: danglers-to-ignore.txt
==================================================================
--- /dev/null
+++ danglers-to-ignore.txt
@@ -0,0 +1,4 @@
+spublish:lst->path
+megatest-param->mtutil-param
+add-target-mapper
+add-runname-mapper
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -308,11 +308,10 @@
(conc "*"menu-item-text)
#:action
(lambda (obj)
(let* ((scheme-match (string-match "^#(\\(.*)" command-line)))
- ;;(BB> "cmdline is >"command-line"<")
(common:with-env-vars
;; TODO: with-env-vars <runconfig target vars, env-override vars from mtest>
;; TODO: with-env-vars MT_*
(runs:get-mt-env-alist run-id run-name target test-name item-path)
@@ -321,11 +320,10 @@
(begin
(handle-exceptions
exn
(print "error with custom menu scheme, exn=" exn)
(begin
- ;;(BB> "gonna eval it!")
(eval (with-input-from-string (cadr scheme-match) read)))))
(common:run-a-command command-line with-vars: #t))))))))
#f)))
vars)))
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -171,19 +171,19 @@
(lambda (x)
(refreshdat)
(if *exit-started*
(set! *exit-started* 'ok))))))
-(define (main-window setuptab fsltab collateraltab toolstab)
- (iup:show
- (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES"
- (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab)))
- (iup:attribute-set! tabtop "TABTITLE0" "Setup")
- (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
- (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
- (iup:attribute-set! tabtop "TABTITLE3" "Tools")
- tabtop))))
+;; (define (main-window setuptab fsltab collateraltab toolstab)
+;; (iup:show
+;; (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES"
+;; (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab)))
+;; (iup:attribute-set! tabtop "TABTITLE0" "Setup")
+;; (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
+;; (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
+;; (iup:attribute-set! tabtop "TABTITLE3" "Tools")
+;; tabtop))))
;; BUG: Remember to re-instate this!!!!
;; (on-exit (lambda ()
;; (let ((tdb (tasks:open-db)))
;; ;; (print "On-exit called")
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -754,13 +754,13 @@
#:numlin-visible 5
#:click-cb (lambda (obj lin col status)
;; (if (equal? col 6)
(let* ((mtrx-rc (conc lin ":" 6))
(fname (iup:attribute obj mtrx-rc))
- (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7))))
+ (stepname (iup:attribute obj (conc lin ":" 1)))
+ (comment (iup:attribute obj (conc lin ":" 7))))
(case col
-
((7) (print "Comment from step "stepname": "comment))
((8) (ezsteps:spawn-run-from testdat stepname #t))
((9) (ezsteps:spawn-run-from testdat stepname #f))
(else (view-a-log fname))))))))
;; (let loop ((count 0))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -48,11 +48,10 @@
;; (declare (uses dashboard-main))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
-(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
@@ -351,11 +350,11 @@
tests-tree ;; used in newdashboard
)
;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
+#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
(cons dboard:tabdat?
(lambda (tabdat-item)
(filter
(lambda (alist-entry)
(member (car alist-entry)
@@ -501,11 +500,11 @@
duration
)
;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
+#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
(cons dboard:rundat?
(lambda (tabdat-item)
(filter
(lambda (alist-entry)
(member (car alist-entry)
@@ -1829,37 +1828,10 @@
(define (new-tree-path->run-id rdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
#f))
-
-;; (define (dboard:get-tests-dat tabdat run-id last-update)
-;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
-;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
-;; run-id
-;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
-;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
-;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
-;; #f #f ;; offset limit
-;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in
-;; #f #f ;; sort-by sort-order
-;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
-;; (if (dboard:tabdat-filters-changed tabdat)
-;; 0
-;; last-update)
-;; *dashboard-mode*)
-;; '()))) ;; get 'em all
-;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
-;; (sort tdat (lambda (a b)
-;; (let* ((aval (vector-ref a 2))
-;; (bval (vector-ref b 2))
-;; (anum (string->number aval))
-;; (bnum (string->number bval)))
-;; (if (and anum bnum)
-;; (< anum bnum)
-;; (string<= aval bval)))))))
-
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
@@ -2307,11 +2279,10 @@
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
- ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (rmt:get-run-info run-id))
@@ -2473,17 +2444,10 @@
(mark-for-update tabdat))))
(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
(iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
- ;; (set! hide-empty (iup:button "HideEmpty"
- ;; ;; #:expand HORIZONTAL"
- ;; #:expand "NO" #:size "80x15"
- ;; #:action (lambda (obj)
- ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
- ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
- ;; (mark-for-update tabdat))))
(set! hide (iup:button "Hide"
#:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
#:action (lambda (obj)
(dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
@@ -2497,23 +2461,19 @@
(iup:attribute-set! show "BGCOLOR" sel-color)
(iup:attribute-set! hide "BGCOLOR" nonsel-color)
(mark-for-update tabdat))))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
- ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
(iup:vbox
(iup:hbox hide show)
sort-lb)))
)
;; insert extra widget here
(if extra-widget
extra-widget
(iup:hbox)) ;; empty widget
-
-
-
)))
(let* ((status-toggles (map (lambda (status)
(iup:toggle (conc status)
@@ -3036,11 +2996,10 @@
(or please-update-buttons
(and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
(> modtime (- last-db-update-time 3)) ;; add three seconds of margin
(> (current-seconds)(+ last-db-update-time 1)))))
-;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
;; (tasks:open-db)
@@ -3259,26 +3218,13 @@
;; (dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-max-row-set! tabdat 0)
(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
(update-rundat tabdat
runpatt
- ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
- testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
- ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
-
- targpatt
-
- ;; old method
- ;; (let ((res '()))
- ;; (for-each (lambda (key)
- ;; (if (not (equal? key "runname"))
- ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
- ;; (if val (set! res (cons (list key val) res))))))
- ;; (dboard:tabdat-dbkeys tabdat))
- ;; res)
- )))))
+ testpatt
+ targpatt)))))
;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
@@ -3293,16 +3239,10 @@
(canvas-clear! cnv)
(vg:draw dwg tabdat)
(mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
-;; doesn't work.
-;;
-;;(define (gotoescape tabdat escape)
-;; (or (dboard:tabdat-layout-update-ok tabdat)
-;; (escape #t)))
-
(define (dboard:graph-db-open dbstr)
(let* ((parts (string-split dbstr ":"))
(dbpth (if (< (length parts) 2) ;; assume then a filename was provided
dbstr
(if (equal? (car parts) "sqlite3")
ADDED datashare-src/datashare.scm
Index: datashare-src/datashare.scm
==================================================================
--- /dev/null
+++ datashare-src/datashare.scm
@@ -0,0 +1,825 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+(use ssax)
+(use sxml-serializer)
+(use sxml-modifications)
+(use regex)
+(use srfi-69)
+(use regex-case)
+(use posix)
+(use json)
+(use csv)
+(use srfi-18)
+(use format)
+
+(require-library iup)
+(import (prefix iup iup:))
+(require-library ini-file)
+(import (prefix ini-file ini:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (uses configf))
+(declare (uses tree))
+(declare (uses margs))
+;; (declare (uses dcommon))
+;; (declare (uses launch))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses synchash))
+;; (declare (uses server))
+;; (declare (uses megatest-version))
+;; (declare (uses tbd))
+
+(include "megatest-fossil-hash.scm")
+
+;;
+;; GLOBALS
+;;
+(define *datashare:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define datashare:help (conc "Usage: datashare [action [params ...]]
+
+Note: run datashare without parameters to start the gui.
+
+ list-areas : List the allowed areas
+
+ list-versions <area> : List versions available in <area>
+ options : -full, -vpatt patt
+
+ publish <path> <area> <version> : Publish data for area and with version
+
+ get <area> <version> : Get a link to data, put the link in destpath
+ options : -i iteration
+
+ update <area> : Update the link to data to the latest iteration.
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
+;; testing
+(define (make-datashare:pkg)(make-vector 15))
+(define-inline (datashare:pkg-get-id vec) (vector-ref vec 0))
+(define-inline (datashare:pkg-get-area vec) (vector-ref vec 1))
+(define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2))
+(define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3))
+(define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4))
+(define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5))
+(define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6))
+(define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7))
+(define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8))
+(define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9))
+(define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10))
+(define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11))
+(define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12))
+(define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13))
+(define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14))
+(define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val))
+(define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val))
+(define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val))
+(define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val))
+(define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val))
+(define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val))
+(define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val))
+(define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val))
+(define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val))
+(define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val))
+(define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val))
+(define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val))
+(define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val))
+(define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val))
+(define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val))
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+(define (datashare:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (sqlite3:execute db qry))
+ (list
+ "CREATE TABLE pkgs
+ (id INTEGER PRIMARY KEY,
+ area TEXT,
+ version_name TEXT,
+ store_type TEXT DEFAULT 'copy',
+ copied INTEGER DEFAULT 0,
+ source_path TEXT,
+ stored_path TEXT,
+ iteration INTEGER DEFAULT 0,
+ submitter TEXT,
+ datetime TIMESTAMP DEFAULT (strftime('%s','now')),
+ storegrp TEXT,
+ datavol INTEGER,
+ quality TEXT,
+ disk_id INTEGER,
+ comment TEXT);"
+ "CREATE TABLE refs
+ (id INTEGER PRIMARY KEY,
+ pkg_id INTEGER,
+ destlink TEXT);"
+ "CREATE TABLE disks
+ (id INTEGER PRIMARY KEY,
+ storegrp TEXT,
+ path TEXT);")))
+
+(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
+ (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
+ (next-iteration 0))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:for-each-row
+ (lambda (iteration)
+ (if (and (number? iteration)
+ (>= iteration next-iteration))
+ (set! next-iteration (+ iteration 1))))
+ iter-qry area version-name)
+ ;; now store the data
+ (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment)
+ VALUES (?,?,?,?,?,?,?,?);"
+ area version-name next-iteration (conc store-type) submitter source-path quality comment)))
+ (sqlite3:finalize! iter-qry)
+ next-iteration))
+
+(define (datashare:get-id db area version-name iteration)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
+ area version-name iteration)
+ res))
+
+(define (datashare:set-stored-path db id path)
+ (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
+
+(define (datashare:set-copied db id value)
+ (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
+
+(define (datashare:get-pkg-record db area version-name iteration)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (apply vector a b)))
+ db
+ "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
+ area
+ version-name
+ iteration)
+ res))
+
+;; take version-name iteration and register or update "lastest/0"
+;;
+(define (datashare:set-latest db id area version-name iteration)
+ (let* ((rec (datashare:get-pkg-record db area version-name iteration))
+ (latest-id (datashare:get-id db area "latest" 0))
+ (stored-path (datashare:pkg-get-stored_path rec)))
+ (if latest-id ;; have a record - bump the link pointer
+ (datashare:set-stored-path db latest-id stored-path)
+ (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))
+
+;; set a package ref, this is the location where the link back to the stored data
+;; is put.
+;;
+;; if there is nothing at that location then the record can be removed
+;; if there are no refs for a particular pkg-id then that pkg-id is a
+;; candidate for removal
+;;
+(define (datashare:record-pkg-ref db pkg-id dest-link)
+ (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
+
+(define (datashare:count-refs db pkg-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ db
+ "SELECT count(id) FROM refs WHERE pkg_id=?;"
+ pkg-id)
+ res))
+
+;; Create the sqlite db
+(define (datashare:open-db configdat)
+ (let ((path (configf:lookup configdat "database" "location")))
+ (if (and path
+ (directory? path)
+ (file-read-access? path))
+ (let* ((dbpath (conc path "/datashare.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (common:file-exists? dbpath))
+ (handler (make-busy-timeout 136000)))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit))
+ (set! db (sqlite3:open-database dbpath)))
+ (if *db-write-access* (sqlite3:set-busy-handler! db handler))
+ (if (not dbexists)
+ (begin
+ (datashare:initialize-db db)))
+ db)
+ (print "ERROR: invalid path for storing database: " path))))
+
+(define (open-run-close-exception-handling proc idb . params)
+ (handle-exceptions
+ exn
+ (let ((sleep-time (random 30))
+ (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+ (case err-status
+ ((busy)
+ (thread-sleep! sleep-time))
+ (else
+ (print "EXCEPTION: database overloaded or unreadable.")
+ (print " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print "exn=" (condition->list exn))
+ (print " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (print-call-chain (current-error-port))
+ (thread-sleep! sleep-time)
+ (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
+ (apply open-run-close-exception-handling proc idb params))
+ (apply open-run-close-no-exception-handling proc idb params)))
+
+(define (open-run-close-no-exception-handling proc idb . params)
+ ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
+ (let* ((db (cond
+ ((sqlite3:database? idb) idb)
+ ((not idb) (print "ERROR: cannot open-run-close with #f anymore"))
+ ((procedure? idb) (idb))
+ (else (print "ERROR: cannot open-run-close with #f anymore"))))
+ (res #f))
+ (set! res (apply proc db params))
+ (if (not idb)(sqlite3:finalize! dbstruct))
+ ;; (print "open-run-close-no-exception-handling END" )
+ res))
+
+(define open-run-close open-run-close-no-exception-handling)
+
+(define (datashare:get-pkgs db area-filter version-filter iter-filter)
+ (let ((res '()))
+ (sqlite3:for-each-row ;; replace with fold ...
+ (lambda (a . b)
+ (set! res (cons (list->vector (cons a b)) res)))
+ db
+ (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
+ " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
+ area-filter version-filter)
+ (reverse res)))
+
+(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
+ (let ((dat '())
+ (res #f))
+ (sqlite3:for-each-row ;; replace with fold ...
+ (lambda (a . b)
+ (set! dat (cons (list->vector (cons a b)) dat)))
+ db
+ (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
+ " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
+ area-name version-name)
+ ;; now filter for iteration, either max if #f or specific one
+ (if (null? dat)
+ #f
+ (let loop ((hed (car dat))
+ (tal (cdr dat))
+ (cur 0))
+ (let ((itr (datashare:pkg-get-iteration hed)))
+ (if (equal? itr iteration) ;; this is the one if iteration is specified
+ hed
+ (if (null? tal)
+ hed
+ (loop (car tal)(cdr tal)))))))))
+
+(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
+ (let ((res '())
+ (data (make-hash-table)))
+ (sqlite3:for-each-row
+ (lambda (version-name submitter iteration submitted-time comment)
+ ;; 0 1 2 3 4
+ (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
+ db
+ "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
+ (or version-patt "%"))
+ (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))
+
+;;======================================================================
+;; DATA IMPORT/EXPORT
+;;======================================================================
+
+(define (datashare:import-data configdat source-path dest-path area version iteration)
+ (let* ((space-avail (car dest-path))
+ (disk-path (cdr dest-path))
+ (targ-path (conc disk-path "/" area "/" version "/" iteration))
+ (id (datashare:get-id db area version iteration))
+ (db (datashare:open-db configdat)))
+ (if (> space-avail 10000) ;; dumb heuristic
+ (begin
+ (create-directory targ-path #t)
+ (datashare:set-stored-path db id targ-path)
+ (print "Running command: rsync -av " source-path "/ " targ-path "/")
+ (let ((th1 (make-thread (lambda ()
+ (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
+ (process-wait pid)
+ (datashare:set-copied db id "yes")
+ (sqlite3:finalize! db)))
+ "Data copy")))
+ (thread-start! th1))
+ #t)
+ (begin
+ (print "ERROR: Not enough space in storage area " dest-path)
+ (datashare:set-copied db id "no")
+ (sqlite3:finalize! db)
+ #f))))
+
+(define (datashare:get-areas configdat)
+ (let* ((areadat (configf:get-section configdat "areas"))
+ (areas (if areadat (map car areadat) '())))
+ areas))
+
+(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
+ ;; input checks
+ (cond
+ ((not (member area-name (datashare:get-areas configdat)))
+ (cons #f (conc "Illegal area name \"" area-name "\"")))
+ (else
+ (let ((db (datashare:open-db configdat))
+ (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment))
+ (dest-store (datashare:get-best-storage configdat)))
+ (if iteration
+ (if (eq? 'copy publish-type)
+ (begin
+ (datashare:import-data configdat spath dest-store area-name version iteration)
+ (let ((id (datashare:get-id db area-name version iteration)))
+ (datashare:set-latest db id area-name version iteration)))
+ (let ((id (datashare:get-id db area-name version iteration)))
+ (datashare:set-stored-path db id spath)
+ (datashare:set-copied db id "yes")
+ (datashare:set-copied db id "n/a")
+ (datashare:set-latest db id area-name version iteration)))
+ (print "ERROR: Failed to get an iteration number"))
+ (sqlite3:finalize! db)
+ (cons #t "Successfully saved data")))))
+
+(define (datashare:get-best-storage configdat)
+ (let* ((storage (configf:lookup configdat "settings" "storage"))
+ (store-areas (if storage (string-split storage) '())))
+ (print "Looking for available space in " store-areas)
+ (datashare:find-most-space store-areas)))
+
+;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))
+
+(define (datashare:find-most-space paths)
+ (fold (lambda (area res)
+ ;; (print "area=" area " res=" res)
+ (let ((maxspace (car res))
+ (currpath (cdr res)))
+ ;; (print currpath " " maxspace)
+ (if (file-write-access? area)
+ (let ((currspace (string->number
+ (list-ref
+ (with-input-from-pipe
+ ;; (conc "df --output=avail " area)
+ (conc "df -B1000000 " area)
+ ;; (lambda ()(read)(read))
+ (lambda ()(read-line)(string-split (read-line))))
+ 3))))
+ (if (> currspace maxspace)
+ (cons currspace area)
+ res))
+ res)))
+ (cons 0 #f)
+ paths))
+
+;; remove existing link and if possible ...
+;; create path to next of tip of target, create link back to source
+(define (datashare:build-dir-make-link source target)
+ (if (common:file-exists? target)(datashare:backup-move target))
+ (create-directory (pathname-directory target) #t)
+ (create-symbolic-link source target))
+
+(define (datashare:backup-move path)
+ (let* ((trashdir (conc (pathname-directory path) "/.trash"))
+ (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+ (create-directory trashdir #t)
+ (if (directory? path)
+ (system (conc "mv " path " " trashfile))
+ (file-move path trash-file))))
+
+;;======================================================================
+;; GUI
+;;======================================================================
+
+;; The main menu
+(define (datashare:main-menu)
+ (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+ (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
+ (iup:menu-item "Open" action: (lambda (obj)
+ (iup:show (iup:file-dialog))
+ (print "File->open " obj)))
+ (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
+ (iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
+ (iup:menu-item "Tools" (iup:menu
+ (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+ ;; (iup:menu-item "Show dialog" #:action (lambda (obj)
+ ;; (show message-window
+ ;; #:modal? #t
+ ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+ ;; ;; #:x 'mouse
+ ;; ;; #:y 'mouse
+ ;; )
+ ))))
+
+(define (datashare:publish-view configdat)
+ ;; (pp (hash-table->alist configdat))
+ (let* ((areas (configf:get-section configdat "areas"))
+ (label-size "70x")
+ (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
+ (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x"))
+ (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
+ (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
+ (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
+ ;; (copy-link (iup:toggle #:expand "HORIZONTAL"))
+ ;; (iteration (iup:textbox #:expand "YES" #:size "20x"))
+ ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
+ (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
+ (comment-tb (iup:textbox #:expand "YES" #:multiline "YES"))
+ (source-tb (iup:textbox #:expand "HORIZONTAL"
+ #:value (or (configf:lookup configdat "settings" "basepath")
+ "")))
+ (publish (lambda (publish-type)
+ (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0))
+ (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
+ (area-path (cadr area-dat))
+ (area-name (car area-dat))
+ (version (iup:attribute version-tb "VALUE"))
+ (comment (iup:attribute comment-tb "VALUE"))
+ (spath (iup:attribute source-tb "VALUE"))
+ (submitter (current-user-name))
+ (quality 2))
+ (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
+ (copy (iup:button "Copy and Publish"
+ #:expand "HORIZONTAL"
+ #:action (lambda (obj)
+ (publish 'copy))))
+ (link (iup:button "Link and Publish"
+ #:expand "HORIZONTAL"
+ #:action (lambda (obj)
+ (publish 'link))))
+ (browse-btn (iup:button "Browse"
+ #:size "40x"
+ #:action (lambda (obj)
+ (let* ((fd (iup:file-dialog #:dialogtype "DIR"))
+ (top (iup:show fd #:modal? "YES")))
+ (iup:attribute-set! source-tb "VALUE"
+ (iup:attribute fd "VALUE"))
+ (iup:destroy! fd))))))
+ (print "areas")
+ ;; (pp areas)
+ (fold (lambda (areadat num)
+ ;; (print "Adding num=" num ", areadat=" areadat)
+ (iup:attribute-set! areas-sel (conc num) (car areadat))
+ (+ 1 num))
+ 1 areas)
+ (iup:vbox
+ (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter
+ areas-sel)
+ (iup:hbox (iup:label "Version:" #:size label-size) version-tb)
+ ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link)
+ ;; (iup:label "Iteration:") iteration)
+ (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb)
+ (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn)
+ (iup:hbox copy link))))
+
+(define (datashare:lst->path pathlst)
+ (conc "/" (string-intersperse (map conc pathlst) "/")))
+
+(define (datashare:path->lst path)
+ (string-split path "/"))
+
+(define (datashare:pathdat-apply-heuristics configdat path)
+ (cond
+ ((common:file-exists? path) "found")
+ (else (conc path " not installed"))))
+
+(define (datashare:get-view configdat)
+ (iup:vbox
+ (iup:hbox
+ (let* ((label-size "60x")
+ ;; filter elements
+ (area-filter "%")
+ (version-filter "%")
+ (iter-filter ">= 0")
+ ;; reverse lookup from path to data for src and installed
+ (srcdat (make-hash-table)) ;; reverse lookup
+ (installed-dat (make-hash-table))
+ ;; config values
+ (basepath (configf:lookup configdat "settings" "basepath"))
+ ;; gui elements
+ (submitter (iup:label "" #:expand "HORIZONTAL"))
+ (date-submitted (iup:label "" #:expand "HORIZONTAL"))
+ (comment (iup:label "" #:expand "HORIZONTAL"))
+ (copy-link (iup:label "" #:expand "HORIZONTAL"))
+ (quality (iup:label "" #:expand "HORIZONTAL"))
+ (installed-status (iup:label "" #:expand "HORIZONTAL"))
+ ;; misc
+ (curr-record #f)
+ ;; (source-data (iup:label "" #:expand "HORIZONTAL"))
+ (tb (iup:treebox
+ #:value 0
+ #:name "Packages"
+ #:expand "YES"
+ #:addexpanded "NO"
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
+ (record (hash-table-ref/default srcdat path #f)))
+ (if record
+ (begin
+ (set! curr-record record)
+ (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record))
+ (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
+ (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record))
+ (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record))
+ (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record))
+ ))
+ ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
+ ))))
+ (tb2 (iup:treebox
+ #:value 0
+ #:name "Installed"
+ #:expand "YES"
+ #:addexpanded "NO"
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
+ (status (hash-table-ref/default installed-dat path #f)))
+ (iup:attribute-set! installed-status "TITLE" (if status status ""))
+ ))))
+ (refresh (lambda (obj)
+ (let* ((db (datashare:open-db configdat))
+ (areas (or (configf:get-section configdat "areas") '())))
+ ;;
+ ;; first update the Sources
+ ;;
+ (for-each
+ (lambda (pkgitem)
+ (let* ((pkg-path (list (datashare:pkg-get-area pkgitem)
+ (datashare:pkg-get-version_name pkgitem)
+ (datashare:pkg-get-iteration pkgitem)))
+ (pkg-id (datashare:pkg-get-id pkgitem))
+ (path (datashare:lst->path pkg-path)))
+ ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
+ (if (not (hash-table-ref/default srcdat path #f))
+ (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
+ ;; (print "path=" path " pkgitem=" pkgitem)
+ (hash-table-set! srcdat path pkgitem)))
+ (datashare:get-pkgs db area-filter version-filter iter-filter))
+ ;;
+ ;; then update the installed
+ ;;
+ (for-each
+ (lambda (area)
+ (let* ((path (conc "/" (cadr area)))
+ (fullpath (conc basepath path)))
+ (if (not (hash-table-ref/default installed-dat path #f))
+ (tree:add-node tb2 "Installed" (datashare:path->lst path)))
+ (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
+ areas)
+ (sqlite3:finalize! db))))
+ (apply (iup:button "Apply"
+ #:action
+ (lambda (obj)
+ (if curr-record
+ (let* ((area (datashare:pkg-get-area curr-record))
+ (stored-path (datashare:pkg-get-stored_path curr-record))
+ (source-type (datashare:pkg-get-store_type curr-record))
+ (source-path (case source-type ;; (equal? source-type "link"))
+ ((link)(datashare:pkg-get-source-path curr-record))
+ ((copy)stored-path)
+ (else #f)))
+ (dest-stub (configf:lookup configdat "areas" area))
+ (target-path (conc basepath "/" dest-stub)))
+ (datashare:build-dir-make-link stored-path target-path)
+ (print "Creating link from " stored-path " to " target-path)))))))
+ (iup:vbox
+ (iup:hbox tb tb2)
+ (iup:frame
+ #:title "Source Info"
+ (iup:vbox
+ (iup:hbox (iup:button "Refresh" #:action refresh) apply)
+ (iup:hbox (iup:label "Submitter: ") ;; #:size label-size)
+ submitter
+ (iup:label "Submitted on: ") ;; #:size label-size)
+ date-submitted)
+ (iup:hbox (iup:label "Data stored: ")
+ copy-link
+ (iup:label "Quality: ")
+ quality)
+ (iup:hbox (iup:label "Comment: ")
+ comment)))
+ (iup:frame
+ #:title "Installed Info"
+ (iup:vbox
+ (iup:hbox (iup:label "Installed status/path: ") installed-status)))
+ )))))
+
+(define (datashare:manage-view configdat)
+ (iup:vbox
+ (iup:hbox
+ (iup:button "Pushme"
+ #:expand "YES"
+ ))))
+
+(define (datashare:gui configdat)
+ (iup:show
+ (iup:dialog
+ #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))
+ #:menu (datashare:main-menu)
+ (let* ((tabs (iup:tabs
+ #:tabchangepos-cb (lambda (obj curr prev)
+ (set! *datashare:current-tab-number* curr))
+ (datashare:publish-view configdat)
+ (datashare:get-view configdat)
+ (datashare:manage-view configdat)
+ )))
+ ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
+ (iup:attribute-set! tabs "TABTITLE0" "Publish")
+ (iup:attribute-set! tabs "TABTITLE1" "Get")
+ (iup:attribute-set! tabs "TABTITLE2" "Manage")
+ ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
+ tabs)))
+ (iup:main-loop))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+
+(define (datashare:do-as-calling-user proc)
+ (let ((eid (current-effective-user-id))
+ (cid (current-user-id)))
+ (if (not (eq? eid cid)) ;; running suid
+ (set! (current-effective-user-id) cid))
+ ;; (print "running as " (current-effective-user-id))
+ (proc)
+ (if (not (eq? eid cid))
+ (set! (current-effective-user-id) eid))))
+
+(define (datashare:find name paths)
+ (if (null? paths)
+ #f
+ (let loop ((hed (car paths))
+ (tal (cdr paths)))
+ (if (common:file-exists? (conc hed "/" name))
+ hed
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)))))))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (datashare:load-config exe-dir exe-name)
+ (let* ((fname (conc exe-dir "/." exe-name ".config")))
+ (ini:property-separator-patt " * *")
+ (ini:property-separator #\space)
+ (if (common:file-exists? fname)
+ ;; (ini:read-ini fname)
+ (read-config fname #f #t)
+ (make-hash-table))))
+
+(define (datashare:process-action configdat action . args)
+ (case (string->symbol action)
+ ((get)
+ (if (< (length args) 2)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1))
+ (let* ((basepath (configf:lookup configdat "settings" "basepath"))
+ (db (datashare:open-db configdat))
+ (area (car args))
+ (version (cadr args)) ;; iteration
+ (remargs (args:get-args args '("-i") '() args:arg-hash 0))
+ (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
+ (curr-record (datashare:get-pkg db area version iteration: iteration)))
+ (if (not curr-record)
+ (begin
+ (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
+ (exit 1))
+ (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
+ (source-type (datashare:pkg-get-store_type curr-record))
+ (source-path (case source-type ;; (equal? source-type "link"))
+ ((link) (datashare:pkg-get-source-path curr-record))
+ ((copy) stored-path)
+ (else #f)))
+ (dest-stub (configf:lookup configdat "areas" area))
+ (target-path (conc basepath "/" dest-stub)))
+ (datashare:build-dir-make-link stored-path target-path)
+ (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
+ (sqlite3:finalize! db)
+ (print "Creating link from " stored-path " to " target-path))))))
+ ((publish)
+ (if (< (length args) 3)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1))
+ (let* ((srcpath (list-ref args 0))
+ (areaname (list-ref args 1))
+ (version (list-ref args 2))
+ (remargs (args:get-args (drop args 2)
+ '("-type" ;; link or copy (default is copy)
+ "-m")
+ '()
+ args:arg-hash
+ 0))
+ (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
+ (comment (or (args:get-arg "-m") ""))
+ (submitter (current-user-name))
+ (quality (args:get-arg "-quality"))
+ (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
+ (if (not (car publish-res))
+ (begin
+ (print "ERROR: " (cdr publish-res))
+ (exit 1))))))
+ ((list-versions)
+ (let ((area-name (car args)) ;; version patt full print
+ (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
+ (db (datashare:open-db configdat))
+ (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
+ ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
+ (map (lambda (x)
+ (if (args:get-arg "-full")
+ (format #t
+ "~10a~10a~4a~27a~30a\n"
+ (vector-ref x 0)
+ (vector-ref x 1)
+ (vector-ref x 2)
+ (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
+ (conc "\"" (vector-ref x 4) "\""))
+ (print (vector-ref x 0))))
+ versions)
+ (sqlite3:finalize! db)))))
+
+;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
+ (if (common:file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (exe-name (pathname-file (car (argv))))
+ (exe-dir (or (pathname-directory prog)
+ (datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+ (configdat (datashare:load-config exe-dir exe-name)))
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print datashare:help))
+ ((list-areas)
+ (map print (datashare:get-areas configdat)))
+ (else
+ (print "ERROR: Unrecognised command. Try \"datashare help\""))))
+ ;; multi-word commands
+ ((null? rema)(datashare:gui configdat))
+ ((>= (length rema) 2)
+ (apply datashare:process-action configdat (car rema)(cdr rema)))
+ (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
+
+(main)
DELETED datashare.scm
Index: datashare.scm
==================================================================
--- datashare.scm
+++ /dev/null
@@ -1,825 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-(use ssax)
-(use sxml-serializer)
-(use sxml-modifications)
-(use regex)
-(use srfi-69)
-(use regex-case)
-(use posix)
-(use json)
-(use csv)
-(use srfi-18)
-(use format)
-
-(require-library iup)
-(import (prefix iup iup:))
-(require-library ini-file)
-(import (prefix ini-file ini:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (uses configf))
-(declare (uses tree))
-(declare (uses margs))
-;; (declare (uses dcommon))
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses synchash))
-;; (declare (uses server))
-;; (declare (uses megatest-version))
-;; (declare (uses tbd))
-
-(include "megatest-fossil-hash.scm")
-
-;;
-;; GLOBALS
-;;
-(define *datashare:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define datashare:help (conc "Usage: datashare [action [params ...]]
-
-Note: run datashare without parameters to start the gui.
-
- list-areas : List the allowed areas
-
- list-versions <area> : List versions available in <area>
- options : -full, -vpatt patt
-
- publish <path> <area> <version> : Publish data for area and with version
-
- get <area> <version> : Get a link to data, put the link in destpath
- options : -i iteration
-
- update <area> : Update the link to data to the latest iteration.
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
-;; testing
-(define (make-datashare:pkg)(make-vector 15))
-(define-inline (datashare:pkg-get-id vec) (vector-ref vec 0))
-(define-inline (datashare:pkg-get-area vec) (vector-ref vec 1))
-(define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2))
-(define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3))
-(define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4))
-(define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5))
-(define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6))
-(define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7))
-(define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8))
-(define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9))
-(define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10))
-(define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11))
-(define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12))
-(define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13))
-(define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14))
-(define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val))
-(define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val))
-(define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val))
-(define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val))
-(define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val))
-(define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val))
-(define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val))
-(define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val))
-(define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val))
-(define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val))
-(define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val))
-(define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val))
-(define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val))
-(define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val))
-(define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val))
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-(define (datashare:initialize-db db)
- (for-each
- (lambda (qry)
- (sqlite3:execute db qry))
- (list
- "CREATE TABLE pkgs
- (id INTEGER PRIMARY KEY,
- area TEXT,
- version_name TEXT,
- store_type TEXT DEFAULT 'copy',
- copied INTEGER DEFAULT 0,
- source_path TEXT,
- stored_path TEXT,
- iteration INTEGER DEFAULT 0,
- submitter TEXT,
- datetime TIMESTAMP DEFAULT (strftime('%s','now')),
- storegrp TEXT,
- datavol INTEGER,
- quality TEXT,
- disk_id INTEGER,
- comment TEXT);"
- "CREATE TABLE refs
- (id INTEGER PRIMARY KEY,
- pkg_id INTEGER,
- destlink TEXT);"
- "CREATE TABLE disks
- (id INTEGER PRIMARY KEY,
- storegrp TEXT,
- path TEXT);")))
-
-(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
- (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
- (next-iteration 0))
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row
- (lambda (iteration)
- (if (and (number? iteration)
- (>= iteration next-iteration))
- (set! next-iteration (+ iteration 1))))
- iter-qry area version-name)
- ;; now store the data
- (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment)
- VALUES (?,?,?,?,?,?,?,?);"
- area version-name next-iteration (conc store-type) submitter source-path quality comment)))
- (sqlite3:finalize! iter-qry)
- next-iteration))
-
-(define (datashare:get-id db area version-name iteration)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
- area version-name iteration)
- res))
-
-(define (datashare:set-stored-path db id path)
- (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
-
-(define (datashare:set-copied db id value)
- (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
-
-(define (datashare:get-pkg-record db area version-name iteration)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (apply vector a b)))
- db
- "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
- area
- version-name
- iteration)
- res))
-
-;; take version-name iteration and register or update "lastest/0"
-;;
-(define (datashare:set-latest db id area version-name iteration)
- (let* ((rec (datashare:get-pkg-record db area version-name iteration))
- (latest-id (datashare:get-id db area "latest" 0))
- (stored-path (datashare:pkg-get-stored_path rec)))
- (if latest-id ;; have a record - bump the link pointer
- (datashare:set-stored-path db latest-id stored-path)
- (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))
-
-;; set a package ref, this is the location where the link back to the stored data
-;; is put.
-;;
-;; if there is nothing at that location then the record can be removed
-;; if there are no refs for a particular pkg-id then that pkg-id is a
-;; candidate for removal
-;;
-(define (datashare:record-pkg-ref db pkg-id dest-link)
- (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
-
-(define (datashare:count-refs db pkg-id)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db
- "SELECT count(id) FROM refs WHERE pkg_id=?;"
- pkg-id)
- res))
-
-;; Create the sqlite db
-(define (datashare:open-db configdat)
- (let ((path (configf:lookup configdat "database" "location")))
- (if (and path
- (directory? path)
- (file-read-access? path))
- (let* ((dbpath (conc path "/datashare.db"))
- (writeable (file-write-access? dbpath))
- (dbexists (common:file-exists? dbpath))
- (handler (make-busy-timeout 136000)))
- (handle-exceptions
- exn
- (begin
- (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
- ((condition-property-accessor 'exn 'message) exn))
- (exit))
- (set! db (sqlite3:open-database dbpath)))
- (if *db-write-access* (sqlite3:set-busy-handler! db handler))
- (if (not dbexists)
- (begin
- (datashare:initialize-db db)))
- db)
- (print "ERROR: invalid path for storing database: " path))))
-
-(define (open-run-close-exception-handling proc idb . params)
- (handle-exceptions
- exn
- (let ((sleep-time (random 30))
- (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (case err-status
- ((busy)
- (thread-sleep! sleep-time))
- (else
- (print "EXCEPTION: database overloaded or unreadable.")
- (print " message: " ((condition-property-accessor 'exn 'message) exn))
- (print "exn=" (condition->list exn))
- (print " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (print-call-chain (current-error-port))
- (thread-sleep! sleep-time)
- (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
- (apply open-run-close-exception-handling proc idb params))
- (apply open-run-close-no-exception-handling proc idb params)))
-
-(define (open-run-close-no-exception-handling proc idb . params)
- ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
- (let* ((db (cond
- ((sqlite3:database? idb) idb)
- ((not idb) (print "ERROR: cannot open-run-close with #f anymore"))
- ((procedure? idb) (idb))
- (else (print "ERROR: cannot open-run-close with #f anymore"))))
- (res #f))
- (set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! dbstruct))
- ;; (print "open-run-close-no-exception-handling END" )
- res))
-
-(define open-run-close open-run-close-no-exception-handling)
-
-(define (datashare:get-pkgs db area-filter version-filter iter-filter)
- (let ((res '()))
- (sqlite3:for-each-row ;; replace with fold ...
- (lambda (a . b)
- (set! res (cons (list->vector (cons a b)) res)))
- db
- (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
- " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
- area-filter version-filter)
- (reverse res)))
-
-(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
- (let ((dat '())
- (res #f))
- (sqlite3:for-each-row ;; replace with fold ...
- (lambda (a . b)
- (set! dat (cons (list->vector (cons a b)) dat)))
- db
- (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
- " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
- area-name version-name)
- ;; now filter for iteration, either max if #f or specific one
- (if (null? dat)
- #f
- (let loop ((hed (car dat))
- (tal (cdr dat))
- (cur 0))
- (let ((itr (datashare:pkg-get-iteration hed)))
- (if (equal? itr iteration) ;; this is the one if iteration is specified
- hed
- (if (null? tal)
- hed
- (loop (car tal)(cdr tal)))))))))
-
-(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
- (let ((res '())
- (data (make-hash-table)))
- (sqlite3:for-each-row
- (lambda (version-name submitter iteration submitted-time comment)
- ;; 0 1 2 3 4
- (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
- db
- "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
- (or version-patt "%"))
- (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))
-
-;;======================================================================
-;; DATA IMPORT/EXPORT
-;;======================================================================
-
-(define (datashare:import-data configdat source-path dest-path area version iteration)
- (let* ((space-avail (car dest-path))
- (disk-path (cdr dest-path))
- (targ-path (conc disk-path "/" area "/" version "/" iteration))
- (id (datashare:get-id db area version iteration))
- (db (datashare:open-db configdat)))
- (if (> space-avail 10000) ;; dumb heuristic
- (begin
- (create-directory targ-path #t)
- (datashare:set-stored-path db id targ-path)
- (print "Running command: rsync -av " source-path "/ " targ-path "/")
- (let ((th1 (make-thread (lambda ()
- (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
- (process-wait pid)
- (datashare:set-copied db id "yes")
- (sqlite3:finalize! db)))
- "Data copy")))
- (thread-start! th1))
- #t)
- (begin
- (print "ERROR: Not enough space in storage area " dest-path)
- (datashare:set-copied db id "no")
- (sqlite3:finalize! db)
- #f))))
-
-(define (datashare:get-areas configdat)
- (let* ((areadat (configf:get-section configdat "areas"))
- (areas (if areadat (map car areadat) '())))
- areas))
-
-(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
- ;; input checks
- (cond
- ((not (member area-name (datashare:get-areas configdat)))
- (cons #f (conc "Illegal area name \"" area-name "\"")))
- (else
- (let ((db (datashare:open-db configdat))
- (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment))
- (dest-store (datashare:get-best-storage configdat)))
- (if iteration
- (if (eq? 'copy publish-type)
- (begin
- (datashare:import-data configdat spath dest-store area-name version iteration)
- (let ((id (datashare:get-id db area-name version iteration)))
- (datashare:set-latest db id area-name version iteration)))
- (let ((id (datashare:get-id db area-name version iteration)))
- (datashare:set-stored-path db id spath)
- (datashare:set-copied db id "yes")
- (datashare:set-copied db id "n/a")
- (datashare:set-latest db id area-name version iteration)))
- (print "ERROR: Failed to get an iteration number"))
- (sqlite3:finalize! db)
- (cons #t "Successfully saved data")))))
-
-(define (datashare:get-best-storage configdat)
- (let* ((storage (configf:lookup configdat "settings" "storage"))
- (store-areas (if storage (string-split storage) '())))
- (print "Looking for available space in " store-areas)
- (datashare:find-most-space store-areas)))
-
-;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))
-
-(define (datashare:find-most-space paths)
- (fold (lambda (area res)
- ;; (print "area=" area " res=" res)
- (let ((maxspace (car res))
- (currpath (cdr res)))
- ;; (print currpath " " maxspace)
- (if (file-write-access? area)
- (let ((currspace (string->number
- (list-ref
- (with-input-from-pipe
- ;; (conc "df --output=avail " area)
- (conc "df -B1000000 " area)
- ;; (lambda ()(read)(read))
- (lambda ()(read-line)(string-split (read-line))))
- 3))))
- (if (> currspace maxspace)
- (cons currspace area)
- res))
- res)))
- (cons 0 #f)
- paths))
-
-;; remove existing link and if possible ...
-;; create path to next of tip of target, create link back to source
-(define (datashare:build-dir-make-link source target)
- (if (common:file-exists? target)(datashare:backup-move target))
- (create-directory (pathname-directory target) #t)
- (create-symbolic-link source target))
-
-(define (datashare:backup-move path)
- (let* ((trashdir (conc (pathname-directory path) "/.trash"))
- (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
- (create-directory trashdir #t)
- (if (directory? path)
- (system (conc "mv " path " " trashfile))
- (file-move path trash-file))))
-
-;;======================================================================
-;; GUI
-;;======================================================================
-
-;; The main menu
-(define (datashare:main-menu)
- (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
- (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
- (iup:menu-item "Open" action: (lambda (obj)
- (iup:show (iup:file-dialog))
- (print "File->open " obj)))
- (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
- (iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
- (iup:menu-item "Tools" (iup:menu
- (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
- ;; (iup:menu-item "Show dialog" #:action (lambda (obj)
- ;; (show message-window
- ;; #:modal? #t
- ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
- ;; ;; #:x 'mouse
- ;; ;; #:y 'mouse
- ;; )
- ))))
-
-(define (datashare:publish-view configdat)
- ;; (pp (hash-table->alist configdat))
- (let* ((areas (configf:get-section configdat "areas"))
- (label-size "70x")
- (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
- (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x"))
- (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
- (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
- (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
- ;; (copy-link (iup:toggle #:expand "HORIZONTAL"))
- ;; (iteration (iup:textbox #:expand "YES" #:size "20x"))
- ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
- (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
- (comment-tb (iup:textbox #:expand "YES" #:multiline "YES"))
- (source-tb (iup:textbox #:expand "HORIZONTAL"
- #:value (or (configf:lookup configdat "settings" "basepath")
- "")))
- (publish (lambda (publish-type)
- (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0))
- (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
- (area-path (cadr area-dat))
- (area-name (car area-dat))
- (version (iup:attribute version-tb "VALUE"))
- (comment (iup:attribute comment-tb "VALUE"))
- (spath (iup:attribute source-tb "VALUE"))
- (submitter (current-user-name))
- (quality 2))
- (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
- (copy (iup:button "Copy and Publish"
- #:expand "HORIZONTAL"
- #:action (lambda (obj)
- (publish 'copy))))
- (link (iup:button "Link and Publish"
- #:expand "HORIZONTAL"
- #:action (lambda (obj)
- (publish 'link))))
- (browse-btn (iup:button "Browse"
- #:size "40x"
- #:action (lambda (obj)
- (let* ((fd (iup:file-dialog #:dialogtype "DIR"))
- (top (iup:show fd #:modal? "YES")))
- (iup:attribute-set! source-tb "VALUE"
- (iup:attribute fd "VALUE"))
- (iup:destroy! fd))))))
- (print "areas")
- ;; (pp areas)
- (fold (lambda (areadat num)
- ;; (print "Adding num=" num ", areadat=" areadat)
- (iup:attribute-set! areas-sel (conc num) (car areadat))
- (+ 1 num))
- 1 areas)
- (iup:vbox
- (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter
- areas-sel)
- (iup:hbox (iup:label "Version:" #:size label-size) version-tb)
- ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link)
- ;; (iup:label "Iteration:") iteration)
- (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb)
- (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn)
- (iup:hbox copy link))))
-
-(define (datashare:lst->path pathlst)
- (conc "/" (string-intersperse (map conc pathlst) "/")))
-
-(define (datashare:path->lst path)
- (string-split path "/"))
-
-(define (datashare:pathdat-apply-heuristics configdat path)
- (cond
- ((common:file-exists? path) "found")
- (else (conc path " not installed"))))
-
-(define (datashare:get-view configdat)
- (iup:vbox
- (iup:hbox
- (let* ((label-size "60x")
- ;; filter elements
- (area-filter "%")
- (version-filter "%")
- (iter-filter ">= 0")
- ;; reverse lookup from path to data for src and installed
- (srcdat (make-hash-table)) ;; reverse lookup
- (installed-dat (make-hash-table))
- ;; config values
- (basepath (configf:lookup configdat "settings" "basepath"))
- ;; gui elements
- (submitter (iup:label "" #:expand "HORIZONTAL"))
- (date-submitted (iup:label "" #:expand "HORIZONTAL"))
- (comment (iup:label "" #:expand "HORIZONTAL"))
- (copy-link (iup:label "" #:expand "HORIZONTAL"))
- (quality (iup:label "" #:expand "HORIZONTAL"))
- (installed-status (iup:label "" #:expand "HORIZONTAL"))
- ;; misc
- (curr-record #f)
- ;; (source-data (iup:label "" #:expand "HORIZONTAL"))
- (tb (iup:treebox
- #:value 0
- #:name "Packages"
- #:expand "YES"
- #:addexpanded "NO"
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
- (record (hash-table-ref/default srcdat path #f)))
- (if record
- (begin
- (set! curr-record record)
- (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record))
- (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
- (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record))
- (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record))
- (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record))
- ))
- ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
- ))))
- (tb2 (iup:treebox
- #:value 0
- #:name "Installed"
- #:expand "YES"
- #:addexpanded "NO"
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((path (datashare:lst->path (cdr (tree:node->path obj id))))
- (status (hash-table-ref/default installed-dat path #f)))
- (iup:attribute-set! installed-status "TITLE" (if status status ""))
- ))))
- (refresh (lambda (obj)
- (let* ((db (datashare:open-db configdat))
- (areas (or (configf:get-section configdat "areas") '())))
- ;;
- ;; first update the Sources
- ;;
- (for-each
- (lambda (pkgitem)
- (let* ((pkg-path (list (datashare:pkg-get-area pkgitem)
- (datashare:pkg-get-version_name pkgitem)
- (datashare:pkg-get-iteration pkgitem)))
- (pkg-id (datashare:pkg-get-id pkgitem))
- (path (datashare:lst->path pkg-path)))
- ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
- (if (not (hash-table-ref/default srcdat path #f))
- (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
- ;; (print "path=" path " pkgitem=" pkgitem)
- (hash-table-set! srcdat path pkgitem)))
- (datashare:get-pkgs db area-filter version-filter iter-filter))
- ;;
- ;; then update the installed
- ;;
- (for-each
- (lambda (area)
- (let* ((path (conc "/" (cadr area)))
- (fullpath (conc basepath path)))
- (if (not (hash-table-ref/default installed-dat path #f))
- (tree:add-node tb2 "Installed" (datashare:path->lst path)))
- (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
- areas)
- (sqlite3:finalize! db))))
- (apply (iup:button "Apply"
- #:action
- (lambda (obj)
- (if curr-record
- (let* ((area (datashare:pkg-get-area curr-record))
- (stored-path (datashare:pkg-get-stored_path curr-record))
- (source-type (datashare:pkg-get-store_type curr-record))
- (source-path (case source-type ;; (equal? source-type "link"))
- ((link)(datashare:pkg-get-source-path curr-record))
- ((copy)stored-path)
- (else #f)))
- (dest-stub (configf:lookup configdat "areas" area))
- (target-path (conc basepath "/" dest-stub)))
- (datashare:build-dir-make-link stored-path target-path)
- (print "Creating link from " stored-path " to " target-path)))))))
- (iup:vbox
- (iup:hbox tb tb2)
- (iup:frame
- #:title "Source Info"
- (iup:vbox
- (iup:hbox (iup:button "Refresh" #:action refresh) apply)
- (iup:hbox (iup:label "Submitter: ") ;; #:size label-size)
- submitter
- (iup:label "Submitted on: ") ;; #:size label-size)
- date-submitted)
- (iup:hbox (iup:label "Data stored: ")
- copy-link
- (iup:label "Quality: ")
- quality)
- (iup:hbox (iup:label "Comment: ")
- comment)))
- (iup:frame
- #:title "Installed Info"
- (iup:vbox
- (iup:hbox (iup:label "Installed status/path: ") installed-status)))
- )))))
-
-(define (datashare:manage-view configdat)
- (iup:vbox
- (iup:hbox
- (iup:button "Pushme"
- #:expand "YES"
- ))))
-
-(define (datashare:gui configdat)
- (iup:show
- (iup:dialog
- #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))
- #:menu (datashare:main-menu)
- (let* ((tabs (iup:tabs
- #:tabchangepos-cb (lambda (obj curr prev)
- (set! *datashare:current-tab-number* curr))
- (datashare:publish-view configdat)
- (datashare:get-view configdat)
- (datashare:manage-view configdat)
- )))
- ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
- (iup:attribute-set! tabs "TABTITLE0" "Publish")
- (iup:attribute-set! tabs "TABTITLE1" "Get")
- (iup:attribute-set! tabs "TABTITLE2" "Manage")
- ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
- tabs)))
- (iup:main-loop))
-
-;;======================================================================
-;; MISC
-;;======================================================================
-
-
-(define (datashare:do-as-calling-user proc)
- (let ((eid (current-effective-user-id))
- (cid (current-user-id)))
- (if (not (eq? eid cid)) ;; running suid
- (set! (current-effective-user-id) cid))
- ;; (print "running as " (current-effective-user-id))
- (proc)
- (if (not (eq? eid cid))
- (set! (current-effective-user-id) eid))))
-
-(define (datashare:find name paths)
- (if (null? paths)
- #f
- (let loop ((hed (car paths))
- (tal (cdr paths)))
- (if (common:file-exists? (conc hed "/" name))
- hed
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))
-
-;;======================================================================
-;; MAIN
-;;======================================================================
-
-(define (datashare:load-config exe-dir exe-name)
- (let* ((fname (conc exe-dir "/." exe-name ".config")))
- (ini:property-separator-patt " * *")
- (ini:property-separator #\space)
- (if (common:file-exists? fname)
- ;; (ini:read-ini fname)
- (read-config fname #f #t)
- (make-hash-table))))
-
-(define (datashare:process-action configdat action . args)
- (case (string->symbol action)
- ((get)
- (if (< (length args) 2)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1))
- (let* ((basepath (configf:lookup configdat "settings" "basepath"))
- (db (datashare:open-db configdat))
- (area (car args))
- (version (cadr args)) ;; iteration
- (remargs (args:get-args args '("-i") '() args:arg-hash 0))
- (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
- (curr-record (datashare:get-pkg db area version iteration: iteration)))
- (if (not curr-record)
- (begin
- (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
- (exit 1))
- (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
- (source-type (datashare:pkg-get-store_type curr-record))
- (source-path (case source-type ;; (equal? source-type "link"))
- ((link) (datashare:pkg-get-source-path curr-record))
- ((copy) stored-path)
- (else #f)))
- (dest-stub (configf:lookup configdat "areas" area))
- (target-path (conc basepath "/" dest-stub)))
- (datashare:build-dir-make-link stored-path target-path)
- (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
- (sqlite3:finalize! db)
- (print "Creating link from " stored-path " to " target-path))))))
- ((publish)
- (if (< (length args) 3)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1))
- (let* ((srcpath (list-ref args 0))
- (areaname (list-ref args 1))
- (version (list-ref args 2))
- (remargs (args:get-args (drop args 2)
- '("-type" ;; link or copy (default is copy)
- "-m")
- '()
- args:arg-hash
- 0))
- (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
- (comment (or (args:get-arg "-m") ""))
- (submitter (current-user-name))
- (quality (args:get-arg "-quality"))
- (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
- (if (not (car publish-res))
- (begin
- (print "ERROR: " (cdr publish-res))
- (exit 1))))))
- ((list-versions)
- (let ((area-name (car args)) ;; version patt full print
- (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
- (db (datashare:open-db configdat))
- (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
- ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
- (map (lambda (x)
- (if (args:get-arg "-full")
- (format #t
- "~10a~10a~4a~27a~30a\n"
- (vector-ref x 0)
- (vector-ref x 1)
- (vector-ref x 2)
- (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
- (conc "\"" (vector-ref x 4) "\""))
- (print (vector-ref x 0))))
- versions)
- (sqlite3:finalize! db)))))
-
-;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(define (main)
- (let* ((args (argv))
- (prog (car args))
- (rema (cdr args))
- (exe-name (pathname-file (car (argv))))
- (exe-dir (or (pathname-directory prog)
- (datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
- (configdat (datashare:load-config exe-dir exe-name)))
- (cond
- ;; one-word commands
- ((eq? (length rema) 1)
- (case (string->symbol (car rema))
- ((help -h -help --h --help)
- (print datashare:help))
- ((list-areas)
- (map print (datashare:get-areas configdat)))
- (else
- (print "ERROR: Unrecognised command. Try \"datashare help\""))))
- ;; multi-word commands
- ((null? rema)(datashare:gui configdat))
- ((>= (length rema) 2)
- (apply datashare:process-action configdat (car rema)(cdr rema)))
- (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
-
-(main)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1178,55 +1178,10 @@
(if sync-needed
(debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
res))
-;; keeping it around for debugging purposes only
-#;(define (open-run-close-no-exception-handling proc idb . params)
- (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
- (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
- (exit)
- (if (or *db-write-access*
- (not #t)) ;; was: (member proc * db:all-write-procs *)))
- (let* ((db (cond
- ((pair? idb) (db:dbdat-get-db idb))
- ((sqlite3:database? idb) idb)
- ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
- ((procedure? idb) (idb))
- (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
- (res #f))
- (set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! dbstruct))
- (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
- res)
- #f))
-
-#;(define (open-run-close-exception-handling proc idb . params)
- (handle-exceptions
- exn
- (let ((sleep-time (random 30))
- (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (case err-status
- ((busy)
- (thread-sleep! sleep-time))
- (else
- (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (print-call-chain (current-error-port))
- (thread-sleep! sleep-time)
- (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
- (apply open-run-close-exception-handling proc idb params))
- (apply open-run-close-no-exception-handling proc idb params)))
-
-;; (define open-run-close
-#;(define open-run-close open-run-close-exception-handling)
- ;; open-run-close-no-exception-handling
-;; open-run-close-exception-handling)
-;;)
-
(define db:trigger-list
(list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
FOR EACH ROW
BEGIN
UPDATE runs SET last_update=(strftime('%s','now'))
@@ -1666,17 +1621,10 @@
db
"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
archive-block-id)
res))))
-;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
-;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
-;; (db (db:dbdat-get-db dbdat))
-;; (res '())
-;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
-;; (sqlite3:for-each-row #f)
-
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db)
@@ -1997,11 +1945,11 @@
;; b. If test dir gone, delete the test record
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
-(define (db:clean-up-rundb dbdat)
+#;(define (db:clean-up-rundb dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
(let* ((db (db:dbdat-get-db dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
(statements
(map (lambda (stmt)
@@ -2302,11 +2250,11 @@
db
"SELECT runname FROM runs WHERE id=?;"
run-id)
res))))
-(define (db:get-run-key-val dbstruct run-id key)
+#;(define (db:get-run-key-val dbstruct run-id key)
(db:with-db
dbstruct
#f
#f
(lambda (db)
@@ -3321,11 +3269,11 @@
;; tags: '("tag%" "tag2" "%ag6")
;;
;; done with run when:
;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
-(define (db:estimated-tests-remaining dbstruct run-id)
+#;(define (db:estimated-tests-remaining dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (db)
@@ -3452,11 +3400,11 @@
(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
;; move test ids into the 30k * run_id range
;;
-(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
+#;(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
(debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
(let ((min-test-id (* run-id 30000)))
(for-each
(lambda (testrec)
(let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
@@ -3464,11 +3412,11 @@
testrecs)))
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
-(define (db:prep-megatest.db-for-migration mtdb)
+#;(define (db:prep-megatest.db-for-migration mtdb)
(let* ((run-ids (db:get-all-run-ids mtdb)))
(for-each
(lambda (run-id)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
(db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
@@ -3943,25 +3891,10 @@
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
-;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
-;; ;
-;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
-;; (let ((dbdat (db:get-db dbstruct run-id)))
-;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
-;; (db:general-call dbdat 'set-test-start-time (list test-id)))
-;; ;; (if msg
-;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
-;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
-;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
-;; ;; process the test_data table
-;; (if (and test-id state status (equal? status "AUTO"))
-;; (db:test-data-rollup dbstruct run-id test-id status))
-;; (mt:process-triggers dbstruct run-id test-id state status)))
-
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
@@ -4031,76 +3964,74 @@
(if (and state status (not (member state *common:dont-roll-up-states*)))
(cons status (map dbr:counts-status state-status-counts))
(map dbr:counts-status state-status-counts)))
*common:std-statuses* >))
(non-completes (filter (lambda (x)
- (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
- all-curr-states))
- (preq-fails (filter (lambda (x)
- (equal? x "PREQ_FAIL"))
- all-curr-statuses))
+ (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
+ all-curr-states))
+ (preq-fails (filter (lambda (x)
+ (equal? x "PREQ_FAIL"))
+ all-curr-statuses))
(num-non-completes (length non-completes))
- (newstate (cond
- ((> running 0) "RUNNING") ;; anything running, call the situation running
- ((> (length preq-fails) 0) "NOT_STARTED")
- ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
- ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
- (else (car all-curr-states))))
+ (newstate (cond
+ ((> running 0) "RUNNING") ;; anything running, call the situation running
+ ((> (length preq-fails) 0) "NOT_STARTED")
+ ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
+ ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
+ (else (car all-curr-states))))
(newstatus (cond
- ((> (length preq-fails) 0) "PREQ_FAIL")
- ((or (> bad-not-started 0)
- (and (equal? newstate "NOT_STARTED")
- (> num-non-completes 0)))
- "STARTED")
- (else (car all-curr-statuses)))))
- (debug:print-info 2 *default-log-port*
- "\n--> probe db:set-state-status-and-roll-up-items: "
- "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
- "\n--> running: "running
- "\n--> bad-not-started: "bad-not-started
- "\n--> non-non-completes: "num-non-completes
- "\n--> non-completes: "non-completes
- "\n--> all-curr-states: "all-curr-states
- "\n--> all-curr-statuses: "all-curr-statuses
- "\n--> newstate "newstate
- "\n--> newstatus "newstatus
- "\n\n")
-
- ;; NB// Pass the db so it is part of the transaction
- (list newstate newstatus)))
+ ((> (length preq-fails) 0) "PREQ_FAIL")
+ ((or (> bad-not-started 0)
+ (and (equal? newstate "NOT_STARTED")
+ (> num-non-completes 0)))
+ "STARTED")
+ (else (car all-curr-statuses)))))
+ (debug:print-info 2 *default-log-port*
+ "\n--> probe db:set-state-status-and-roll-up-items: "
+ "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+ "\n--> running: "running
+ "\n--> bad-not-started: "bad-not-started
+ "\n--> non-non-completes: "num-non-completes
+ "\n--> non-completes: "non-completes
+ "\n--> all-curr-states: "all-curr-states
+ "\n--> all-curr-statuses: "all-curr-statuses
+ "\n--> newstate "newstate
+ "\n--> newstatus "newstatus
+ "\n\n")
+
+ ;; NB// Pass the db so it is part of the transaction
+ (list newstate newstatus)))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
- (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (let ((tr-res
- (sqlite3:with-transaction
- db
- (lambda ()
- (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
- (state-stauses (db:roll-up-rules state-status-counts #f #f ))
- (newstate (car state-stauses))
- (newstatus (cadr state-stauses)))
- (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
- (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
- (mutex-unlock! *db-transaction-mutex*)
- tr-res))))
-
+ (mutex-lock! *db-transaction-mutex*)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let ((tr-res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
+ (state-stauses (db:roll-up-rules state-status-counts #f #f ))
+ (newstate (car state-stauses))
+ (newstatus (cadr state-stauses)))
+ (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
+ (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
+ (mutex-unlock! *db-transaction-mutex*)
+ tr-res))))
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
- (let* ((test-count-recs (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:map-row
- (lambda (state status count)
- (make-dbr:counts state: state status: status count: count))
- db
- "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
- run-id )))))
- test-count-recs))
-
+ (let* ((test-count-recs (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:map-row
+ (lambda (state status count)
+ (make-dbr:counts state: state status: status count: count))
+ db
+ "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
+ run-id )))))
+ test-count-recs))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
@@ -4138,24 +4069,10 @@
(unrelated-rec-list
(filter nonmatch-countrec-lambda other-items-count-recs)))
(cons updated-count-rec unrelated-rec-list)))
-;; (define (db:get-all-item-states db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-;;
-;; (define (db:get-all-item-statuses db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
#f
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -106,13 +106,20 @@
(define-inline (db:test-get-archived vec) (vector-ref vec 17))
(define-inline (db:test-get-last_update vec) (vector-ref vec 18))
;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15))
;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16))
+
(define-inline (db:test-get-fullname vec)
(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
+(define-inline (test:test-get-fullname test)
+ (conc (db:test-get-testname test)
+ (if (equal? (db:test-get-item-path test) "")
+ ""
+ (conc "(" (db:test-get-item-path test) ")"))))
+
;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
(if (equal? itempath "") testname (conc testname "/" itempath)))
(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15)))
@@ -240,20 +247,5 @@
(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
-
-;; The data structure for handing off requests via wire
-(define (make-cdb:packet)(make-vector 6))
-(define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0))
-(define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1))
-(define-inline (cdb:packet-get-immediate vec) (vector-ref vec 2))
-(define-inline (cdb:packet-get-query-sig vec) (vector-ref vec 3))
-(define-inline (cdb:packet-get-params vec) (vector-ref vec 4))
-(define-inline (cdb:packet-get-qtime vec) (vector-ref vec 5))
-(define-inline (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
-(define-inline (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
-(define-inline (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
-(define-inline (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
-(define-inline (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
-(define-inline (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -151,215 +151,10 @@
(iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
-;; TO-DO
-;; 1. Make "data" hash-table hierarchial store of all displayed data
-;; 2. Update synchash to understand "get-runs", "get-tests" etc.
-;; 3. Add extraction of filters to synchash calls
-;;
-;; NOTE: Used in newdashboard
-;;
-;; Mode is 'full or 'incremental for full refresh or incremental refresh
-;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
-;; (let* (;; count and offset => #f so not used
-;; ;; the synchash calls modify the "data" hash
-;; (changed #f)
-;; (get-runs-sig (conc (client:get-signature) " get-runs"))
-;; (get-tests-sig (conc (client:get-signature) " get-tests"))
-;; (get-details-sig (conc (client:get-signature) " get-test-details"))
-;;
-;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
-;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data)))
-;; ;; run-id is #f in next line to send the query to server 0
-;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
-;; (tests-detail-changes (if (not (null? test-ids))
-;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids)
-;; '()))
-;;
-;; ;; Now can calculate the run-ids
-;; (run-hash (hash-table-ref/default data get-runs-sig #f))
-;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '()))
-;;
-;; (all-test-changes (let ((res (make-hash-table)))
-;; (for-each (lambda (run-id)
-;; (if (> run-id 0)
-;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
-;; run-ids)
-;; res))
-;; (runs-hash (hash-table-ref/default data get-runs-sig #f))
-;; (header (hash-table-ref/default runs-hash "header" #f))
-;; (run-ids (sort (filter number? (hash-table-keys runs-hash))
-;; (lambda (a b)
-;; (let* ((record-a (hash-table-ref runs-hash a))
-;; (record-b (hash-table-ref runs-hash b))
-;; (time-a (db:get-value-by-header record-a header "event_time"))
-;; (time-b (db:get-value-by-header record-b header "event_time")))
-;; (> time-a time-b)))
-;; ))
-;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col"))
-;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row"))
-;; (colnum 1)
-;; (rownum 0)
-;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
-;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
-;;
-;; ;; tests related stuff
-;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))
-;;
-;; ;; Given a run-id and testname/item_path calculate a cell R:C
-;;
-;; ;; NOTE: Also build the test tree browser and look up table
-;; ;;
-;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
-;; (for-each (lambda (run-id)
-;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
-;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key))
-;; keys))
-;; (run-name (db:get-value-by-header run-record header "runname"))
-;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
-;; (run-path (append key-vals (list run-name))))
-;; (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
-;; ;; modify cell - but only if changed
-;; (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
-;; (hash-table-set! runid-to-col run-id (list colnum run-record))
-;; ;; Here we update the tests treebox and tree keys
-;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
-;; userdata: (conc "run-id: " run-id))
-;; (set! colnum (+ colnum 1))))
-;; run-ids)
-;;
-;; ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
-;; ;; Do this analysis in the order of the run-ids, the most recent run wins
-;; (for-each (lambda (run-id)
-;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id))
-;; (test-changes (hash-table-ref all-test-changes run-id))
-;; (new-test-dat (car test-changes))
-;; (removed-tests (cadr test-changes))
-;; (tests (sort (map cadr (filter (lambda (testrec)
-;; (eq? run-id (db:mintest-get-run_id (cadr testrec))))
-;; new-test-dat))
-;; (lambda (a b)
-;; (let ((time-a (db:mintest-get-event_time a))
-;; (time-b (db:mintest-get-event_time b)))
-;; (> time-a time-b)))))
-;; ;; test-changes is a list of (( id record ) ... )
-;; ;; Get list of test names sorted by time, remove tests
-;; (test-names (delete-duplicates (map (lambda (t)
-;; (let ((i (db:mintest-get-item_path t))
-;; (n (db:mintest-get-testname t)))
-;; (if (string=? i "")
-;; (conc " " i)
-;; n)))
-;; tests)))
-;; (colnum (car (hash-table-ref runid-to-col run-id))))
-;; ;; for each test name get the slot if it exists and fill in the cell
-;; ;; or take the next slot and fill in the cell, deal with items in the
-;; ;; run view panel? The run view panel can have a tree selector for
-;; ;; browsing the tests/items
-;;
-;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY
-;; (for-each (lambda (test)
-;; (let* ((test-id (db:mintest-get-id test))
-;; (state (db:mintest-get-state test))
-;; (status (db:mintest-get-status test))
-;; (testname (db:mintest-get-testname test))
-;; (itempath (db:mintest-get-item_path test))
-;; (fullname (conc testname "/" itempath))
-;; (dispname (if (string=? itempath "") testname (conc " " itempath)))
-;; (rownum (hash-table-ref/default testname-to-row fullname #f))
-;; (test-path (append run-path (if (equal? itempath "")
-;; (list testname)
-;; (list testname itempath))))
-;; (tb (dboard:tabdat-tests-tree data)))
-;; (print "INFONOTE: run-path: " run-path)
-;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs"
-;; test-path
-;; userdata: (conc "test-id: " test-id))
-;; (let ((node-num (tree:find-node tb (cons "Runs" test-path)))
-;; (color (car (gutils:get-color-for-state-status state status))))
-;; (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
-;;
-;; (set! changed (dcommon:modifiy-if-different
-;; tb
-;; (conc "COLOR" node-num)
-;; color changed))
-;;
-;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
-;; )
-;; (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
-;; (if (not rownum)
-;; (let ((rownums (hash-table-values testname-to-row)))
-;; (set! rownum (if (null? rownums)
-;; 1
-;; (+ 1 (common:max rownums))))
-;; (hash-table-set! testname-to-row fullname rownum)
-;; ;; create the label
-;; (set! changed (dcommon:modifiy-if-different
-;; (dboard:tabdat-runs-matrix data)
-;; (conc rownum ":" 0)
-;; dispname
-;; changed))
-;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
-;; ;; (conc rownum ":" 0) dispname)
-;; ))
-;; ;; set the cell text and color
-;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
-;; (set! changed (dcommon:modifiy-if-different
-;; (dboard:tabdat-runs-matrix data)
-;; (conc rownum ":" colnum)
-;; (if (member state '("ARCHIVED" "COMPLETED"))
-;; status
-;; state)
-;; changed))
-;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
-;; ;; (conc rownum ":" colnum)
-;; ;; (if (member state '("ARCHIVED" "COMPLETED"))
-;; ;; status
-;; ;; state))
-;; (set! changed (dcommon:modifiy-if-different
-;; (dboard:tabdat-runs-matrix data)
-;; (conc "BGCOLOR" rownum ":" colnum)
-;; (car (gutils:get-color-for-state-status state status))
-;; changed))
-;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
-;; ;; (conc "BGCOLOR" rownum ":" colnum)
-;; ;; (car (gutils:get-color-for-state-status state status)))
-;; ))
-;; tests)))
-;; run-ids)
-;;
-;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f)))
-;; (if updater (updater (hash-table-ref/default data get-details-sig #f))))
-;;
-;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
-;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
-;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
-;; (list run-changes all-test-changes)))
-
-#;(define (dcommon:runsdat-get-col-num dat target runname force-set)
- (let* ((runs-index (dboard:runsdat-runs-index dat))
- (col-name (conc target "/" runname))
- (res (hash-table-ref/default runs-index col-name #f)))
- (if res
- res
- (if force-set
- (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index))))))
- (hash-table-set! runs-index col-name max-col-num)
- max-col-num)))))
-
-#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
- (let* ((tests-index (dboard:runsdat-runs-index dat))
- (row-name (conc testname "/" itempath))
- (res (hash-table-ref/default runs-index row-name #f)))
- (if res
- res
- (if force-set
- (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index))))))
- (hash-table-set! runs-index row-name max-row-num)
- max-row-num)))))
(define (dcommon:rundat-copy-tests-to-by-name rundat)
(let ((src-ht (dboard:rundat-tests rundat))
(trg-ht (dboard:rundat-tests-by-name rundat)))
(if (and (hash-table? src-ht)(hash-table? trg-ht))
@@ -1215,36 +1010,10 @@
#:size "x30" ;; was 10x30
#:multiline "YES")))
(set! test-patterns-textbox tb)
(dboard:tabdat-test-patterns-textbox-set! tabdat tb)
tb))
-;; (iup:frame
-;; #:title "Target"
-;; ;; Target selectors
-;; (apply iup:hbox
-;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals))
-;; (key-lb (car dat))
-;; (combos (cadr dat)))
-;; combos)))
- ;; (iup:hbox
- ;; ;; Text box for STATES
- ;; (iup:frame
- ;; #:title "States"
- ;; (dashboard:text-list-toggle-box
- ;; ;; Move these definitions to common and find the other useages and replace!
- ;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
- ;; (lambda (all)
- ;; (dboard:tabdat-states-set! tabdat all)
- ;; (dashboard:update-run-command tabdat))))
- ;; ;; Text box for STATES
- ;; (iup:frame
- ;; #:title "Statuses"
- ;; (dashboard:text-list-toggle-box
- ;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
- ;; (lambda (all)
- ;; (dboard:tabdat-statuses-set! tabdat all)
- ;; (dashboard:update-run-command tabdat)))))
))
(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
(iup:frame
#:title "Tests and Tasks"
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -25,30 +25,23 @@
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
-;; (declare (uses sdb))
-;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-
-;;(rmt:get-test-info-by-id run-id test-id) -> testdat
-
+;; (rmt:get-test-info-by-id run-id test-id) -> testdat
+;;
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(stepinfo (cadr ezstep))
- ;; (let ((info (cadr ezstep)))
- ;; (if (proc? info) "" info)))
- ;; (stepproc (let ((info (cadr ezstep)))
- ;; (if (proc? info) info #f)))
(stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
(stepparams (if (and (list? stepparts)
(> (length stepparts) 1))
(list-ref stepparts 2)
#f)) ;; for future use, {VAR=1,2,3}, run step for each
DELETED fdb_records.scm
Index: fdb_records.scm
==================================================================
--- fdb_records.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;; Single record for managing a filedb
-;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
-;; Filedb record
-(define (make-filedb:fdb)(make-vector 5))
-(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
-(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
-(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
-(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
-(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
-(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
-(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
-(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
-(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
-
-;; children records, should have use something other than "child"
-(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
-(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
-(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
DELETED filedb.scm
Index: filedb.scm
==================================================================
--- filedb.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-;; Copyright 2006-2011, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
-(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit filedb))
-
-(include "fdb_records.scm")
-;; (include "settings.scm")
-
-(define (filedb:open-db dbpath)
- (let* ((fdb (make-filedb:fdb))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath)))
- (filedb:fdb-set-db! fdb db)
- (filedb:fdb-set-dbpath! fdb dbpath)
- (filedb:fdb-set-pathcache! fdb (make-hash-table))
- (filedb:fdb-set-idcache! fdb (make-hash-table))
- (filedb:fdb-set-partcache! fdb (make-hash-table))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
- (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
- ;; NB// We store a useful subset of file attributes but do not attempt to store all
- (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
- path TEXT,
- parent_id INTEGER,
- mode INTEGER DEFAULT -1,
- uid INTEGER DEFAULT -1,
- gid INTEGER DEFAULT -1,
- size INTEGER DEFAULT -1,
- mtime INTEGER DEFAULT -1);")
- (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
- (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
- ;; close the sqlite3 db and open it as needed
- (filedb:finalize-db! fdb)
- (filedb:fdb-set-db! fdb #f)
- fdb))
-
-(define (filedb:reopen-db fdb)
- (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
- (filedb:fdb-set-db! fdb db)
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
-
-(define (filedb:finalize-db! fdb)
- (sqlite3:finalize! (filedb:fdb-get-db fdb)))
-
-(define (filedb:get-current-time-string)
- (string-chomp (time->string (seconds->local-time (current-seconds)))))
-
-(define (filedb:get-base-id db path)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:get-path-id db path parent)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path parent)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:add-base db path)
- (let ((existing (filedb:get-base-id db path)))
- (if existing #f
- (begin
- (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
-
-;; index value field notes
-;; 0 inode number st_ino
-;; 1 mode st_mode bitfield combining file permissions and file type
-;; 2 number of hard links st_nlink
-;; 3 UID of owner st_uid as with file-owner
-;; 4 GID of owner st_gid
-;; 5 size st_size as with file-size
-;; 6 access time st_atime as with file-access-time
-;; 7 change time st_ctime as with file-change-time
-;; 8 modification time st_mtime as with file-modification-time
-;; 9 parent device ID st_dev ID of device on which this file resides
-;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
-;; 11 block size st_blksize
-;; 12 number of blocks allocated st_blocks
-
-(define (filedb:add-path-stat db path parent statinfo)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
- (sqlite3:execute stmt
- path
- parent
- (vector-ref statinfo 1) ;; mode
- (vector-ref statinfo 3) ;; uid
- (vector-ref statinfo 4) ;; gid
- (vector-ref statinfo 5) ;; size
- (vector-ref statinfo 8) ;; mtime
- )
- (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
-
-(define (filedb:add-path db path parent)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
- (sqlite3:execute stmt path parent)
- (sqlite3:finalize! stmt)))
-
-(define (filedb:register-path fdb path #!key (save-stat #f))
- (let* ((db (filedb:fdb-get-db fdb))
- (pathcache (filedb:fdb-get-pathcache fdb))
- (stat (if save-stat (file-stat path #t)))
- (id (hash-table-ref/default pathcache path #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if id id
- (let ((plist (string-split path "/")))
- (let loop ((head (car plist))
- (tail (cdr plist))
- (parent 0))
- (let ((id (filedb:get-path-id db head parent))
- (done (null? tail)))
- (if id ;; we'll have a id if the path is already registered
- (if done
- (begin
- (hash-table-set! pathcache path id)
- id) ;; return the last path id for a result
- (loop (car tail)(cdr tail) id))
- (begin ;; add the path and then repeat the loop with the same data
- (if save-stat
- (filedb:add-path-stat db head parent stat)
- (filedb:add-path db head parent))
- (loop head tail parent)))))))))
-
-(define (filedb:update-recursively fdb path #!key (save-stat #f))
- (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
- (print "processed 0 files...")
- (let loop ((l (read-line p))
- (lc 0)) ;; line count
- (if (eof-object? l)
- (begin
- (print " " lc " files")
- (close-input-port p))
- (begin
- (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
- (if (= (modulo lc 100) 0)
- (print " " lc " files"))
- (loop (read-line p)(+ lc 1)))))))
-
-(define (filedb:update fdb path #!key (save-stat #f))
- ;; first get the realpath and add it to the bases table
- (let ((real-path path) ;; (filedb:get-real-path path))
- (db (filedb:fdb-get-db fdb)))
- (filedb:add-base db real-path)
- (filedb:update-recursively fdb path save-stat: save-stat)))
-
-;; not used and broken
-;;
-(define (filedb:get-real-path path)
- (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
- (pth (read-line p)))
- (if (eof-object? pth) path
- (begin
- (close-input-port p)
- pth))))
-
-(define (filedb:drop-base fdb path)
- (print "Sorry, I don't do anything yet"))
-
-(define (filedb:find-all fdb pattern action)
- (let* ((db (filedb:fdb-get-db fdb))
- (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
- (result '()))
- (sqlite3:for-each-row
- (lambda (num)
- (action num)
- (set! result (cons num result))) stmt pattern)
- (sqlite3:finalize! stmt)
- result))
-
-(define (filedb:get-path-record fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (partcache (filedb:fdb-get-partcache fdb))
- (dat (hash-table-ref/default partcache id #f)))
- (if dat dat
- (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
- (result #f))
- (sqlite3:for-each-row
- (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
- (hash-table-set! partcache id result)
- (sqlite3:finalize! stmt)
- result))))
-
-(define (filedb:get-children fdb parent-id)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
- parent-id)
- res))
-
-;; retrieve all that have children and those without
-;; children that match patt
-(define (filedb:get-children-patt fdb parent-id search-patt)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- ;; first get the children that have no children
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
- (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
- parent-id search-patt)
- res))
-
-(define (filedb:get-path fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (idcache (filedb:fdb-get-idcache fdb))
- (path (hash-table-ref/default idcache id #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if path path
- (let loop ((curr-id id)
- (path ""))
- (let ((path-record (filedb:get-path-record fdb curr-id)))
- (if (not path-record) #f ;; this id has no path
- (let* ((parent-id (list-ref path-record 1))
- (pname (list-ref path-record 0))
- (newpath (string-append "/" pname path)))
- (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
- (begin
- (hash-table-set! idcache id newpath)
- newpath)
- (loop parent-id newpath)))))))))
-
-(define (filedb:search db pattern)
- (let ((action (lambda (id)(print (filedb:get-path db id)))))
- (filedb:find-all db pattern action)))
-
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
DELETED ftail.scm
Index: ftail.scm
==================================================================
--- ftail.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;======================================================================
-;; Copyright 2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;;======================================================================
-
-(declare (unit ftail))
-
-(module ftail
- (
- open-tail-db
- tail-write
- tail-get-fid
- file-tail
- )
-
-(import scheme chicken data-structures extras)
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
-
-)
Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ index-tree.scm
@@ -34,11 +34,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
;; Populate the links tree with index.html files
;;
;; - start from most recent tests and work towards oldest -OR-
;; start from deepest hierarchy and work way up
DELETED lock-queue.scm
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ /dev/null
@@ -1,253 +0,0 @@
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-(use (prefix sqlite3 sqlite3:) srfi-18)
-
-(declare (unit lock-queue))
-(declare (uses common))
-(declare (uses tasks))
-
-;;======================================================================
-;; attempt to prevent overlapping updates of rollup files by queueing
-;; update requests in an sqlite db
-;;======================================================================
-
-;;======================================================================
-;; db record, <vector db path-to-db>
-;;======================================================================
-
-(define (make-lock-queue:db-dat)(make-vector 3))
-(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0))
-(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1))
-(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val))
-
-(define (lock-queue:delete-lock-db dbdat)
- (let ((fname (lock-queue:db-dat-get-path dbdat)))
- (system (conc "rm -f " fname "*"))))
-
-(define (lock-queue:open-db fname #!key (count 10))
- (let* ((actualfname (conc fname ".lockdb"))
- (dbexists (common:file-exists? actualfname))
- (db (sqlite3:open-database actualfname))
- (handler (make-busy-timeout 136000)))
- (if dbexists
- (vector db actualfname)
- (begin
- (handle-exceptions
- exn
- (begin
- (thread-sleep! 10)
- (if (> count 0)
- (lock-queue:open-db fname count: (- count 1))
- (vector db actualfname)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:execute
- db
- "CREATE TABLE IF NOT EXISTS queue (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- start_time INTEGER,
- state TEXT,
- CONSTRAINT queue_constraint UNIQUE (test_id));")
- (sqlite3:execute
- db
- "CREATE TABLE IF NOT EXISTS runlocks (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- run_lock TEXT,
- CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
- (sqlite3:set-busy-handler! db handler)
- (vector db actualfname)))
-
-(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 30)
- (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
- (begin
- (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
- #f))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
- newstate
- test-id)))
-
-(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
- ;; no need to wait on journal on read only queries
- ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 5)
- (lock-queue:delete-lock-db dbdat)
- (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
- (begin
- (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
- #f))
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (tid)
- ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
- (if (not (equal? tid test-id))
- (set! res tid)))
- (lock-queue:db-dat-get-db dbdat)
- "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
- res)))
-
-(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
- (let* ((res #f)
- (db (lock-queue:db-dat-get-db dbdat))
- (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
- (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
- (let ((result
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 10)
- ;; (if (> count 0)
- ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries
- ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
- (lock-queue:delete-lock-db dbdat)
- #f)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row (lambda (tid lockstate)
- (set! res (list tid lockstate)))
- lckqry)
- (if res
- (if (equal? (car res) test-id)
- #t ;; already have the lock
- #f)
- (begin
- (sqlite3:execute mklckqry test-id)
- ;; if no error handled then return #t for got the lock
- #t)))))))
- (sqlite3:finalize! lckqry)
- (sqlite3:finalize! mklckqry)
- result)))
-
-(define (lock-queue:release-lock fname test-id #!key (count 10))
- (let* ((dbdat (lock-queue:open-db fname)))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! (/ count 10))
- (if (> count 0)
- (begin
- (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
- (lock-queue:release-lock fname test-id count: (- count 1)))
- (let ((journal (conc fname "-journal")))
- ;; If we've tried ten times and failed there is a serious problem
- ;; try to remove the lock db and allow it to be recreated
- (handle-exceptions
- exn
- #f
- (if (common:file-exists? journal)(delete-file journal))
- (if (common:file-exists? fname) (delete-file fname))
- #f))))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
- (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
-
-(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
- (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 10)
- (if (> count 0)
- (lock-queue:steal-lock dbdat test-id count: (- count 1))
- #f))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
- (lock-queue:get-lock dbdat test-it))
-
-;; returns #f if ok to skip the task
-;; returns #t if ok to proceed with task
-;; otherwise waits
-;;
-(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
- (let* ((dbdat (lock-queue:open-db fname))
- (mystart (current-seconds))
- (db (lock-queue:db-dat-get-db dbdat)))
- ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))
- (thread-sleep! 10)
- (if (> count 0)
- (begin
- (sqlite3:finalize! db)
- (lock-queue:wait-turn fname test-id count: (- count 1)))
- (begin
- (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
- (print-call-chain (current-error-port))
- #f)))
- ;; wait 10 seconds and then check to see if someone is already updating the html
- (thread-sleep! 10)
- (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
- (begin
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
- (sqlite3:execute
- db
- "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
- test-id mystart)
- ;; (thread-sleep! 1) ;; give other tests a chance to register
- (let ((result
- (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
- (if younger-waiting
- (begin
- ;; no need for us to wait. mark in the lock queue db as skipping
- ;; no point in marking anything in the queue - simply never register this
- ;; test as it is *covered* by a previously started update to the html file
- ;; (lock-queue:set-state dbdat test-id "skipping")
- #f) ;; let the calling process know that nothing needs to be done
- (if (lock-queue:get-lock dbdat test-id)
- #t
- (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
- (lock-queue:steal-lock dbdat test-id)
- (begin
- (thread-sleep! 1)
- (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
- (sqlite3:finalize! db)
- result))))))
-
-
-;; (use trace)
-;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1,6 +1,6 @@
-;; Copyright 2006-2017, Matthew Welland.
+>;; Copyright 2006-2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -47,11 +47,10 @@
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
-(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
readline apropos json http-client directory-utils typed-records
http-client srfi-18 extras format)
@@ -1092,12 +1091,11 @@
;;======================================================================
;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
- (let* ((runrec (runs:runrec-make-record))
- (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
+ (let* ((target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
(runname (or runname-in
(args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
(testpatt (or (args:get-arg "-testpatt")
(and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
(common:get-full-test-name))
@@ -1250,14 +1248,10 @@
(if indx
(if (>= indx (vector-length datavec))
#f ;; index too high, should raise an error I suppose
(vector-ref datavec indx))
#f)))
-
-
-
-
(when (args:get-arg "-testdata-csv")
(if (launch:setup)
(let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
(runpatt (or (args:get-arg "-runname") "%"))
DELETED mlaunch.scm
Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; Copyright 2006-2014, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-;;======================================================================
-;; MLAUNCH
-;;
-;; take jobs from the given queue and keep launching them keeping
-;; the cpu load at the targeted level
-;;
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
-
-(declare (unit mlaunch))
-(declare (uses db))
-(declare (uses common))
-
DELETED monitor.scm
Index: monitor.scm
==================================================================
--- monitor.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit runs))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -33,11 +33,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
;;======================================================================
@@ -102,11 +101,11 @@
#f))))
(if useres
(let ((result (vector-ref res 1)))
(debug:print 4 *default-log-port* "Using lazy value res: " result)
result)
- (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
+ (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode itemmaps)))
(hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
newres))))
(define (mt:get-run-stats dbstruct run-id)
;; Get run stats from local access, move this ... but where?
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -55,11 +55,11 @@
;; helpers for mappers/checkers
(define (add-target-mapper name proc)
(hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
(hash-table-set! *runname-mappers* name proc))
-(define (add-area-checker name proc)
+(define (add-area-checker name proc) ;; util, USED EXTERNALLY, do not remove.
(hash-table-set! *area-checkers* name proc))
;; given a runkey, xlatr-key and other info return one of the following:
;; list of targets, null list to skip processing
;;
@@ -1692,11 +1692,12 @@
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
- (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
+ (if (and (equal? msg "time-to-die")
+ (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-close-nn host-port msg attrib timeout: time-out )))
@@ -1720,11 +1721,12 @@
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
- (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
+ (if (and (equal? msg "time-to-die")
+ (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-receive-nn host-port msg attrib timeout: time-out )))
DELETED newdashboard.scm
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ /dev/null
@@ -1,742 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2016, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;;======================================================================
-
-(use format)
-
-(use (prefix iup iup:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
- (prefix dbi dbi:))
-
-(declare (uses common))
-(declare (uses megatest-version))
-(declare (uses margs))
-
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses server))
-;; (declare (uses synchash))
-(declare (uses dcommon))
-;; (declare (uses tree))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;; (include "key_records.scm")
-
-(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2011
-
-Usage: dashboard [options]
- -h : this help
- -server host:port : connect to host:port instead of db access
- -test testid : control test identified by testid
- -guimonitor : control panel for runs
-
-Misc
- -rows N : set number of rows
-"))
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-rows"
- "-run"
- "-test"
- "-debug"
- "-host"
- )
- (list "-h"
- "-guimonitor"
- "-main"
- "-v"
- "-q"
- )
- args:arg-hash
- 0))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(debug:setup)
-
-(define *tim* (iup:timer))
-(define *ord* #f)
-
-(iup:attribute-set! *tim* "TIME" 300)
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define (message-window msg)
- (iup:show
- (iup:dialog
- (iup:vbox
- (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items . default)
- (let ((i 1)
- (selected-item (if (null? default) #f (car default))))
- (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
- (for-each (lambda (item)
- (iup:attribute-set! lb (number->string i) item)
- (if selected-item
- (if (equal? selected-item item)
- (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
- (set! i (+ i 1)))
- items)
- i))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-
-(define (mkstr . x)
- (string-intersperse (map conc x) ","))
-
-(define (update-search x val)
- (hash-table-set! *searchpatts* x val))
-
-
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat
- ;; runs
- ((allruns '()) : list) ;; list of dboard:rundat records
- ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
- ((done-runs '()) : list) ;; list of runs already drawn
- ((not-done-runs '()) : list) ;; list of runs not yet drawn
- (header #f) ;; header for decoding the run records
- (keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
- ((tot-runs 0) : number)
- ((last-data-update 0) : number) ;; last time the data in allruns was updated
- ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
- (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
- ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
- ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
- ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
-
- ;; Runs view
- ((buttondat (make-hash-table)) : hash-table) ;;
- ((item-test-names '()) : list) ;; list of itemized tests
- ((run-keys (make-hash-table)) : hash-table)
- (runs-matrix #f) ;; used in newdashboard
- ((start-run-offset 0) : number) ;; left-right slider value
- ((start-test-offset 0) : number) ;; up-down slider value
- ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
- ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
- ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
- ((all-test-names '()) : list)
-
- ;; Canvas and drawing data
- (cnv #f)
- (cnv-obj #f)
- (drawing #f)
- ((run-start-row 0) : number)
- ((max-row 0) : number)
- ((running-layout #f) : boolean)
- (originx #f)
- (originy #f)
- ((layout-update-ok #t) : boolean)
- ((compact-layout #t) : boolean)
-
- ;; Run times layout
- ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
- (graph-matrix #f)
- ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
- ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
- ((graph-matrix-row 1) : number)
- ((graph-matrix-col 1) : number)
-
- ;; Controls used to launch runs etc.
- ((command "") : string) ;; for run control this is the command being built up
- (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
- (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
- (key-listboxes #f)
- (key-lbs #f)
- run-name ;; from run name setting widget
- states ;; states for -state s1,s2 ...
- statuses ;; statuses for -status s1,s2 ...
-
- ;; Selector variables
- curr-run-id ;; current row to display in Run summary view
- prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
- curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
- ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
- ((hide-empty-runs #f) : boolean)
- ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
- (hide-not-hide-button #f)
- ((searchpatts (make-hash-table)) : hash-table) ;;
- ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
- ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
- (target #f)
- (test-patts #f)
-
- ;; db info to file the .db files for the area
- (access-mode (db:get-access-mode)) ;; use cached db or not
- (dbdir #f)
- (dbfpath #f)
- (dbkeys #f)
- ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
- (monitor-db-path #f) ;; where to find monitor.db
- ro ;; is the database read-only?
-
- ;; tests data
- ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
-
- ;; runs tree
- ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
- (runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
- ;; tab data
- ((view-changed #t) : boolean)
- ((xadj 0) : number) ;; x slider number (if using canvas)
- ((yadj 0) : number) ;; y slider number (if using canvas)
- ;; runs-summary tab state
- ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
- ((runs-summary-mode-buttons '()) : list)
- ((runs-summary-mode 'one-run) : symbol)
- ((runs-summary-mode-change-callbacks '()) : list)
- (runs-summary-source-runname-label #f)
- (runs-summary-dest-runname-label #f)
- ;; runs summary view
-
- tests-tree ;; used in newdashboard
- )
-
-
-
-;; mtest is actually the megatest.config file
-;;
-(define (mtest toppath window-id)
- (let* ((curr-row-num 0)
- ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
- (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
- (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
- (jobtools-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 3))
- (validvals-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 2
- #:numcol-visible 1
- #:numlin-visible 2))
- (envovrd-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- (disks-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- )
- (iup:attribute-set! disks-matrix "0:0" "Disk Name")
- (iup:attribute-set! disks-matrix "0:1" "Disk Path")
- (iup:attribute-set! disks-matrix "WIDTH1" "120")
- (iup:attribute-set! disks-matrix "WIDTH0" "100")
- (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
-
- ;; fill in existing info
- (for-each
- (lambda (mat fname)
- (set! curr-row-num 1)
- (for-each
- (lambda (var)
- (iup:attribute-set! mat (conc curr-row-num ":0") var)
- ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
- (set! curr-row-num (+ curr-row-num 1)))
- '()));; (configf:section-vars rawconfig fname)))
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
- (list "setup" "jobtools" "validvalues" "env-override" "disks"))
-
- (for-each
- (lambda (mat)
- (iup:attribute-set! mat "0:1" "Value")
- (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES")
- (iup:attribute-set! mat "WIDTH1" "120")
- (iup:attribute-set! mat "WIDTH0" "100")
- )
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
-
- (iup:attribute-set! validvals-matrix "WIDTH1" "290")
- (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
-
- (iup:vbox
- (iup:hbox
-
- (iup:vbox
- (let ((tabs (iup:tabs
- ;; The required tab
- (iup:hbox
- ;; The keys
- (iup:frame
- #:title "Keys (required)"
- (iup:vbox
- (iup:label (conc "Set the fields for organising your runs\n"
- "here. Note: can only be changed before\n"
- "running the first run when megatest.db\n"
- "is created."))
- keys-matrix))
- (iup:vbox
- ;; The setup section
- (iup:frame
- #:title "Setup"
- (iup:vbox
- (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
- "linktree : directory where linktree will be created."))
- setup-matrix))
- ;; The jobtools
- (iup:frame
- #:title "Jobtools"
- (iup:vbox
- (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
- "useshell : use system to run your launcher\n"
- "workhosts : spread jobs out on these hosts"))
- jobtools-matrix))
- ;; The disks
- (iup:frame
- #:title "Disks"
- (iup:vbox
- (iup:label (conc "Enter names and existing paths of locations to run tests"))
- disks-matrix))))
- ;; The optional tab
- (iup:vbox
- ;; The Environment Overrides
- (iup:frame
- #:title "Env override"
- envovrd-matrix)
- ;; The valid values
- (iup:frame
- #:title "Validvalues"
- validvals-matrix)
- ))))
- (iup:attribute-set! tabs "TABTITLE0" "Required settings")
- (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
- tabs))
- ))))
-
-;; The runconfigs.config file
-;;
-(define (rconfig window-id)
- (iup:vbox
- (iup:frame #:title "Default")))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-(define (tree-path->test-id path)
- (if (not (null? path))
- (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
- #f))
-
-(define (test-panel window-id)
- (let* ((curr-row-num 0)
- (viewlog (lambda (x)
- (if (common:file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
- (command-launch-button (iup:button "Execute!"
- ;; #:expand "HORIZONTAL"
- #:size "50x"
- #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
- " -runtests " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
- " -testpatt " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (run-info-matrix (iup:matrix
- #:expand "YES"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin 4
- #:numcol-visible 1
- #:numlin-visible 4
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status))))
- (test-info-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 7
- #:numcol-visible 1
- #:numlin-visible 7))
- (test-run-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (meta-dat-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (steps-matrix (iup:matrix
- #:expand "YES"
- #:numcol 6
- #:numlin 50
- #:numcol-visible 6
- #:numlin-visible 8))
- (data-matrix (iup:matrix
- #:expand "YES"
- #:numcol 8
- #:numlin 50
- #:numcol-visible 8
- #:numlin-visible 8))
- (updater (lambda (testdat)
- (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
-
- ;; Set the updater in updaters
- ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
- ;;
- (for-each
- (lambda (mat)
- ;; (iup:attribute-set! mat "0:1" "Value")
- ;; (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "HEIGHT0" 0)
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
- ;; (iup:attribute-set! mat "WIDTH1" "120")
- ;; (iup:attribute-set! mat "WIDTH0" "100"))
- (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
-
- ;; Steps matrix
- (iup:attribute-set! steps-matrix "0:1" "Step Name")
- (iup:attribute-set! steps-matrix "0:2" "Start")
- (iup:attribute-set! steps-matrix "WIDTH2" "40")
- (iup:attribute-set! steps-matrix "0:3" "End")
- (iup:attribute-set! steps-matrix "WIDTH3" "40")
- (iup:attribute-set! steps-matrix "0:4" "Status")
- (iup:attribute-set! steps-matrix "WIDTH4" "40")
- (iup:attribute-set! steps-matrix "0:5" "Duration")
- (iup:attribute-set! steps-matrix "WIDTH5" "40")
- (iup:attribute-set! steps-matrix "0:6" "Log File")
- (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
- ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
- ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
-
- ;; Data matrix
- ;;
- (let ((rownum 1))
- (for-each
- (lambda (x)
- (iup:attribute-set! data-matrix (conc "0:" rownum) x)
- (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
- (set! rownum (+ rownum 1)))
- (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
- (iup:attribute-set! data-matrix "REDRAW" "ALL")
-
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (keys (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (iup:attribute-set! mat (conc rownum ":0") key)
- (set! rownum (+ rownum 1)))
- keys)
- (iup:attribute-set! mat "REDRAW" "ALL")))
- (list
- (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
- (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
- (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
- (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
-
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- run-info-matrix
- test-info-matrix)
- ;; test-info-matrix)
- (iup:vbox
- test-run-matrix
- meta-dat-matrix))
- (iup:vbox
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
- (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
- (iup:hbox
- (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
- (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
- (iup:hbox
- ;; hiup:split ;; hbox
- ;; #:orientation "HORIZONTAL"
- ;; #:value 300
- command-text-box
- command-launch-button)))
- (iup:vbox
- (let ((tabs (iup:tabs
- steps-matrix
- data-matrix)))
- (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
- (iup:attribute-set! tabs "TABTITLE1" "Test Data")
- tabs)))))
-
-;; Test browser
-(define (tests window-id)
- (iup:split
- (let* ((tb (iup:treebox
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (test-id (tree-path->test-id (cdr run-path))))
- ;; (if test-id
- ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
- ;; window-id test-id))
- (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
- (iup:attribute-set! tb "VALUE" "0")
- (iup:attribute-set! tb "NAME" "Runs")
- ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- ;; (dboard:data-tests-tree-set! *data* tb)
- tb)
- (test-panel window-id)))
-
-;; The function to update the fields in the test view panel
-(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
- ;; get test-id
- ;; then get test record
- (if testdat
- (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
- (test-data (hash-table-ref/default testdat test-id #f))
- (run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
- run-id
- '()))
- (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
- (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
- (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
-
- (if test-data
- (begin
- ;;
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (vals (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (let ((cell (conc rownum ":1")))
- (if (not (equal? (iup:attribute mat cell)(conc key)))
- (begin
- ;; (print "setting cell " cell " in matrix " mat " to value " key)
- (iup:attribute-set! mat cell (conc key))
- (iup:attribute-set! mat "REDRAW" cell)))
- (set! rownum (+ rownum 1))))
- vals)))
- (list
- (list run-info-matrix
- (if test-id
- (list (db:test-get-run_id test-data)
- target
- runname
- "n/a")
- (make-list 4 "")))
- (list test-info-matrix
- (if test-id
- (list test-id
- (db:test-get-testname test-data)
- (db:test-get-item-path test-data)
- (db:test-get-state test-data)
- (db:test-get-status test-data)
- (seconds->string (db:test-get-event_time test-data))
- (db:test-get-comment test-data))
- (make-list 7 "")))
- (list test-run-matrix
- (if test-id
- (list (db:test-get-host test-data)
- (db:test-get-uname test-data)
- (db:test-get-diskfree test-data)
- (db:test-get-cpuload test-data)
- (seconds->hr-min-sec (db:test-get-run_duration test-data)))
- (make-list 5 "")))
- ))
- (dcommon:populate-steps steps-dat steps-matrix))))))
- ;;(list meta-dat-matrix
- ;; (if test-id
- ;; (list (
-
-
-;; db:test-get-id
-;; db:test-get-run_id
-;; db:test-get-testname
-;; db:test-get-state
-;; db:test-get-status
-;; db:test-get-event_time
-;; db:test-get-host
-;; db:test-get-cpuload
-;; db:test-get-diskfree
-;; db:test-get-uname
-;; db:test-get-rundir
-;; db:test-get-item-path
-;; db:test-get-run_duration
-;; db:test-get-final_logf
-;; db:test-get-comment
-;; db:test-get-fullname
-
-
-;;======================================================================
-;; R U N C O N T R O L
-;;======================================================================
-
-;; Overall runs browser
-;;
-(define (runs window-id)
- (let* ((runs-matrix (iup:matrix
- #:expand "YES"
- ;; #:fittosize "YES"
- #:scrollbar "YES"
- #:numcol 100
- #:numlin 100
- #:numcol-visible 7
- #:numlin-visible 7
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
-
- (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
- (iup:attribute-set! runs-matrix "WIDTH0" "100")
-
- ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
- (iup:hbox
- (iup:frame
- #:title "Runs browser"
- (iup:vbox
- runs-matrix)))))
-
-;; Browse and control a single run
-;;
-(define (runcontrol window-id)
- (iup:hbox))
-
-;;======================================================================
-;; D A S H B O A R D
-;;======================================================================
-
-;; Main Panel
-(define (main-panel window-id)
- (iup:dialog
- #:title "Megatest Control Panel"
- #:menu (dcommon:main-menu)
- #:shrink "YES"
- (let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
- (runcontrol window-id)
- (mtest *toppath* window-id)
- (rconfig window-id)
- )))
- (iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
- tabtop)))
-
-(define *current-window-id* 0)
-
-(define (newdashboard dbstruct)
- (let* ((data (make-hash-table))
- (keys '()) ;; (db:get-keys dbstruct))
- (runname "%")
- (testpatt "%")
- (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
- (states '())
- (statuses '())
- (nextmintime (current-milliseconds))
- (my-window-id *current-window-id*))
- (set! *current-window-id* (+ 1 *current-window-id*))
- ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
- (iup:show (main-panel my-window-id))
- ;; Yes, running iup:show will pop up a new panel
- ;; (iup:show (main-panel my-window-id))
- (iup:callback-set! *tim*
- "ACTION_CB"
- (lambda (x)
- ;; Want to dedicate no more than 50% of the time to this so skip if
- ;; 2x delta time has not passed since last query
- (if (< nextmintime (current-milliseconds))
- (let* ((starttime (current-milliseconds))
- ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
- (endtime (current-milliseconds)))
- (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
- ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
- )
- (debug:print-info 11 *default-log-port* "Server overloaded"))))))
-
-;; (dboard:data-updaters-set! *data* (make-hash-table))
-(newdashboard #f) ;; *dbstruct-local*)
-(iup:main-loop)
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -30,17 +30,10 @@
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
res)))
(define (process:cmd-run-with-stderr->list cmd . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
-;; (print " " ((condition-property-accessor 'exn 'message) exn))
-;; #f)
(let-values (((fh fho pid fhe) (if (null? params)
(process* cmd)
(process* cmd params))))
(let loop ((curr (read-line fh))
(result '()))
@@ -55,17 +48,10 @@
(close-input-port fhe)
(close-output-port fho)
result))))) ;; )
(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
-;; (print " " ((condition-property-accessor 'exn 'message) exn))
-;; #f)
(let-values (((fh fho pid fhe) (if (null? params)
(process* cmd)
(process* cmd params))))
(let loop ((curr (read-line fh))
(result '()))
@@ -81,11 +67,10 @@
(close-input-port fhe)
(close-output-port fho)
(list result (if normalexit? exitstatus -1))))))))
(define (process:cmd-run-proc-each-line cmd proc . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
(handle-exceptions
exn
(begin
(print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
DELETED records-vs-vectors-vs-coops.scm
Index: records-vs-vectors-vs-coops.scm
==================================================================
--- records-vs-vectors-vs-coops.scm
+++ /dev/null
@@ -1,110 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;; (include "vg.scm")
-
-;; (declare (uses vg))
-
-(use foof-loop defstruct coops)
-
-(defstruct obj type fill-color angle)
-
-(define (make-vg:obj)(make-vector 3))
-(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
-(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
-(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
-(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
-(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
-(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
-
-(use simple-exceptions)
-(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
-(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
-(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
-(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
-(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
-(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
-(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
-(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
-
-(define-class <vgc> ()
- ((type)
- (fill-color)
- (angle)))
-
-
-;; first use raw vectors
-(print "Using vectors")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-vg:obj)))
- (vg:obj-set-type! obj 'abc)
- (vg:obj-set-fill-color! obj "green")
- (vg:obj-set-angle! obj 135)
- (let ((a (vg:obj-get-type obj))
- (b (vg:obj-get-fill-color obj))
- (c (vg:obj-get-angle obj)))
- obj))))))
-
-;; first use raw vectors with safe mode
-(print "Using vectors (safe mode)")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-vgs:obj)))
- ;; (badobj (make-vector 20)))
- (vgs:obj-type-set! obj 'abc)
- (vgs:obj-fill-color-set! obj "green")
- (vgs:obj-angle-set! obj 135)
- (let ((a (vgs:obj-type obj))
- (b (vgs:obj-fill-color obj))
- (c (vgs:obj-angle obj)))
- obj))))))
-
-;; first use defstruct
-(print "Using defstruct")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-obj)))
- (obj-type-set! obj 'abc)
- (obj-fill-color-set! obj "green")
- (obj-angle-set! obj 135)
- (let ((a (obj-type obj))
- (b (obj-fill-color obj))
- (c (obj-angle obj)))
- obj))))))
-
-
-;; first use defstruct
-(print "Using coops")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make <vgc>)))
- (set! (slot-value obj 'type) 'abc)
- (set! (slot-value obj 'fill-color) "green")
- (set! (slot-value obj 'angle) 135)
- (let ((a (slot-value obj 'type))
- (b (slot-value obj 'fill-color))
- (c (slot-value obj 'angle)))
- obj))))))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -675,11 +675,12 @@
(apply append
(map (lambda (run-id)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
run-ids))))
-(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
+;; NOTE: rmt functions can NEVER have key params as they might be called as local
+(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmaps #f))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
DELETED rmtdb.scm
Index: rmtdb.scm
==================================================================
--- rmtdb.scm
+++ /dev/null
@@ -1,20 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;;======================================================================
-
Index: run_records.scm
==================================================================
--- run_records.scm
+++ run_records.scm
@@ -38,11 +38,5 @@
(define-inline (test:get-test-name vec)(vector-ref vec 2))
(define-inline (test:get-state vec) (vector-ref vec 3))
(define-inline (test:get-status vec) (vector-ref vec 4))
(define-inline (test:get-item-path vec)(vector-ref vec 5))
-(define-inline (test:test-get-fullname test)
- (conc (db:test-get-testname test)
- (if (equal? (db:test-get-item-path test) "")
- ""
- (conc "(" (db:test-get-item-path test) ")"))))
-
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -34,11 +34,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
;; (include "debugger.scm")
;; use this struct to facilitate refactoring
;;
@@ -60,11 +59,15 @@
)
(defstruct runs:testdat
hed tal reg reruns test-record
test-name item-path jobgroup
- waitons testmode newtal itemmaps prereqs-not-met)
+ waitons testmode newtal
+ itemmaps
+ (prereqs-not-met #f)
+ (last-update 0) ;;
+ )
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;; - remove any that are over 3600 seconds old
;; - if there are any that are younger than 10 seconds
;; * sleep 10 seconds
@@ -886,31 +889,40 @@
;; tal - list of never visited tests
;; prefer next hed to be from reg than tal.
(define runs:nothing-left-in-queue-count 0)
+(define (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
+ (if (and (runs:testdat-prereqs-not-met testdat)
+ (< (- (current-seconds) (runs:testdat-last-update testdat)) 10)) ;; only refresh for this test if it has been at least 10 seconds
+ (runs:testdat-prereqs-not-met testdat)
+ (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode itemmaps)))
+ (if (list? res)
+ res
+ (begin
+ (debug:print 0 *default-log-port*
+ "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
+ " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps)
+ '())))))
+ (runs:testdat-prereqs-not-met-set! testdat res)
+ (runs:testdat-last-update-set! testdat (current-seconds))
+ res)))
+
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;; (let loop ((hed (car sorted-test-names))
;; (tal (cdr sorted-test-names))
;; (reg '()) ;; registered, put these at the head of tal
;; (reruns '()))
-(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
+(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record
+ can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat)
(let* ((loop-list (list hed tal reg reruns))
- (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
- (if (list? res)
- res
- (begin
- (debug:print 0 *default-log-port*
- "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
- " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
- '()))))
- (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
- ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
+ (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
+ (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
(fails (runs:calc-fails prereqs-not-met))
(prereq-fails (runs:calc-prereq-fail prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(runnables (runs:calc-runnable prereqs-not-met))
(unexpanded-prereqs
@@ -1152,12 +1164,10 @@
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup(list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
- ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
- ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs
(runs:calc-fails prereqs-not-met)
(begin
(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
'())))
@@ -1553,11 +1563,10 @@
keyvals: keyvals
run-info: run-info
;; newtal: newtal
all-tests-registry: all-tests-registry
;; itemmaps: itemmaps
- ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)
;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
)))
;; Initialize the test-registery hash with tests that already have a record
;; convert state to symbol and use that as the hash value
@@ -1772,11 +1781,13 @@
(loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
(- remtries 1)))))))
)))))
;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed
- (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
+ (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path
+ mode: testmode
+ itemmaps: itemmaps)
;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
(runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))
(let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
@@ -1843,11 +1854,11 @@
((or (procedure? items)(eq? items 'have-procedure))
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-4")
(let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
(if (not can-run-more) #;(and (list? can-run-more)
(car can-run-more))
- (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
+ (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat))) ;; itemized test expanded here
(if loop-list
(apply loop loop-list)
(debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
)
)
DELETED sauth-common.scm
Index: sauth-common.scm
==================================================================
--- sauth-common.scm
+++ /dev/null
@@ -1,328 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-
-;; Create the sqlite db
-(define (sauthorize:db-do proc)
- (if (or (not *db-path*)
- (not (file-exists? *db-path*)))
- (begin
- (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
- (exit 1)))
- (if (and *db-path*
- (directory? *db-path*)
- (file-read-access? *db-path*))
- (let* ((dbpath (conc *db-path* "/sauthorize.db"))
- (writeable (file-write-access? dbpath))
- (dbexists (file-exists? dbpath)))
- (handle-exceptions
- exn
- (begin
- (print 2 "ERROR: problem accessing db " dbpath
- ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- ;(print "calling proc " proc "db path " dbpath )
- (call-with-database
- dbpath
- (lambda (db)
- ;(print 0 "calling proc " proc " on db " db)
- (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
- (if (not dbexists)(sauthorize:initialize-db db))
- (proc db)))))
- (print 0 "ERROR: invalid path for storing database: " *db-path*)))
-
-;;execute a query
-(define (sauthorize:db-qry db qry)
- ;(print qry)
- (exec (sql db qry)))
-
-
-(define (sauthorize:do-as-calling-user proc)
- (let ((eid (current-effective-user-id))
- (cid (current-user-id)))
- (if (not (eq? eid cid)) ;; running suid
- (set! (current-effective-user-id) cid))
- ;(print 0 "cid " cid " eid:" eid)
- (proc)
- (if (not (eq? eid cid))
- (set! (current-effective-user-id) eid))))
-
-
-(define (run-cmd cmd arg-list)
- ; (print (current-effective-user-id))
- ;(handle-exceptions
-; exn
-; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
- (let ((pid (process-run cmd arg-list)))
- (process-wait pid))
-)
-;)
-
-
-(define (regster-log inl usr-id area-id cmd)
- (sauth-common:shell-do-as-adm
- (lambda ()
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )")))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Check user types
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-;;check if a user is an admin
-(define (is-admin username)
- (let* ((admin #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
- (if (not (null? data-row))
- (let ((col (car data-row)))
- (if (equal? col "yes")
- (set! admin #t)))))))
-admin))
-
-
-;;check if a user is an read-admin
-(define (is-read-admin username)
- (let* ((admin #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
- (if (not (null? data-row))
- (let ((col (car data-row)))
- (if (equal? col "read-admin")
- (set! admin #t)))))))
-admin))
-
-
-;;check if user has specifc role for a area
-(define (is-user role username area)
- (let* ((has-access #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
- (if (not (null? data-row))
- (begin
- (let* ((access-type (car data-row))
- (exdate (cadr data-row)))
- (if (not (null? exdate))
- (begin
- (let ((valid (is-access-valid exdate)))
- ;(print valid)
- (if (and (equal? access-type role)
- (equal? valid #t))
- (set! has-access #t))))
- (print "Access expired"))))))))
- ;(print has-access)
-has-access))
-
-(define (is-access-valid exp-str)
- (let* ((ret-val #f )
- (date-parts (string-split exp-str "/"))
- (yr (string->number (car date-parts)))
- (month (string->number(car (cdr date-parts))))
- (day (string->number(caddr date-parts)))
- (exp-date (make-date 0 0 0 0 day month yr )))
- ;(print exp-date)
- ;(print (current-date))
- (if (> (date-compare exp-date (current-date)) 0)
- (set! ret-val #t))
- ;(print ret-val)
- ret-val))
-
-
-;check if area exists
-(define (area-exists area)
- (let* ((area-defined #f))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
- (if (not (null? data-row))
- (set! area-defined #t)))))
-area-defined))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Get Record from database
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;gets area id by code
-(define (get-area area)
- (let* ((area-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
- (set! area-defined data-row))))
-area-defined))
-
-;get id of users table by user name
-(define (get-user user)
- (let* ((user-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'")))))
- (set! user-defined data-row))))
-user-defined))
-
-;get permissions id by userid and area id
-(define (get-perm userid areaid)
- (let* ((user-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid)))))
- (set! user-defined data-row))))
-
-user-defined))
-
-(define (get-restrictions base-path usr)
-(let* ((user-defined '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'")))))
- ;(print data-row)
- (set! user-defined data-row))))
- ; (print user-defined)
- (if (null? user-defined)
- ""
- (car user-defined))))
-
-
-(define (get-obj-by-path path)
- (let* ((obj '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'")))))
- (set! obj data-row))))
-obj))
-
-(define (get-obj-by-code code )
- (let* ((obj '()))
- (sauthorize:db-do (lambda (db)
- ;(print (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'"))
- (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'")))))
- ;(print data-row)
- (set! obj data-row)
- ;(print obj)
- )))
- (if (not (null? obj))
- (begin
- (let* ((req-grp (caddr (cddr obj))))
- (sauthorize:do-as-calling-user
- (lambda ()
- (sauth-common:check-user-groups req-grp))))))
-obj))
-
-(define (sauth-common:check-user-groups req-grp)
-(let* ((current-groups (get-groups) )
- (req-grp-list (string-split req-grp ",")))
- ;(print req-grp-list)
- (for-each (lambda (grp)
- (let ((grp-info (group-information grp)))
- ;(print grp-info " " grp)
- (if (not (equal? grp-info #f))
- (begin
- (if (not (member (caddr grp-info) current-groups))
- (begin
- (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
- (exit 1)))))))
- req-grp-list)))
-
-(define (get-obj-by-code-no-grp-validation code )
- (let* ((obj '()))
- (sauthorize:db-do (lambda (db)
- (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'")))))
- (set! obj data-row))))
-;(print obj)
-obj))
-
-
-(define (sauth-common:src-size path)
- (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'")
- (lambda()
- (read-line)))))
- (string->number output)))
-
-(define (sauth-common:space-left-at-dest path)
- (let* ((output (run/string (pipe (df ,path ) (tail -1))))
- (size (caddr (cdr (string-split output " ")))))
- (string->number size)))
-
-;; function to validate the users input for target path and resolve the path
-;; TODO: Check for restriction in subpath
-(define (sauth-common:resolve-path new current allowed-sheets)
- (let* ((target-path (append current (string-split new "/")))
- (target-path-string (string-join target-path "/"))
- (normal-path (normalize-pathname target-path-string))
- (normal-list (string-split normal-path "/"))
- (ret '()))
- (if (string-contains normal-path "..")
- (begin
- (print "ERROR: Path " new " resolved outside target area ")
- #f)
- (if(equal? normal-path ".")
- ret
- (if (not (member (car normal-list) allowed-sheets))
- (begin
- (print "ERROR: Permision denied to " new )
- #f)
- normal-list)))))
-
-(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
- (usr (current-user-name) ) )
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- #f
- (let* ((sheet (car resolved-path))
- (restricted-areas (get-restrictions base-path usr))
- (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
- (target-path (if (null? (cdr resolved-path))
- base-path
- (conc base-path "/" (string-join (cdr resolved-path) "/")))))
-
-
- (if (and (not (equal? restricted-areas "" ))
- (string-match (regexp restrictions) target-path))
- (begin
- (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
- ;(exit 1)
- #f)
- target-path)
-
-))
- #f)))
-
-(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
- (if (and (null? base-path-list) (equal? ext-path "") )
- (print (string-intersperse top-areas " "))
- (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
- ;(print resolved-path)
- (if (not (equal? resolved-path #f))
- (if (null? resolved-path)
- (print (string-intersperse top-areas " "))
- (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
- (print target-path)
- (if (not (equal? target-path #f))
- (begin
- (cond
- ((null? tail-cmd-list)
- (run (pipe
- (ls "-lrt" ,target-path))))
- ((not (equal? (car tail-cmd-list) "|"))
- (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
- (else
- (run (pipe
- (ls "-lrt" ,target-path)
- (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
-
-(define (sauth:print-error msg)
- (with-output-to-port (current-error-port)
- (lambda ()
- (print (conc "ERROR: " msg)))))
-
ADDED sauth-src/sauth-common.scm
Index: sauth-src/sauth-common.scm
==================================================================
--- /dev/null
+++ sauth-src/sauth-common.scm
@@ -0,0 +1,328 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+
+;; Create the sqlite db
+(define (sauthorize:db-do proc)
+ (if (or (not *db-path*)
+ (not (file-exists? *db-path*)))
+ (begin
+ (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
+ (exit 1)))
+ (if (and *db-path*
+ (directory? *db-path*)
+ (file-read-access? *db-path*))
+ (let* ((dbpath (conc *db-path* "/sauthorize.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath)))
+ (handle-exceptions
+ exn
+ (begin
+ (print 2 "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ ;(print "calling proc " proc "db path " dbpath )
+ (call-with-database
+ dbpath
+ (lambda (db)
+ ;(print 0 "calling proc " proc " on db " db)
+ (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+ (if (not dbexists)(sauthorize:initialize-db db))
+ (proc db)))))
+ (print 0 "ERROR: invalid path for storing database: " *db-path*)))
+
+;;execute a query
+(define (sauthorize:db-qry db qry)
+ ;(print qry)
+ (exec (sql db qry)))
+
+
+(define (sauthorize:do-as-calling-user proc)
+ (let ((eid (current-effective-user-id))
+ (cid (current-user-id)))
+ (if (not (eq? eid cid)) ;; running suid
+ (set! (current-effective-user-id) cid))
+ ;(print 0 "cid " cid " eid:" eid)
+ (proc)
+ (if (not (eq? eid cid))
+ (set! (current-effective-user-id) eid))))
+
+
+(define (run-cmd cmd arg-list)
+ ; (print (current-effective-user-id))
+ ;(handle-exceptions
+; exn
+; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
+ (let ((pid (process-run cmd arg-list)))
+ (process-wait pid))
+)
+;)
+
+
+(define (regster-log inl usr-id area-id cmd)
+ (sauth-common:shell-do-as-adm
+ (lambda ()
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )")))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Check user types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;check if a user is an admin
+(define (is-admin username)
+ (let* ((admin #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
+ (if (not (null? data-row))
+ (let ((col (car data-row)))
+ (if (equal? col "yes")
+ (set! admin #t)))))))
+admin))
+
+
+;;check if a user is an read-admin
+(define (is-read-admin username)
+ (let* ((admin #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
+ (if (not (null? data-row))
+ (let ((col (car data-row)))
+ (if (equal? col "read-admin")
+ (set! admin #t)))))))
+admin))
+
+
+;;check if user has specifc role for a area
+(define (is-user role username area)
+ (let* ((has-access #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
+ (if (not (null? data-row))
+ (begin
+ (let* ((access-type (car data-row))
+ (exdate (cadr data-row)))
+ (if (not (null? exdate))
+ (begin
+ (let ((valid (is-access-valid exdate)))
+ ;(print valid)
+ (if (and (equal? access-type role)
+ (equal? valid #t))
+ (set! has-access #t))))
+ (print "Access expired"))))))))
+ ;(print has-access)
+has-access))
+
+(define (is-access-valid exp-str)
+ (let* ((ret-val #f )
+ (date-parts (string-split exp-str "/"))
+ (yr (string->number (car date-parts)))
+ (month (string->number(car (cdr date-parts))))
+ (day (string->number(caddr date-parts)))
+ (exp-date (make-date 0 0 0 0 day month yr )))
+ ;(print exp-date)
+ ;(print (current-date))
+ (if (> (date-compare exp-date (current-date)) 0)
+ (set! ret-val #t))
+ ;(print ret-val)
+ ret-val))
+
+
+;check if area exists
+(define (area-exists area)
+ (let* ((area-defined #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
+ (if (not (null? data-row))
+ (set! area-defined #t)))))
+area-defined))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Get Record from database
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;gets area id by code
+(define (get-area area)
+ (let* ((area-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
+ (set! area-defined data-row))))
+area-defined))
+
+;get id of users table by user name
+(define (get-user user)
+ (let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'")))))
+ (set! user-defined data-row))))
+user-defined))
+
+;get permissions id by userid and area id
+(define (get-perm userid areaid)
+ (let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid)))))
+ (set! user-defined data-row))))
+
+user-defined))
+
+(define (get-restrictions base-path usr)
+(let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'")))))
+ ;(print data-row)
+ (set! user-defined data-row))))
+ ; (print user-defined)
+ (if (null? user-defined)
+ ""
+ (car user-defined))))
+
+
+(define (get-obj-by-path path)
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'")))))
+ (set! obj data-row))))
+obj))
+
+(define (get-obj-by-code code )
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'"))
+ (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'")))))
+ ;(print data-row)
+ (set! obj data-row)
+ ;(print obj)
+ )))
+ (if (not (null? obj))
+ (begin
+ (let* ((req-grp (caddr (cddr obj))))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (sauth-common:check-user-groups req-grp))))))
+obj))
+
+(define (sauth-common:check-user-groups req-grp)
+(let* ((current-groups (get-groups) )
+ (req-grp-list (string-split req-grp ",")))
+ ;(print req-grp-list)
+ (for-each (lambda (grp)
+ (let ((grp-info (group-information grp)))
+ ;(print grp-info " " grp)
+ (if (not (equal? grp-info #f))
+ (begin
+ (if (not (member (caddr grp-info) current-groups))
+ (begin
+ (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
+ (exit 1)))))))
+ req-grp-list)))
+
+(define (get-obj-by-code-no-grp-validation code )
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'")))))
+ (set! obj data-row))))
+;(print obj)
+obj))
+
+
+(define (sauth-common:src-size path)
+ (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'")
+ (lambda()
+ (read-line)))))
+ (string->number output)))
+
+(define (sauth-common:space-left-at-dest path)
+ (let* ((output (run/string (pipe (df ,path ) (tail -1))))
+ (size (caddr (cdr (string-split output " ")))))
+ (string->number size)))
+
+;; function to validate the users input for target path and resolve the path
+;; TODO: Check for restriction in subpath
+(define (sauth-common:resolve-path new current allowed-sheets)
+ (let* ((target-path (append current (string-split new "/")))
+ (target-path-string (string-join target-path "/"))
+ (normal-path (normalize-pathname target-path-string))
+ (normal-list (string-split normal-path "/"))
+ (ret '()))
+ (if (string-contains normal-path "..")
+ (begin
+ (print "ERROR: Path " new " resolved outside target area ")
+ #f)
+ (if(equal? normal-path ".")
+ ret
+ (if (not (member (car normal-list) allowed-sheets))
+ (begin
+ (print "ERROR: Permision denied to " new )
+ #f)
+ normal-list)))))
+
+(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
+ (usr (current-user-name) ) )
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ #f
+ (let* ((sheet (car resolved-path))
+ (restricted-areas (get-restrictions base-path usr))
+ (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
+ (target-path (if (null? (cdr resolved-path))
+ base-path
+ (conc base-path "/" (string-join (cdr resolved-path) "/")))))
+
+
+ (if (and (not (equal? restricted-areas "" ))
+ (string-match (regexp restrictions) target-path))
+ (begin
+ (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
+ ;(exit 1)
+ #f)
+ target-path)
+
+))
+ #f)))
+
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+ (if (and (null? base-path-list) (equal? ext-path "") )
+ (print (string-intersperse top-areas " "))
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+ ;(print resolved-path)
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print (string-intersperse top-areas " "))
+ (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
+ (print target-path)
+ (if (not (equal? target-path #f))
+ (begin
+ (cond
+ ((null? tail-cmd-list)
+ (run (pipe
+ (ls "-lrt" ,target-path))))
+ ((not (equal? (car tail-cmd-list) "|"))
+ (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
+ (else
+ (run (pipe
+ (ls "-lrt" ,target-path)
+ (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
+
+(define (sauth:print-error msg)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print (conc "ERROR: " msg)))))
+
ADDED sauth-src/sauthorize.scm
Index: sauth-src/sauthorize.scm
==================================================================
--- /dev/null
+++ sauth-src/sauthorize.scm
@@ -0,0 +1,651 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+(use defstruct)
+(use scsh-process)
+
+(use srfi-18)
+(use srfi-19)
+(use refdb)
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+;(declare (uses common))
+;(declare (uses configf))
+(declare (uses margs))
+
+(include "megatest-version.scm")
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+ list : list areas $USER's can access
+ log : get listing of recent activity.
+ sauth list-area-user <area code> : list the users that can access the area.
+ sauth open <path> --group <grpname> : Open up an area. User needs to be the owner of the area to open it.
+ --code <unique short identifier for an area>
+ --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
+ sauth update <area code> --retrieve|--publish : update the binaries with the lates changes
+ sauth grant <username> --area <area identifier> : Grant permission to read or write to a area that is alrady opend up.
+ --expiration yyyy/mm/dd --retrieve|--publish
+ [--restrict <comma separated directory names> ]
+ sauth read-shell <area identifier> : Open sretrieve shell for reading.
+ sauth write-shell <area identifier> : Open spublish shell for writing.
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+(define (sauthorize:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (exec (sql db qry)))
+ (list
+ "CREATE TABLE IF NOT EXISTS actions
+ (id INTEGER PRIMARY KEY,
+ cmd TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ comment TEXT DEFAULT '' NOT NULL,
+ action_type TEXT NOT NULL);"
+ "CREATE TABLE IF NOT EXISTS users
+ (id INTEGER PRIMARY KEY,
+ username TEXT NOT NULL,
+ is_admin TEXT NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS areas
+ (id INTEGER PRIMARY KEY,
+ basepath TEXT NOT NULL,
+ code TEXT NOT NULL,
+ exe_name TEXT NOT NULL,
+ required_grps TEXT DEFAULT '' NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS permissions
+ (id INTEGER PRIMARY KEY,
+ access_type TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ restriction TEXT DEFAULT '' NOT NULL,
+ expiration TIMESTAMP DEFAULT NULL);"
+ )))
+
+
+
+
+(define (get-access-type args)
+ (let loop ((hed (car args))
+ (tal (cdr args)))
+ (cond
+ ((equal? hed "--retrieve")
+ "retrieve")
+ ((equal? hed "--publish")
+ "publish")
+ ((equal? hed "--area-admin")
+ "area-admin")
+ ((equal? hed "--writer-admin")
+ "writer-admin")
+ ((equal? hed "--read-admin")
+ "read-admin")
+
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+
+
+;; check if user can gran access to an area
+(define (can-grant-perm username access-type area)
+ (let* ((isadmin (is-admin username))
+ (is-area-admin (is-user "area-admin" username area ))
+ (is-read-admin (is-user "read-admin" username area) )
+ (is-writer-admin (is-user "writer-admin" username area) ) )
+ (cond
+ ((equal? isadmin #t)
+ #t)
+ ((equal? is-area-admin #t )
+ #t)
+ ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
+ #t)
+ ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
+ #t)
+
+ (else
+ #f))))
+
+(define (sauthorize:list-areausers area )
+ (sauthorize:db-do (lambda (db)
+ (print "Users having access to " area ":")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (cadr row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse row " | "))))))
+ (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
+
+
+
+
+; check if executable exists
+(define (exe-exist exe access-type)
+ (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
+ ; (print filepath)
+ (if (file-exists? filepath)
+ #t
+ #f)))
+
+(define (copy-exe access-type exe-name group)
+ (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
+ (let* ((spath (conc *exe-src* "/s" access-type))
+ (dpath (conc *exe-path* "/" access-type "/" exe-name)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd "/bin/cp" (list spath dpath ))
+ (if (equal? access-type "publish")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (if (equal? group "none")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (run-cmd "/bin/chgrp" (list group dpath))
+ (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
+ (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
+
+(define (get-exe-name path group)
+ (let ((name ""))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (if (equal? (current-effective-user-id) (file-owner path))
+ (set! name (conc (current-user-name) "_" group))
+ (begin
+ (print "You cannot open areas that you dont own!!")
+ (exit 1)))))
+name))
+
+(define (sauthorize:valid-unix-user username)
+ (let* ((ret-val #f))
+ (let-values (((inp oup pid)
+ (process "/usr/bin/id" (list username))))
+ (let loop ((inl (read-line inp)))
+ (if (string? inl)
+ (if (string-contains inl "No such user")
+ (set! ret-val #f)
+ (set! ret-val #t)))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (close-output-port oup))
+ (loop (read-line inp)))))
+ ret-val))
+
+
+;check if a paths/codes are vaid and if area is alrady open
+(define (open-area group path code access-type other-grps)
+ (let* ((exe-name (get-exe-name path group))
+ (path-obj (get-obj-by-path path))
+ (code-obj (get-obj-by-code-no-grp-validation code)))
+ ;(print path-obj)
+ (cond
+ ((not (null? path-obj))
+ (if (equal? code (car path-obj))
+ (begin
+ (if (equal? exe-name (cadr path-obj))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group)
+ (begin
+ (print "Area already open!!")
+ (exit 1))))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ ;; update exe-name in db
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
+ )))
+ (begin
+ (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
+ (exit 1))))
+
+ ((not (null? code-obj))
+ (print "Code " code " is used for diffrent path. Please try diffrent value of --code" )
+ (exit 1))
+ (else
+ ; (print (exe-exist exe-name access-type))
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ (sauthorize:db-do (lambda (db)
+ (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ")
+ (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
+
+(define (user-has-open-perm user path access)
+ (let* ((has-access #f)
+ (eid (current-user-id)))
+ (cond
+ ((is-admin user)
+ (set! has-access #t ))
+ ((and (is-read-admin user) (equal? access "retrieve"))
+ (set! has-access #t ))
+ (else
+ (print "User " user " does not have permission to open areas")))
+ has-access))
+
+
+;;check if user has group access
+(define (is-group-washed req_grpid current-grp-list)
+ (let loop ((hed (car current-grp-list))
+ (tal (cdr current-grp-list)))
+ (cond
+ ((equal? hed req_grpid)
+ #t)
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+;create executables with appropriate suids
+(define (sauthorize:open user path group code access-type other-groups)
+ (let* ((gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (and (not (equal? group "none")) (equal? valid-grp #f ))
+ (begin
+ (print "Group " group " is not washed in the current xterm!!")
+ (exit 1))))
+ (if (not (file-write-access? path))
+ (begin
+ (print "You can open areas owned by yourself. You do not have permissions to open path." path)
+ (exit 1)))
+ (if (user-has-open-perm user path access-type)
+ (begin
+ ;(print "here")
+ (open-area group path code access-type other-groups)
+ (sauthorize:grant user user code "2017/12/25" "read-admin" "")
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
+ (print "Area has " path " been opened for " access-type ))))
+
+(define (sauthorize:update username exe area access-type)
+ (let* ((parts (string-split exe "_"))
+ (owner (car parts))
+ (group (cadr parts))
+ (gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (not (equal? username owner))
+ (begin
+ (print "You cannot update " area ". Only " owner " can update this area!!")
+ (exit 1)))
+ (copy-exe access-type exe group)
+ (print "recording action..")
+ (sauthorize:db-do (lambda (db)
+
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
+ (print "Area has " area " been update!!" )))
+
+(define (sauthorize:grant auser guser area exp-date access-type restrict)
+ ; check if user exist in db
+ (let* ((area-obj (get-area area))
+ (auser-obj (get-user auser))
+ (user-obj (get-user guser)))
+
+ (if (null? user-obj)
+ (begin
+ ;; is guser a valid unix user
+ (if (not (sauthorize:valid-unix-user guser))
+ (begin
+ (print "User " guser " is Invalid unix user!!")
+ (exit 1)))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
+ (set! user-obj (get-user guser))))
+ (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
+ (if(null? perm-obj)
+ (begin
+ ;; insert permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
+ (begin
+ ;update permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))
+ (print "Permission has been sucessfully granted to user " guser))))
+
+(define (sauthorize:process-action username action . args)
+ (case (string->symbol action)
+ ((grant)
+ (if (< (length args) 6)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
+ (guser (car args))
+ (restrict (or (args:get-arg "--restrict") ""))
+ (area (or (args:get-arg "--area") ""))
+ (exp-date (or (args:get-arg "--expiration") ""))
+ (access-type (get-access-type remargs)))
+ ; (print "version " guser " restrict " restrict )
+ ; (print "area " area " exp-date " exp-date " access-type " access-type)
+ (cond
+ ((equal? guser "")
+ (print "Username not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "Area not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? exp-date "")
+ (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+ (if (can-grant-perm username access-type area)
+ (begin
+ (print "calling sauthorize:grant ")
+ (sauthorize:grant username guser area exp-date access-type restrict))
+ (begin
+ (print "User " username " does not have permission to grant permissions to area " area "!!")
+ (exit 1)))))
+ ((list-area-user)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to list-area-user ")
+ (exit 1)))
+ (let* ((area (car args)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+
+ (sauthorize:list-areausers area )
+ ))
+ ((read-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
+ ((write-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for Writing!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
+ ((publish)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish <action> <area> [opts] ")
+ (exit 1)))
+
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ ;(print "area " area)
+ ;(print "code: " code-obj)
+ ;(print (exe-exist (cadr code-obj) "publish"))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for writing!!")
+ (exit 1)))
+ ;(print "hear")
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ ; (print *exe-path* "/publish/" (cadr code-obj) action area cmd-args )
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+ ((retrieve)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish <action> <area> [opts] ")
+ (exit 1)))
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+
+
+ ((open)
+ (if (< (length args) 6)
+ (begin
+ (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish")
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
+ (path (car args))
+ (group (or (args:get-arg "--group") ""))
+ (area (or (args:get-arg "--code") ""))
+ (other-grps (or (args:get-arg "--additional-grps") ""))
+ (access-type (get-access-type remargs)))
+
+ (cond
+ ((equal? path "")
+ (print "path not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "--code not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((and (not (equal? access-type "publish"))
+ (not (equal? access-type "retrieve")))
+ (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ ; (print other-grps)
+ (sauthorize:open username path group area access-type other-grps)))
+ ((update)
+ (if (< (length args) 2)
+ (begin
+ (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area))
+ (access-type (get-access-type (cdr args))))
+ (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
+ (begin
+ (print "Access type can be --retrieve|--publish ")
+ (exit 1)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) access-type)))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:update username (cadr code-obj) area access-type )))
+ ((area-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+
+ (if (is-admin username)
+ (begin
+ ; (print usr-obj)
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
+ (begin
+ ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with area-admin access!"))
+ (print "Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" ))))))
+ ((mk-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+ (if (not (sauthorize:valid-unix-user usr))
+ (begin
+ (print "User " usr " is Invalid unix user!!")
+ (exit 1)))
+
+ (if (member username *super-users*)
+ (begin
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with admin access!"))
+ (print "Super-Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" ))))))
+
+ ((register-log)
+ (if (< (length args) 4)
+ (print "Invalid arguments"))
+ ;(print args)
+ (let* ((cmd-line (car args))
+ (user-id (cadr args))
+ (area-id (caddr args))
+ (user-obj (get-user username))
+ (cmd (cadddr args)))
+
+ (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
+ (print "You ar not authorised to run this cmd")
+
+)))
+
+
+ (else (print 0 "Unrecognised command " action))))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (username (current-user-name)))
+ ;; preserve the exe data in the config file
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print sauthorize:help))
+ ((list)
+
+ (sauthorize:db-do (lambda (db)
+ (print "My Area accesses: ")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (car row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse (cdr row) " | "))))))
+ (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
+
+ ((log)
+ (sauthorize:db-do (lambda (db)
+ (print "Logs : ")
+ (query (for-each-row
+ (lambda (row)
+
+ (apply print (intersperse row " | "))))
+ (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
+ (else
+ (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
+ ;; multi-word commands
+ ((null? rema)(print sauthorize:help))
+ ((>= (length rema) 2)
+ (apply sauthorize:process-action username (car rema)(cdr rema)))
+ (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
+
+(main)
+
+
+
DELETED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ /dev/null
@@ -1,651 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-(use defstruct)
-(use scsh-process)
-
-(use srfi-18)
-(use srfi-19)
-(use refdb)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-;(declare (uses common))
-;(declare (uses configf))
-(declare (uses margs))
-
-(include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
-;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
-(include "sauth-paths.scm")
-(include "sauth-common.scm")
-
-;;
-;; GLOBALS
-;;
-(define *verbosity* 1)
-(define *logging* #f)
-(define *exe-name* (pathname-file (car (argv))))
-(define *sretrieve:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
-
- list : list areas $USER's can access
- log : get listing of recent activity.
- sauth list-area-user <area code> : list the users that can access the area.
- sauth open <path> --group <grpname> : Open up an area. User needs to be the owner of the area to open it.
- --code <unique short identifier for an area>
- --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
- sauth update <area code> --retrieve|--publish : update the binaries with the lates changes
- sauth grant <username> --area <area identifier> : Grant permission to read or write to a area that is alrady opend up.
- --expiration yyyy/mm/dd --retrieve|--publish
- [--restrict <comma separated directory names> ]
- sauth read-shell <area identifier> : Open sretrieve shell for reading.
- sauth write-shell <area identifier> : Open spublish shell for writing.
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-;; replace (strftime('%s','now')), with datetime('now'))
-(define (sauthorize:initialize-db db)
- (for-each
- (lambda (qry)
- (exec (sql db qry)))
- (list
- "CREATE TABLE IF NOT EXISTS actions
- (id INTEGER PRIMARY KEY,
- cmd TEXT NOT NULL,
- user_id INTEGER NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
- area_id INTEGER NOT NULL,
- comment TEXT DEFAULT '' NOT NULL,
- action_type TEXT NOT NULL);"
- "CREATE TABLE IF NOT EXISTS users
- (id INTEGER PRIMARY KEY,
- username TEXT NOT NULL,
- is_admin TEXT NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
- );"
- "CREATE TABLE IF NOT EXISTS areas
- (id INTEGER PRIMARY KEY,
- basepath TEXT NOT NULL,
- code TEXT NOT NULL,
- exe_name TEXT NOT NULL,
- required_grps TEXT DEFAULT '' NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
- );"
- "CREATE TABLE IF NOT EXISTS permissions
- (id INTEGER PRIMARY KEY,
- access_type TEXT NOT NULL,
- user_id INTEGER NOT NULL,
- datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
- area_id INTEGER NOT NULL,
- restriction TEXT DEFAULT '' NOT NULL,
- expiration TIMESTAMP DEFAULT NULL);"
- )))
-
-
-
-
-(define (get-access-type args)
- (let loop ((hed (car args))
- (tal (cdr args)))
- (cond
- ((equal? hed "--retrieve")
- "retrieve")
- ((equal? hed "--publish")
- "publish")
- ((equal? hed "--area-admin")
- "area-admin")
- ((equal? hed "--writer-admin")
- "writer-admin")
- ((equal? hed "--read-admin")
- "read-admin")
-
- ((null? tal)
- #f)
- (else
- (loop (car tal)(cdr tal))))))
-
-
-
-;; check if user can gran access to an area
-(define (can-grant-perm username access-type area)
- (let* ((isadmin (is-admin username))
- (is-area-admin (is-user "area-admin" username area ))
- (is-read-admin (is-user "read-admin" username area) )
- (is-writer-admin (is-user "writer-admin" username area) ) )
- (cond
- ((equal? isadmin #t)
- #t)
- ((equal? is-area-admin #t )
- #t)
- ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
- #t)
- ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
- #t)
-
- (else
- #f))))
-
-(define (sauthorize:list-areausers area )
- (sauthorize:db-do (lambda (db)
- (print "Users having access to " area ":")
- (query (for-each-row
- (lambda (row)
- (let* ((exp-date (cadr row)))
- (if (is-access-valid exp-date)
- (apply print (intersperse row " | "))))))
- (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
-
-
-
-
-; check if executable exists
-(define (exe-exist exe access-type)
- (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
- ; (print filepath)
- (if (file-exists? filepath)
- #t
- #f)))
-
-(define (copy-exe access-type exe-name group)
- (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
- (let* ((spath (conc *exe-src* "/s" access-type))
- (dpath (conc *exe-path* "/" access-type "/" exe-name)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd "/bin/cp" (list spath dpath ))
- (if (equal? access-type "publish")
- (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
- (begin
- (if (equal? group "none")
- (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
- (begin
- (run-cmd "/bin/chgrp" (list group dpath))
- (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
- (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
-
-(define (get-exe-name path group)
- (let ((name ""))
- (sauthorize:do-as-calling-user
- (lambda ()
- (if (equal? (current-effective-user-id) (file-owner path))
- (set! name (conc (current-user-name) "_" group))
- (begin
- (print "You cannot open areas that you dont own!!")
- (exit 1)))))
-name))
-
-(define (sauthorize:valid-unix-user username)
- (let* ((ret-val #f))
- (let-values (((inp oup pid)
- (process "/usr/bin/id" (list username))))
- (let loop ((inl (read-line inp)))
- (if (string? inl)
- (if (string-contains inl "No such user")
- (set! ret-val #f)
- (set! ret-val #t)))
- (if (eof-object? inl)
- (begin
- (close-input-port inp)
- (close-output-port oup))
- (loop (read-line inp)))))
- ret-val))
-
-
-;check if a paths/codes are vaid and if area is alrady open
-(define (open-area group path code access-type other-grps)
- (let* ((exe-name (get-exe-name path group))
- (path-obj (get-obj-by-path path))
- (code-obj (get-obj-by-code-no-grp-validation code)))
- ;(print path-obj)
- (cond
- ((not (null? path-obj))
- (if (equal? code (car path-obj))
- (begin
- (if (equal? exe-name (cadr path-obj))
- (begin
- (if (not (exe-exist exe-name access-type))
- (copy-exe access-type exe-name group)
- (begin
- (print "Area already open!!")
- (exit 1))))
- (begin
- (if (not (exe-exist exe-name access-type))
- (copy-exe access-type exe-name group))
- ;; update exe-name in db
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
- )))
- (begin
- (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
- (exit 1))))
-
- ((not (null? code-obj))
- (print "Code " code " is used for diffrent path. Please try diffrent value of --code" )
- (exit 1))
- (else
- ; (print (exe-exist exe-name access-type))
- (if (not (exe-exist exe-name access-type))
- (copy-exe access-type exe-name group))
- (sauthorize:db-do (lambda (db)
- (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ")
- (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
-
-(define (user-has-open-perm user path access)
- (let* ((has-access #f)
- (eid (current-user-id)))
- (cond
- ((is-admin user)
- (set! has-access #t ))
- ((and (is-read-admin user) (equal? access "retrieve"))
- (set! has-access #t ))
- (else
- (print "User " user " does not have permission to open areas")))
- has-access))
-
-
-;;check if user has group access
-(define (is-group-washed req_grpid current-grp-list)
- (let loop ((hed (car current-grp-list))
- (tal (cdr current-grp-list)))
- (cond
- ((equal? hed req_grpid)
- #t)
- ((null? tal)
- #f)
- (else
- (loop (car tal)(cdr tal))))))
-
-;create executables with appropriate suids
-(define (sauthorize:open user path group code access-type other-groups)
- (let* ((gpid (group-information group))
- (req_grpid (if (equal? group "none")
- group
- (if (equal? gpid #f)
- #f
- (caddr gpid))))
- (current-grp-list (get-groups))
- (valid-grp (if (equal? group "none")
- group
- (is-group-washed req_grpid current-grp-list))))
- (if (and (not (equal? group "none")) (equal? valid-grp #f ))
- (begin
- (print "Group " group " is not washed in the current xterm!!")
- (exit 1))))
- (if (not (file-write-access? path))
- (begin
- (print "You can open areas owned by yourself. You do not have permissions to open path." path)
- (exit 1)))
- (if (user-has-open-perm user path access-type)
- (begin
- ;(print "here")
- (open-area group path code access-type other-groups)
- (sauthorize:grant user user code "2017/12/25" "read-admin" "")
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
- (print "Area has " path " been opened for " access-type ))))
-
-(define (sauthorize:update username exe area access-type)
- (let* ((parts (string-split exe "_"))
- (owner (car parts))
- (group (cadr parts))
- (gpid (group-information group))
- (req_grpid (if (equal? group "none")
- group
- (if (equal? gpid #f)
- #f
- (caddr gpid))))
-
- (current-grp-list (get-groups))
- (valid-grp (if (equal? group "none")
- group
- (is-group-washed req_grpid current-grp-list))))
- (if (not (equal? username owner))
- (begin
- (print "You cannot update " area ". Only " owner " can update this area!!")
- (exit 1)))
- (copy-exe access-type exe group)
- (print "recording action..")
- (sauthorize:db-do (lambda (db)
-
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
- (print "Area has " area " been update!!" )))
-
-(define (sauthorize:grant auser guser area exp-date access-type restrict)
- ; check if user exist in db
- (let* ((area-obj (get-area area))
- (auser-obj (get-user auser))
- (user-obj (get-user guser)))
-
- (if (null? user-obj)
- (begin
- ;; is guser a valid unix user
- (if (not (sauthorize:valid-unix-user guser))
- (begin
- (print "User " guser " is Invalid unix user!!")
- (exit 1)))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
- (set! user-obj (get-user guser))))
- (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
- (if(null? perm-obj)
- (begin
- ;; insert permissions
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
- (begin
- ;update permissions
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))
- (print "Permission has been sucessfully granted to user " guser))))
-
-(define (sauthorize:process-action username action . args)
- (case (string->symbol action)
- ((grant)
- (if (< (length args) 6)
- (begin
- (print "ERROR: Missing arguments; " (string-intersperse args ", "))
- (exit 1)))
- (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
- (guser (car args))
- (restrict (or (args:get-arg "--restrict") ""))
- (area (or (args:get-arg "--area") ""))
- (exp-date (or (args:get-arg "--expiration") ""))
- (access-type (get-access-type remargs)))
- ; (print "version " guser " restrict " restrict )
- ; (print "area " area " exp-date " exp-date " access-type " access-type)
- (cond
- ((equal? guser "")
- (print "Username not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? area "")
- (print "Area not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? access-type #f)
- (print "Access type not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? exp-date "")
- (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
- (exit 1)))
- (if (not (area-exists area))
- (begin
- (print "Area does not exisit!!")
- (exit 1)))
- (if (can-grant-perm username access-type area)
- (begin
- (print "calling sauthorize:grant ")
- (sauthorize:grant username guser area exp-date access-type restrict))
- (begin
- (print "User " username " does not have permission to grant permissions to area " area "!!")
- (exit 1)))))
- ((list-area-user)
- (if (not (equal? (length args) 1))
- (begin
- (print "Missing argument area code to list-area-user ")
- (exit 1)))
- (let* ((area (car args)))
- (if (not (area-exists area))
- (begin
- (print "Area does not exisit!!")
- (exit 1)))
-
- (sauthorize:list-areausers area )
- ))
- ((read-shell)
- (if (not (equal? (length args) 1))
- (begin
- (print "Missing argument area code to read-shell ")
- (exit 1)))
- (let* ((area (car args))
- (code-obj (get-obj-by-code area)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "retrieve")))
- (begin
- (print "Area " area " is not open for reading!!")
- (exit 1)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
- ((write-shell)
- (if (not (equal? (length args) 1))
- (begin
- (print "Missing argument area code to read-shell ")
- (exit 1)))
- (let* ((area (car args))
- (code-obj (get-obj-by-code area)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "publish")))
- (begin
- (print "Area " area " is not open for Writing!!")
- (exit 1)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
- ((publish)
- (if (< (length args) 2)
- (begin
- (print "Missing argument to publish. \n publish <action> <area> [opts] ")
- (exit 1)))
-
- (let* ((action (car args))
- (area (cadr args))
- (cmd-args (cddr args))
- (code-obj (get-obj-by-code area)))
- ;(print "area " area)
- ;(print "code: " code-obj)
- ;(print (exe-exist (cadr code-obj) "publish"))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "publish")))
- (begin
- (print "Area " area " is not open for writing!!")
- (exit 1)))
- ;(print "hear")
- (sauthorize:do-as-calling-user
- (lambda ()
- ; (print *exe-path* "/publish/" (cadr code-obj) action area cmd-args )
- (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
-
- ((retrieve)
- (if (< (length args) 2)
- (begin
- (print "Missing argument to publish. \n publish <action> <area> [opts] ")
- (exit 1)))
- (let* ((action (car args))
- (area (cadr args))
- (cmd-args (cddr args))
- (code-obj (get-obj-by-code area)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) "retrieve")))
- (begin
- (print "Area " area " is not open for reading!!")
- (exit 1)))
- ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
- (sauthorize:do-as-calling-user
- (lambda ()
- (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
-
-
-
- ((open)
- (if (< (length args) 6)
- (begin
- (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish")
- (exit 1)))
- (let* ((remargs (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
- (path (car args))
- (group (or (args:get-arg "--group") ""))
- (area (or (args:get-arg "--code") ""))
- (other-grps (or (args:get-arg "--additional-grps") ""))
- (access-type (get-access-type remargs)))
-
- (cond
- ((equal? path "")
- (print "path not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? area "")
- (print "--code not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((equal? access-type #f)
- (print "Access type not found!! Try \"sauthorize help\" for useage ")
- (exit 1))
- ((and (not (equal? access-type "publish"))
- (not (equal? access-type "retrieve")))
- (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
- (exit 1)))
- ; (print other-grps)
- (sauthorize:open username path group area access-type other-grps)))
- ((update)
- (if (< (length args) 2)
- (begin
- (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish")
- (exit 1)))
- (let* ((area (car args))
- (code-obj (get-obj-by-code area))
- (access-type (get-access-type (cdr args))))
- (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
- (begin
- (print "Access type can be --retrieve|--publish ")
- (exit 1)))
- (if (or (null? code-obj)
- (not (exe-exist (cadr code-obj) access-type)))
- (begin
- (print "Area " area " is not open for reading!!")
- (exit 1)))
- (sauthorize:update username (cadr code-obj) area access-type )))
- ((area-admin)
- (let* ((usr (car args))
- (usr-obj (get-user usr))
- (user-id (car (get-user username))))
-
- (if (is-admin username)
- (begin
- ; (print usr-obj)
- (if (null? usr-obj)
- (begin
- (sauthorize:db-do (lambda (db)
- ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
- (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
- (begin
- ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
- (print "User " usr " is updated with area-admin access!"))
- (print "Admin only function"))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" ))))))
- ((mk-admin)
- (let* ((usr (car args))
- (usr-obj (get-user usr))
- (user-id (car (get-user username))))
- (if (not (sauthorize:valid-unix-user usr))
- (begin
- (print "User " usr " is Invalid unix user!!")
- (exit 1)))
-
- (if (member username *super-users*)
- (begin
- (if (null? usr-obj)
- (begin
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
- (begin
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
- (print "User " usr " is updated with admin access!"))
- (print "Super-Admin only function"))
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" ))))))
-
- ((register-log)
- (if (< (length args) 4)
- (print "Invalid arguments"))
- ;(print args)
- (let* ((cmd-line (car args))
- (user-id (cadr args))
- (area-id (caddr args))
- (user-obj (get-user username))
- (cmd (cadddr args)))
-
- (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
- (begin
- (sauthorize:db-do (lambda (db)
- (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
- (print "You ar not authorised to run this cmd")
-
-)))
-
-
- (else (print 0 "Unrecognised command " action))))
-
-(define (main)
- (let* ((args (argv))
- (prog (car args))
- (rema (cdr args))
- (username (current-user-name)))
- ;; preserve the exe data in the config file
- (cond
- ;; one-word commands
- ((eq? (length rema) 1)
- (case (string->symbol (car rema))
- ((help -h -help --h --help)
- (print sauthorize:help))
- ((list)
-
- (sauthorize:db-do (lambda (db)
- (print "My Area accesses: ")
- (query (for-each-row
- (lambda (row)
- (let* ((exp-date (car row)))
- (if (is-access-valid exp-date)
- (apply print (intersperse (cdr row) " | "))))))
- (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
-
- ((log)
- (sauthorize:db-do (lambda (db)
- (print "Logs : ")
- (query (for-each-row
- (lambda (row)
-
- (apply print (intersperse row " | "))))
- (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
- (else
- (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
- ;; multi-word commands
- ((null? rema)(print sauthorize:help))
- ((>= (length rema) 2)
- (apply sauthorize:process-action username (car rema)(cdr rema)))
- (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
-
-(main)
-
-
-
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -35,29 +35,17 @@
;; (declare (uses daemon))
(include "common_records.scm")
(include "db_records.scm")
-(define (server:make-server-url hostport)
+#;(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
;;======================================================================
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
@@ -77,11 +65,11 @@
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Get the transport
-(define (server:get-transport)
+#;(define (server:get-transport)
(if *transport-type*
*transport-type*
(let ((ttype (string->symbol
(or (args:get-arg "-transport")
(configf:lookup *configdat* "server" "transport")
@@ -96,25 +84,10 @@
(lambda ()
(write (list (current-directory)
(current-process-id)
(argv)))))))
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;;
-(define (server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (case (server:get-transport)
- ((rpc) (db:obj->string (vector success/fail query-sig result)))
- ((http) (db:obj->string (vector success/fail query-sig result)))
- ((fs) result)
- (else
- (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
- result)))
-
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
@@ -359,11 +332,11 @@
servr))
(if (and host port)
(conc host ":" port)
#f))))
-(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value.
+#;(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value.
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
(set! *my-client-signature* sig)
*my-client-signature*)))
@@ -439,12 +412,10 @@
(server:kind-run areapath))
(thread-sleep! 5)
(loop (server:check-if-running areapath)
(+ try-num 1)))))))
-(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
-
(define (server:get-num-servers #!key (numservers 2))
(let ((ns (string->number
(or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
(or ns numservers)))
@@ -497,25 +468,17 @@
;; in the same process as the server.
;;
(define (server:ping host-port-in server-id #!key (do-exit #f))
(let ((host:port (if (not host-port-in) ;; use read-dotserver to find
#f ;; (server:check-if-running *toppath*)
- ;; (if (number? host-port-in) ;; we were handed a server-id
- ;; (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
- ;; ;; (print "srec: " srec " host-port-in: " host-port-in)
- ;; (if srec
- ;; (conc (vector-ref srec 3) ":" (vector-ref srec 4))
- ;; (conc "no such server-id " host-port-in)))
- host-port-in))) ;; )
+ host-port-in)))
(let* ((host-port (if host:port
(let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f))
#f)))
-;; (toppath (launch:setup)))
- ;; (print "host-port=" host-port)
(if (not host-port)
(begin
(if host-port-in
(debug:print 0 *default-log-port* "ERROR: bad host:port"))
(if do-exit (exit 1))
@@ -548,19 +511,10 @@
((NOREPLY) #f)
((LOGIN_OK) #t)
(else #f))
(loop (read-line) inl))))))
-;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
-;;
-(define (server:login toppath)
- (lambda (toppath)
- (set! *db-last-access* (current-seconds)) ;; might not be needed.
- (if (equal? *toppath* toppath)
- #t
- #f)))
-
;; timeout is hms string: 1h 5m 3s, default is 1 minute
;;
(define (server:expiration-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
@@ -579,26 +533,10 @@
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
-;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
-;; (define (server:release-sync-lock)
-;; (db:no-sync-del! *no-sync-db* server:sync-lock-token))
-;; (define (server:have-sync-lock?)
-;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
-;; (have-lock? (car have-lock-pair))
-;; (lock-time (cdr have-lock-pair))
-;; (lock-age (- (current-seconds) lock-time)))
-;; (cond
-;; (have-lock? #t)
-;; ((>lock-age
-;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
-;; (server:release-sync-lock)
-;; (server:have-sync-lock?))
-;; (else #f))))
-
;; moving this here as it needs access to db and cannot be in common.
;;
(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
@@ -620,11 +558,11 @@
(calculate-off-time (lambda (work-duration duty-cycle)
(* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
(off-time min-intersync-delay) ;; adjusted in closure below.
(do-a-sync
(lambda ()
- (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
+ ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
(let* ((finalres
(let retry-loop ((num-tries 0))
(if (common:simple-file-lock lockfile)
(begin
(cond
@@ -672,13 +610,10 @@
(debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
(if (file-exists? (conc mtdbfile ".backup"))
(system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
#f))))
(common:simple-file-release-lock lockfile)
- (BB> "released lockfile: " lockfile)
- (when (common:file-exists? lockfile)
- (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
res2) ;; end let
);; end begin
;; else
(cond
(persist-until-sync
@@ -690,11 +625,10 @@
(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
'parallel-sync-in-progress))
) ;; end if got lockfile
)
))
- (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
finalres)
) ;; end lambda
))
do-a-sync))
@@ -791,32 +725,10 @@
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)
(debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
(debug:print-info 2 *default-log-port* "sync called but zero records transferred")))))
-;; ;; TODO: factor this next routine out into a function
-;; (with-input-from-pipe ;; this should not block other threads but need to verify this
-;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*)
-;; (lambda ()
-;; (let loop ((inl (read-line))
-;; (res #f))
-;; (if (eof-object? inl)
-;; (begin
-;; (set! sync-duration (- (current-milliseconds) sync-start))
-;; (cond
-;; ((not res)
-;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
-;; ((> res 0)
-;; (mutex-lock! *heartbeat-mutex*)
-;; (set! *db-last-access* (current-seconds))
-;; (mutex-unlock! *heartbeat-mutex*))))
-;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
-;; (if matches
-;; (string->number (cadr matches))
-;; #f))))
-;; (loop (read-line)
-;; (or num-synced res))))))))))
(if will-sync
(begin
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-sync-in-progress* #f)
(set! *db-last-sync* start-time)
@@ -833,12 +745,10 @@
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
- ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
-
(if (and (not *time-to-exit*)
(< count 6)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
DELETED show-uncalled-procedures.scm
Index: show-uncalled-procedures.scm
==================================================================
--- show-uncalled-procedures.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-;;
-(include "codescanlib.scm")
-
-(define (show-danglers)
- (let* ((all-scm-files (glob "*.scm"))
- (xref (get-xref all-scm-files))
- (dangling-procs
- (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
- (for-each print dangling-procs) ;; our product.
- ))
-
-(show-danglers)
-
-
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -20,26 +20,14 @@
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
(declare (unit subrun))
-;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
-;;(declare (uses items))
-;;(declare (uses runconfig))
-;;(declare (uses tests))
-;;(declare (uses server))
(declare (uses mt))
-;;(declare (uses archive))
-;; (declare (uses filedb))
-
-;(include "common_records.scm")
-;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
-;;(include "run_records.scm")
-;;(include "test_records.scm")
(define (subrun:subrun-test-initialized? test-run-dir)
(if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
(common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
#t
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -179,13 +179,13 @@
;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id vec) (vector-ref vec 0))
(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1))
(define (tasks:hostinfo-get-port vec) (vector-ref vec 2))
-(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
+;; (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4))
-(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
+;; (define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6))
(define (tasks:need-server run-id)
(equal? (configf:lookup *configdat* "server" "required") "yes"))
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -375,11 +375,11 @@
res))
;;
;; Move to steps.scm
;;
-(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
+#;(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
(let ((s (vector-ref x 1)))
DELETED test_records.scm
Index: test_records.scm
==================================================================
--- test_records.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-;; make-vector-record tests testqueue testname testconfig waitons priority items
-(define (make-tests:testqueue)(make-vector 7 #f))
-(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0))
-(define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
-(define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2))
-(define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3))
-;; items: #f=no items, list=list of items remaining, proc=need to call to get items
-(define-inline (tests:testqueue-get-items vec) (vector-ref vec 4))
-(define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
-(define-inline (tests:testqueue-get-item_path vec) (vector-ref vec 6))
-
-(define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
-(define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
-(define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
-(define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
-(define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
-(define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
-(define-inline (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
-
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -21,11 +21,11 @@
;;======================================================================
;; Tests
;;======================================================================
(declare (unit tests))
-(declare (uses lock-queue))
+;; (declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
@@ -40,11 +40,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
(include "js-path.scm")
(define (init-java-script-lib)
(set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
)
DELETED trackback.scm
Index: trackback.scm
==================================================================
--- trackback.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
-
-(include "codescanlib.scm")
-
-;; show call paths for named procedure
-(define (traceback-proc in-procname)
- (letrec* ((all-scm-files (glob "*.scm"))
- (xref (get-xref all-scm-files))
- (have (alist-ref (string->symbol in-procname) xref eq? #f))
- (lookup (lambda (path procname depth)
- (let* ((upcone-temp (filter (lambda (x)
- (eq? procname (car x)))
- xref))
- (upcone-temp2 (cond
- ((null? upcone-temp) '())
- (else (cdar upcone-temp))))
- (upcone (filter
- (lambda (x) (not (eq? x procname)))
- upcone-temp2))
- (uppath (cons procname path))
- (updepth (add1 depth)))
- (if (null? upcone)
- (print uppath)
- (for-each (lambda (x)
- (if (not (member procname path))
- (lookup uppath x updepth) ))
- upcone))))))
- (if have
- (lookup '() (string->symbol in-procname) 0)
- (print "no such func - "in-procname))))
-
-
-(if (eq? 1 (length (command-line-arguments)))
- (traceback-proc (car (command-line-arguments)))
- (print "Usage: trackback <procedure name>"))
-
-(exit 0)
-
ADDED utils/Makefile.utils
Index: utils/Makefile.utils
==================================================================
--- /dev/null
+++ utils/Makefile.utils
@@ -0,0 +1,7 @@
+all : show-uncalled-procedures trackback
+
+show-uncalled-procedures : show-uncalled-procedures.scm codescanlib.scm
+ csc show-uncalled-procedures.scm
+
+trackback : trackback.scm codescanlib.scm
+ csc trackback.scm
ADDED utils/codescanlib.scm
Index: utils/codescanlib.scm
==================================================================
--- /dev/null
+++ utils/codescanlib.scm
@@ -0,0 +1,144 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
+(define (load-scm-file scm-file)
+ ;;(print "load "scm-file)
+ (handle-exceptions
+ exn
+ '()
+ (with-input-from-string
+ (conc "("
+ (with-input-from-file scm-file read-all)
+ ")" )
+ read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;; -- be advised:
+;; * this may be fooled by macros, since this code does not take them into account.
+;; * this code does only checks for form (define (<procname> ... ) <body>)
+;; so it excludes from reckoning
+;; - generated functions, as in things like foo-set! from defstructs,
+;; - define-inline, (
+;; - define procname (lambda ..
+;; - etc...
+(define (get-toplevel-procs+file+args+body filename)
+ (let* ((scm-tree (load-scm-file filename))
+ (procs
+ (filter identity
+ (map
+ (match-lambda
+ [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+ [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+ [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+ [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
+ (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+ (list defname filename args body)
+ #f)]
+ [else #f] ) scm-tree))))
+ procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+ (cond
+ ((null? body) '())
+ ((atom? body) (list body))
+ (else
+ (apply append (map get-atoms-in-body body)))))
+
+;; given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+ (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+ (res
+ (map
+ (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (args (caddr item))
+ (body (cadddr item))
+ (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+ (list proc file atoms)))
+ toplevel-proc-items)))
+ res))
+
+;; uniquify a list of atoms
+(define (unique-atoms lst)
+ (let loop ((lst (flatten lst)) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((c (car lst)))
+ (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+ (let* ((all-procs (map car all-procs+file+calls))
+ (caller-ht (make-hash-table)))
+ ;; let's cross reference with a hash table
+ (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+ (for-each (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (calls (caddr item)))
+ (for-each (lambda (callee)
+ (hash-table-set! caller-ht callee
+ (cons proc
+ (hash-table-ref caller-ht callee))))
+ calls)))
+ all-procs+file+calls)
+ (map (lambda (x)
+ (let ((k (car x))
+ (r (unique-atoms (cdr x))))
+ (cons k r)))
+ (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+ (let* ((all-procs+file+atoms
+ (apply append (map get-procs+file+atoms all-scm-files)))
+ (all-procs (map car all-procs+file+atoms))
+ (all-procs+file+calls ; proc calls things in calls list
+ (map (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (atoms (caddr item))
+ (calls
+ (filter identity
+ (map
+ (lambda (x)
+ (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
+ (member x all-procs))
+ x
+ #f))
+ atoms))))
+ (list proc file calls)))
+ all-procs+file+atoms))
+ (callers (get-callers-alist all-procs+file+calls)))
+ callers))
ADDED utils/show-uncalled-procedures.scm
Index: utils/show-uncalled-procedures.scm
==================================================================
--- /dev/null
+++ utils/show-uncalled-procedures.scm
@@ -0,0 +1,188 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
+
+(define (load-scm-file scm-file)
+ ;;(print "load "scm-file)
+ (handle-exceptions
+ exn
+ '()
+ (with-input-from-string
+ (conc "("
+ (with-input-from-file scm-file read-all)
+ ")" )
+ read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;; -- be advised:
+;; * this may be fooled by macros, since this code does not take them into account.
+;; * this code does only checks for form (define (<procname> ... ) <body>)
+;; so it excludes from reckoning
+;; - generated functions, as in things like foo-set! from defstructs,
+;; - define-inline, (
+;; - define procname (lambda ..
+;; - etc...
+(define (get-toplevel-procs+file+args+body filename)
+ (let* ((scm-tree (load-scm-file filename))
+ (procs
+ (filter identity
+ (map
+ (match-lambda
+ [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+ [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+ [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+ [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
+ (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+ (list defname filename args body)
+ #f)]
+ [else #f] ) scm-tree))))
+ procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+ (cond
+ ((null? body) '())
+ ((atom? body) (list body))
+ (else
+ (apply append (map get-atoms-in-body body)))))
+
+;; given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+ (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+ (res
+ (map
+ (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (args (caddr item))
+ (body (cadddr item))
+ (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+ (list proc file atoms)))
+ toplevel-proc-items)))
+ res))
+
+;; uniquify a list of atoms
+(define (unique-atoms lst)
+ (let loop ((lst (flatten lst)) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((c (car lst)))
+ (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+ (let* ((all-procs (map car all-procs+file+calls))
+ (caller-ht (make-hash-table)))
+ ;; let's cross reference with a hash table
+ (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+ (for-each (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (calls (caddr item)))
+ (for-each (lambda (callee)
+ (hash-table-set! caller-ht callee
+ (cons proc
+ (hash-table-ref caller-ht callee))))
+ calls)))
+ all-procs+file+calls)
+ (map (lambda (x)
+ (let ((k (car x))
+ (r (unique-atoms (cdr x))))
+ (cons k r)))
+ (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+ (let* ((all-procs+file+atoms
+ (apply append (map get-procs+file+atoms all-scm-files)))
+ (all-procs (map car all-procs+file+atoms))
+ (all-procs+file+calls ; proc calls things in calls list
+ (map (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (atoms (caddr item))
+ (calls
+ (filter identity
+ (map
+ (lambda (x)
+ (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
+ (member x all-procs))
+ x
+ #f))
+ atoms))))
+ (list proc file calls)))
+ all-procs+file+atoms))
+ (callers (get-callers-alist all-procs+file+calls)))
+ callers))
+
+(define (get-danglers)
+ (let* ((all-scm-files (glob "*.scm"))
+ (xref (get-xref all-scm-files))
+ (dangling-procs
+ (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
+ dangling-procs))
+
+(define (read-ignore-file fname)
+ (let ((ht (make-hash-table)))
+ (if (file-exists? fname)
+ (for-each
+ (lambda (x)
+ (hash-table-set! ht x #t))
+ (with-input-from-file fname
+ read-lines)))
+ ht))
+
+(define (show-danglers)
+ (let ((ignores (read-ignore-file "danglers-to-ignore.txt"))
+ (danglers (map get-stats (get-danglers))))
+ ;; (print "ignores: " (hash-table->alist ignores))
+ (for-each (lambda (dangler)
+ (let* ((fnname (conc (cadr dangler))))
+ ;; (print "fnname="fnname" member: "(member fnname ignore-list))
+ (if (not (hash-table-exists? ignores fnname))
+ (apply print (intersperse dangler "\t"))
+ #;(print "skipping "fnname))))
+ (sort danglers (lambda (a b)(< (car a)(car b)))))))
+
+ ;; (for-each print dangling-procs) ;; our product.
+
+(define (get-stats fn)
+ (let* ((data (with-input-from-pipe (conc "grep '"fn"' *.scm") read-lines))
+ (files (delete-duplicates
+ (map (lambda (entry)
+ (car (string-split entry ":")))
+ data))))
+ (list (length data) fn files)))
+
+(show-danglers)
+
+
ADDED utils/trackback.scm
Index: utils/trackback.scm
==================================================================
--- /dev/null
+++ utils/trackback.scm
@@ -0,0 +1,53 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
+
+(include "codescanlib.scm")
+
+;; show call paths for named procedure
+(define (traceback-proc in-procname)
+ (letrec* ((all-scm-files (glob "*.scm"))
+ (xref (get-xref all-scm-files))
+ (have (alist-ref (string->symbol in-procname) xref eq? #f))
+ (lookup (lambda (path procname depth)
+ (let* ((upcone-temp (filter (lambda (x)
+ (eq? procname (car x)))
+ xref))
+ (upcone-temp2 (cond
+ ((null? upcone-temp) '())
+ (else (cdar upcone-temp))))
+ (upcone (filter
+ (lambda (x) (not (eq? x procname)))
+ upcone-temp2))
+ (uppath (cons procname path))
+ (updepth (add1 depth)))
+ (if (null? upcone)
+ (print uppath)
+ (for-each (lambda (x)
+ (if (not (member procname path))
+ (lookup uppath x updepth) ))
+ upcone))))))
+ (if have
+ (lookup '() (string->symbol in-procname) 0)
+ (print "no such func - "in-procname))))
+
+
+(if (eq? 1 (length (command-line-arguments)))
+ (traceback-proc (car (command-line-arguments)))
+ (print "Usage: trackback <procedure name>"))
+
+(exit 0)
+