Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -38,11 +38,12 @@ ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm @@ -49,11 +50,11 @@ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -mtut: $(OFILES) mtut.scm +mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut TCMTOBJS = \ api.o \ archive.o \ @@ -94,10 +95,14 @@ $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html mkdir -p $(PREFIX)/share/docs $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done +js : java-script-lib/jquery-3.1.0.slim.min.js + mkdir -p $(PREFIX)/share/js + cp java-script-lib/jquery-3.1.0.slim.min.js $(PREFIX)/share/js/jquery-3.1.0.slim.min.js + $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql #multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) @@ -145,10 +150,13 @@ chmod a+x $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut +install-mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/mtut + $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil $(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt @@ -233,12 +241,15 @@ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ - $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt + $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + js +# $(PREFIX)/bin/.$(ARCHSTR)/ndboard # $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) @@ -315,15 +326,23 @@ datashare-testing/spublish : spublish.scm $(OFILES) csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + sretrieve/sretrieve : datashare-testing/sretrieve csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ - srfi-1 posix regex regex-case srfi-69 + srfi-1 posix regex regex-case srfi-69 # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -39,19 +39,23 @@ get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status get-run-stats + get-run-times get-targets get-target ;; register-run get-tests-tags + get-test-times get-tests-for-run get-test-id get-tests-for-runs-mindata + get-tests-for-run-mindata get-run-name-from-id get-runs + simple-get-runs get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt @@ -214,10 +218,11 @@ ;; NO SYNC DB ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) @@ -254,36 +259,42 @@ ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((synchash-get) (apply synchash:server-get dbstruct params)) ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + ((get-test-times) (apply db:get-test-times dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) + ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) + ((get-run-times) (apply db:get-run-times dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ((read-test-data*) (apply db:read-test-data* dbstruct params)) + ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -90,48 +90,128 @@ (print-call-chain) (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn)) #f) (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec)) (pgdb:get-ttype dbh target-spec))))) + +;;====================================================================== +;; T A G S +;;====================================================================== + + +(define (pgdb:get-tag-info-by-name dbh tag) + (dbi:get-one-row dbh "SELECT id,tag_name FROM tags where tag_name=?;" tag)) + +(define (pgdb:insert-tag dbh name ) + (dbi:exec dbh "INSERT INTO tags (tag_name) VALUES (?)" name )) + +(define (pgdb:insert-area-tag dbh tag-id area-id ) + (dbi:exec dbh "INSERT INTO area_tags (tag_id, area_id) VALUES (?,?)" tag-id area-id )) + +(define (pgdb:is-area-taged dbh area-id) + (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=?;" area-id))) + (if area-tag-id + #t + #f))) + +(define (pgdb:is-area-taged-with-a-tag dbh tag-id area-id) + (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=? and tag_id=?;" area-id tag-id))) + (if area-tag-id + #t + #f))) + ;;====================================================================== ;; R U N S ;;====================================================================== ;; given a target spec id, target and run-name return the run-id ;; if no run found return #f ;; -(define (pgdb:get-run-id dbh spec-id target run-name) - (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;" - spec-id target run-name)) +(define (pgdb:get-run-id dbh spec-id target run-name area-id) + (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=? and area_id=?;" + spec-id target run-name area-id)) ;; given a run-id return all the run info ;; -(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not? +(define (pgdb:get-run-info dbh run-id ) ;; to join ttype or not? (dbi:get-one-row dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id - FROM runs WHERE id=?;" run-id)) + FROM runs WHERE id=? ;" run-id )) ;; refresh the data in a run record ;; -(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count) ;; area-id) +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id) ;; area-id) (dbi:exec dbh "UPDATE runs SET - state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? - WHERE id=?;" - state status owner event-time comment fail-count pass-count run-id)) + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? + WHERE id=? and area_id=?;" + state status owner event-time comment fail-count pass-count run-id area-id)) ;; given all needed info create run record ;; -(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count) +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id) + (dbi:exec + dbh + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id ) + VALUES (?,?,?,?,?,?,?,?,?,?,?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id)) + +;;====================================================================== +;; T E S T - S T E P S +;;====================================================================== + +(define (pgdb:get-test-step-id dbh test-id stepname state) + (dbi:get-one + dbh + "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;" + test-id stepname state)) + +(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile) + (dbi:exec + dbh + "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment) + VALUES (?,?,?,?,?,?,?);" + test-id stepname state status event_time logfile comment)) + +(define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile) + (dbi:exec + dbh + "UPDATE test_steps SET + test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=? + WHERE id=?;" + test-id stepname state status event_time logfile comment step-id)) + + +;;====================================================================== +;; T E S T - D A T A +;;====================================================================== + +(define (pgdb:get-test-data-id dbh test-id category variable) + (dbi:get-one + dbh + "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;" + test-id category variable)) + +(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type) + (dbi:exec + dbh + "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) + VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units comment status type)) + +(define (pgdb:update-test-data dbh data-id test-id category variable value expected tol units comment status type) (dbi:exec - dbh - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count) - VALUES (?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count)) + dbh + "UPDATE test_data SET + test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=? + WHERE id=?;" + test-id category variable value expected tol units comment status type data-id )) + + ;;====================================================================== ;; T E S T S ;;====================================================================== ADDED codescanlib.scm Index: codescanlib.scm ================================================================== --- /dev/null +++ codescanlib.scm @@ -0,0 +1,127 @@ + +;; 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 ( ) ) +(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 ( ... ) ) +;; 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 ) ) + (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 @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack +(use srfi-1 data-structures posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable pkts (prefix dbi dbi:) regex) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) @@ -28,10 +28,27 @@ ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) + +;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . +;; arguments - thunk, message +(define (common:fail-safe thunk warning-message-on-exception) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception) + (debug:print-info 0 *default-log-port* + (string-substitute "\n?Error:" "nonfatal condition:" + (with-output-to-string + (lambda () + (print-error-message exn) )))) + (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...") + #f) + (thunk))) + (define getenv get-environment-variable) (define (safe-setenv key val) (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") (if (and (string? val) @@ -42,10 +59,20 @@ (setenv key val)) (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) (define home (getenv "HOME")) (define user (getenv "USER")) + + +;; returns list of fd count, socket count +(define (get-file-descriptor-count #!key (pid (current-process-id ))) + (list + (length (glob (conc "/proc/" pid "/fd/*"))) + (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) + ) +) + ;; GLOBALS ;; CONTEXTS (defstruct cxt @@ -88,10 +115,11 @@ (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog +(define *default-area-tag* "local") ;; DATABASE (define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > @@ -118,11 +146,11 @@ (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) -;; (define *server-id* #f) +(define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) @@ -159,11 +187,11 @@ (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive (conndat #f) (transport *transport-type*) - (server-timeout (server:get-timeout)) ;; default from server:get-timeout + (server-timeout (server:expiration-timeout)) (force-server #f) (ro-mode #f) (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode ;; launching and hosts @@ -254,13 +282,14 @@ ;; 'new2old 'killservers 'adj-target ;; 'old2new 'new2old - (if full + ;; (if full '(dejunk) - '())) + ;; '()) + ) (if (common:api-changed?) (common:set-last-run-version))) ;; Rotate logs, logic: ;; if > 500k and older than 1 week: @@ -479,11 +508,12 @@ ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls (define *common:std-states* ;; for toggle buttons in dashboard - '((0 "ARCHIVED") + '( + (0 "ARCHIVED") (1 "STUCK") (2 "KILLREQ") (3 "KILLED") (4 "NOT_STARTED") (5 "COMPLETED") @@ -500,18 +530,24 @@ (3 "SKIP") (4 "WARN") (5 "WAIVED") (6 "CHECK") (7 "STUCK/DEAD") - (8 "FAIL") - (9 "ABORT"))) + (8 "DEAD") + (9 "FAIL") + (10 "PREQ_FAIL") + (11 "PREQ_DISCARDED") + (12 "ABORT"))) (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed - '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE")) + '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" )) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD")) + +(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed + '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")) ;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items (define *common:running-states* ;; test is either running or can be run '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED")) @@ -830,12 +866,14 @@ (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions - exn - #f + exn + (begin + (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") + #f) (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) @@ -1484,35 +1522,39 @@ (set! best-load load) (set! best-host hostname))))) hosts) best-host)) -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) +(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) + (numcpus (if (< 1 numcpus-in) ;; not possible + (common:get-num-cpus remote-host) + numcpus-in)) + (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME? (first (car loadavg)) (next (cadr loadavg)) - (adjload (* maxload numcpus)) + (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 (loadjmp (- first next))) (cond ((and (> first adjload) (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg "")) + (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg "")) (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) ((and (> loadjmp numcpus) (> count 0)) (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))))) (define (common:wait-for-homehost-load maxload msg) (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. #f (common:get-homehost))) (hh (if hh-dat (car hh-dat) #f)) (numcpus (common:get-num-cpus hh))) - (common:wait-for-normalized-load maxload msg: msg remote-host: hh))) + (common:wait-for-normalized-load maxload msg hh))) (define (common:get-num-cpus remote-host) (let ((proc (lambda () (let loop ((numcpu 0) (inl (read-line))) @@ -1528,11 +1570,11 @@ proc) (with-input-from-file "/proc/cpuinfo" proc)))) ;; wait for normalized cpu load to drop below maxload ;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) +(define (common:wait-for-normalized-load maxload msg remote-host) (let ((num-cpus (common:get-num-cpus remote-host))) (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) @@ -1712,10 +1754,12 @@ key "=" delim (mungeval val) delim))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) +;; a value of #f means "unset this var" +;; (define (alist->env-vars lst) (if (list? lst) (let ((res '())) (for-each (lambda (p) (let* ((var (car p)) @@ -1770,14 +1814,14 @@ ;; T I M E A N D D A T E ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) - (let ((parts (string-split tstr)) + (let ((parts (string-split-fields "\\w+" tstr)) (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days - (trx (regexp "(\\d+)([smhd])"))) + ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks + (trx (regexp "(\\d+)([smhdMyw])"))) (for-each (lambda (part) (let ((match (string-match trx part))) (if match (let ((val (string->number (cadr match))) (unt (caddr match))) @@ -1784,12 +1828,15 @@ (if val (set! time-secs (+ time-secs (* val (case (string->symbol unt) ((s) 1) ((m) 60) - ((h) (* 60 60)) - ((d) (* 24 60 60)) + ((h) 3600) + ((d) 86400) + ((2) 604800) + ((M) 2628000) ;; aproximately one month + ((y) 31536000) (else 0)))))))))) parts) time-secs)) (define (seconds->hr-min-sec secs) @@ -2073,11 +2120,17 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) -(define (common:faux-lock keyname #!key (wait-time 8)) +;;====================================================================== +;; L O C K I N G M E C H A N I S M S +;;====================================================================== + +;; faux-lock is deprecated. Please use simple-lock below +;; +(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count (if (> wait-time 0) (begin (thread-sleep! 1) (if (eq? wait-time 1) ;; only one second left, steal the lock @@ -2095,11 +2148,19 @@ (begin (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) - +;; simple lock. improve and converge on this one. +;; +(define (common:simple-lock keyname) + (rmt:no-sync-get-lock keyname)) + +;;====================================================================== +;; +;;====================================================================== + (define (common:in-running-test?) (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) (define (common:get-color-from-status status) (cond @@ -2391,5 +2452,43 @@ (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target +;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) +;; execute thunk in context of environment modified as per this list +;; restore env to prior state then return value of eval'd thunk. +;; ** this is not thread safe ** +(define (common:with-env-vars delta-env-alist-or-hash-table thunk) + (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) + (hash-table->alist delta-env-alist-or-hash-table) + delta-env-alist-or-hash-table)) + (restore-thunks + (filter + identity + (map (lambda (env-pair) + (let* ((env-var (car env-pair)) + (new-val (cadr env-pair)) + (current-val (get-environment-variable env-var)) + (restore-thunk + (cond + ((not current-val) (lambda () (unsetenv env-var))) + ((not (string? new-val)) #f) + ((eq? current-val new-val) #f) + (else + (lambda () (setenv env-var current-val)))))) + ;;(when (not (string? new-val)) + ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) + ;; (pp delta-env-alist) + ;; (exit 1)) + + + (cond + ((not new-val) ;; modify env here + (unsetenv env-var)) + ((string? new-val) + (setenv env-var new-val))) + restore-thunk)) + delta-env-alist)))) + (let ((rv (thunk))) + (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state + rv))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -147,15 +147,17 @@ (temp (string-split (->string this-loc) " ")) (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) - (let ((dp-args - (append - (list 0 *default-log-port* - (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) - in-args))) + (let* ((color-on "\x1b[1m") + (color-off "\x1b[0m") + (dp-args + (append + (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)) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -77,10 +77,14 @@ (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) + +(define (configf:system ht cmd) + (system cmd) + ) (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) @@ -92,11 +96,11 @@ (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym ((scheme scm) (conc "(lambda (ht)" cmd ")")) - ((system) (conc "(lambda (ht)(system \"" cmd "\"))")) + ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) ((mtrah) (conc "(lambda (ht)" " (let ((extra \"" cmd "\"))" @@ -176,11 +180,27 @@ (configf:process-line inl ht allow-processing))))) (if (and (string? res) (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) (string-substitute "\\s+$" "" res) res)))))) - + +(define (configf:cfgdat->env-alist section cfgdat-ht allow-system) + (filter + (lambda (pair) + (let* ((var (car pair)) + (val (cdr pair))) + (cons var + (cond + ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic + (val)) + ((procedure? val) #f) + ((string? val) val) + (else "#f"))))) + (append + (hash-table-ref/default cfgdat-ht "default" '()) + (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) + (define (calc-allow-system allow-system section sections) (if sections (and (or (equal? "default" section) (member section sections)) allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings @@ -217,19 +237,24 @@ ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) +;; allow-system: +;; #f - do not evaluate [system +;; #t - immediately evaluate [system and store result as string +;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time +;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; -(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) +(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)) + (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") @@ -272,138 +297,174 @@ (lambda (section) (if (not (member section sections)) (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht (hash-table-keys res))) (debug:print 9 *default-log-port* "END: " path) - res) + res + ) ;; retval (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (configf:settings ( x setting val ) (begin - (hash-table-set! settings setting val) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) - (full-conf (if (absolute-pathname? include-file) - include-file - (common:nice-path - (conc (if curr-conf-dir - curr-conf-dir - ".") - "/" include-file))))) - (if (common:file-exists? full-conf) - (begin - ;; (push-directory conf-dir) - (debug:print 9 *default-log-port* "Including: " full-conf) - (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - ;; (pop-directory) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 *default-log-port* " " full-conf) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + (configf:settings ( x setting val ) + (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))) + + (configf:include-rx ( x include-file ) + (let* ((curr-conf-dir (pathname-directory path)) + (full-conf (if (absolute-pathname? include-file) + include-file + (common:nice-path + (conc (if curr-conf-dir + curr-conf-dir + ".") + "/" include-file))))) + (if (common:file-exists? full-conf) + (begin + ;; (push-directory conf-dir) + (debug:print 9 *default-log-port* "Including: " full-conf) + (read-config full-conf res allow-system environ-patt: environ-patt + curr-section: curr-section-name sections: sections settings: settings + keep-filenames: keep-filenames) + ;; (pop-directory) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " full-conf) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))))) (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (common:file-exists? include-script)(file-execute-access? include-script)) - (let* ((new-inp-port (open-input-pipe (conc include-script " " params)))) - (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) - ;; (print "We got here, calling read-config next. Port is: " new-inp-port) - (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - (close-input-port new-inp-port) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - ) ;; ) - (configf:section-rx ( x section-name ) (begin - ;; call post-section-procs - (for-each - (lambda (dat) - (let ((patt (car dat)) - (proc (cdr dat))) - (if (string-match patt curr-section-name) - (proc curr-section-name section-name res path)))) - post-section-procs) - ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards - ;; NOTE: we are processing the curr-section-name, NOT section-name. - (process-wildcards res curr-section-name) - (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - ;; if we have the sections list then force all settings into "" and delete it later? - ;; (if (or (not sections) - ;; (member section-name sections)) - ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. - section-name - #f #f))) - (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections) - (let ((alist (hash-table-ref/default res curr-section-name '())) - (val-proc (lambda () - (let* ((start-time (current-seconds)) - (cmdres (process:cmd-run->list cmd)) - (delta (- (current-seconds) start-time)) - (status (cadr cmdres)) - (res (car cmdres))) - (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) - (if (not (eq? status 0)) - (begin - (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status - " output: " cmdres))) - (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) - (if (null? res) - "" - (string-intersperse res " ")))))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist - key - (case (calc-allow-system allow-system curr-section-name sections) - ((return-procs) val-proc) - ((return-string) cmd) - (else (val-proc))) - metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") - (safe-setenv key fval) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key fval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) - (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (config:eval-string-in-environment val) - val))) - (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar (safe-setenv key realval)) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) + (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (new-inp-port + (common:with-env-vars + env-delta + (lambda () + (open-input-pipe (conc include-script " " params)))))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) + (configf:section-rx ( x section-name ) + (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + ;; if we have the sections list then force all settings into "" and delete it later? + ;; (if (or (not sections) + ;; (member section-name sections)) + ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. + section-name + #f #f))) + (configf:key-sys-pr ( x key cmd ) + (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((start-time (current-seconds)) + (local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist + key + (case (calc-allow-system allow-system curr-section-name sections) + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name #f #f))) + + (configf:key-no-val ( x key val) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name key #f))) + + (configf:key-val-pr ( x key unk1 val unk2 ) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name key #f))) ;; if a continued line - (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) - (if var-flag ;; if set to a string then we have a continued var - (let ((newval (conc - (config-lookup res curr-section-name var-flag) "\n" - ;; trim lead from the incoming whsp to support some indenting. - (if lead - (string-substitute (regexp lead) "" whsp) - "") - val))) - ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist var-flag newval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (configf:cont-ln-rx ( x whsp val ) + (let ((alist (hash-table-ref/default res curr-section-name '()))) + (if var-flag ;; if set to a string then we have a continued var + (let ((newval (conc + (config-lookup res curr-section-name var-flag) "\n" + ;; trim lead from the incoming whsp to support some indenting. + (if lead + (string-substitute (regexp lead) "" whsp) + "") + val))) + ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + ) ;; end loop + ))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) @@ -464,10 +525,18 @@ '() (map car sectdat)))) (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) + +(define (configf:set-section-var cfgdat section var val) + (let ((sectdat (configf:get-section cfgdat section))) + (hash-table-set! cfgdat section + (config:assoc-safe-add sectdat var val)))) + + ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) + ;; (list var val)))) (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -40,16 +40,26 @@ ;;====================================================================== (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override "viewscreen "))) ;; "xterm -geometry 180x20 -e \""))) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + (define (dtests:get-post-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override " &"))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" @@ -469,12 +479,12 @@ (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) - (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t)))) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) (viewlog (lambda (x) (if (common:file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dcommon:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) @@ -616,15 +626,16 @@ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) - (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) - ";megatest -target " keystring " -runname " runname + ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -47,11 +47,11 @@ (include "vg_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2016 + license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check @@ -349,11 +349,11 @@ (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) + (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) ;; RADT => Matrix defstruct addition @@ -577,12 +577,11 @@ (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) - (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run - run-id testnamepatt states statuses ;; run-id testpatt states statuses + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order @@ -652,17 +651,15 @@ ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys)) + (keys (rmt:get-keys)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f last-runs-update));;'("id" "runname") + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -735,15 +732,13 @@ ;; (define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -802,11 +797,19 @@ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin - (if (> elapsed-time 2)(print "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")) + (when (> elapsed-time 2) + (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val)) + + + ) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) @@ -1011,11 +1014,11 @@ (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) - (if x x ""))))) + (if (string? x) x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values ;; (let ((rown 0) @@ -1631,35 +1634,35 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-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 (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)) @@ -1675,16 +1678,17 @@ (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (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 runs-header key)) + (key-vals (map (lambda (key) + (let ((val (db:get-value-by-header run-record runs-header key))) + (if (string? val) val ""))) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) @@ -1709,16 +1713,20 @@ (hash-table-values tests-ht) (lambda (a b) (let ((a-test-name (db:test-get-testname a)) (a-item-path (db:test-get-item-path a)) (b-test-name (db:test-get-testname b)) - (b-item-path (db:test-get-item-path b))) - (cond - ((< 0 (string-compare3 a-test-name b-test-name)) #t) - ((> 0 (string-compare3 a-test-name b-test-name)) #f) - ((< 0 (string-compare3 a-item-path b-item-path)) #t) - (else #f))))))) + (b-item-path (db:test-get-item-path b)) + (a-event-time (db:test-get-event_time a)) + (b-event-time (db:test-get-event_time b))) + (if (not (equal? a-test-name b-test-name)) + (> a-event-time b-event-time) + (cond + ((< 0 (string-compare3 a-test-name b-test-name)) #t) + ((> 0 (string-compare3 a-test-name b-test-name)) #f) + ((< 0 (string-compare3 a-item-path b-item-path)) #t) + (else #f)))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (rmt:get-key-vals run-id)) @@ -1747,12 +1755,11 @@ (define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1764,13 +1771,11 @@ (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) (dashboard:do-update-rundat tabdat) ;; ) (dboard:runs-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query (dboard:tabdat-access-mode tabdat) - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (dashboard:get-runs-hash tabdat)) ;; (runs-hash (let ((ht (make-hash-table))) @@ -2219,10 +2224,20 @@ (iup:hbox (iup:button "Quit" #:action (lambda (obj) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) + (dboard:tabdat-last-data-update-set! tabdat 0) + (dboard:tabdat-last-runs-update-set! tabdat 0) + (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) + (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) + (dboard:tabdat-done-runs-set! tabdat '()) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:commondat-please-update-set! commondat #t) (mark-for-update tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () @@ -2437,11 +2452,11 @@ ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) (iup:menu-item "Run" (iup:menu @@ -2479,11 +2494,20 @@ (lambda (obj) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt % " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))))) + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) (iup:menu-item "Test" (iup:menu (iup:menu-item (conc "Rerun " item-test-path) @@ -2502,10 +2526,19 @@ (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) (iup:menu-item (conc "Clean "item-test-path) #:action (lambda (obj) (common:run-a-command @@ -2958,13 +2991,11 @@ ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) Index: datashare-testing/.sretrieve.config ================================================================== --- datashare-testing/.sretrieve.config +++ datashare-testing/.sretrieve.config @@ -1,8 +1,8 @@ [settings] base-dir /tmp/delme_data -allowed-users matt +allowed-users matt allowed-chars [0-9a-zA-Z\-\.]+ allowed-sub-paths [0-9a-zA-Z\-\.]+ [database] location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,6 +1,6 @@ -;;====================================================================== +;====================================================================== ;; Copyright 2006-2016, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; @@ -198,21 +198,21 @@ ;; open an sql database inside a file lock ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; -;;(define *db-open-mutex* (make-mutex)) +;; (define *db-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) (file-exists (common:file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) - ;;(mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) (readyfname (conc parent-dir "/.ready-" raw-fname)) (readyexists (common:file-exists? readyfname))) @@ -221,10 +221,11 @@ (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists) (begin + (if (and (configf:lookup *configdat* "setup" "use-wal") (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp (sqlite3:execute db "PRAGMA journal_mode=WAL;") (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) (initproc db))) @@ -246,11 +247,11 @@ (condition-case (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (let ((db (sqlite3:open-database fname))) - ;;(mutex-unlock! *db-open-mutex*) + ;; (mutex-unlock! *db-open-mutex*) db)) (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) @@ -334,11 +335,11 @@ (if (and (or (not dbfexists) (and modtimedelta (> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back do-sync) (begin - (debug:print 4 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) + (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") ) (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically @@ -479,20 +480,22 @@ '("run_duration" #f) '("comment" #f) '("event_time" #f) '("fail_count" #f) '("pass_count" #f) - '("archived" #f)) + '("archived" #f) + '("last_update" #f)) (list "test_steps" '("id" #f) '("test_id" #f) '("stepname" #f) '("state" #f) '("status" #f) '("event_time" #f) '("comment" #f) - '("logfile" #f)) + '("logfile" #f) + '("last_update" #f)) (list "test_data" '("id" #f) '("test_id" #f) '("category" #f) '("variable" #f) @@ -500,11 +503,12 @@ '("expected" #f) '("tol" #f) '("units" #f) '("comment" #f) '("status" #f) - '("type" #f)))) + '("type" #f) + '("last_update" #f)))) ;; needs db to get keys, this is for syncing all tables ;; (define (db:sync-main-list dbstruct) (let ((keys (db:get-keys dbstruct))) @@ -516,11 +520,11 @@ (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")))) + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -858,11 +862,19 @@ (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; - END;")) + END;") + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);")) (define (db:adj-target db) (let ((fields (configf:get-section *configdat* "fields")) (field-num 0)) ;; because we will be refreshing the keys table it is best to clear it here @@ -1034,26 +1046,40 @@ data-synced)) (define (db:tmp->megatest.db-sync dbstruct last-update) (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct))) - (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) + (refndb (dbr:dbstruct-refndb dbstruct)) + (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) + res)) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps +;; +;; NB// no-sync-db is the db handle, not a flag! +;; (define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) (let* ((start-time (current-seconds)) - (last-update (if no-sync-db - (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) - 0)) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) + (last-full-update (if no-sync-db + (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0) + 0)) + (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync + (last-update (if full-sync-needed + 0 + (if no-sync-db + (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) + 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) (sync-needed (> (- start-time last-update) 6)) - (res (if sync-needed ;; don't sync if a sync already occurred in the past 6 seconds + (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds + full-sync-needed) (begin (if no-sync-db - (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)) + (begin + (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time)) + (db:no-sync-set no-sync-db "LAST_UPDATE" start-time))) (db:tmp->megatest.db-sync dbstruct last-update)) 0)) (sync-time (- (current-seconds) start-time))) (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (if (common:low-noise-print 30 "sync new to old") @@ -1354,10 +1380,11 @@ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; @@ -1410,11 +1437,13 @@ res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) - (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) + (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; (define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) @@ -1553,17 +1582,17 @@ ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in -;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); +;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (db:with-db @@ -1622,11 +1651,12 @@ (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (for-each (lambda (test-id) - (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 + (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828 + all-ids)))))))) ;; ALL REPLACED BY THE BLOCK ABOVE ;; ;; (sqlite3:execute @@ -1678,10 +1708,14 @@ "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" + ;; remove orphaned test_rundat entries + "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);" + ;; + "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);" )))) ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () @@ -1837,26 +1871,33 @@ ;;====================================================================== (define (db:open-no-sync-db) (let* ((dbpath (db:dbfile-path)) (dbname (conc dbpath "/no-sync.db")) + (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") + (if (not db-exists) + (begin + (sqlite3:execute db "PRAGMA synchronous = 0;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") + (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) db)) ;; if we are not a server create a db handle. this is not finalized ;; so watch for problems. I'm still not clear if it is needed to manually ;; finalize sqlite3 dbs with the sqlite3 egg. ;; (define (db:no-sync-db db-in) - (if db-in - db-in - (let ((db (db:open-no-sync-db))) - (set! *no-sync-db* db) - db))) + (mutex-lock! *db-access-mutex*) + (let ((res (if db-in + db-in + (let ((db (db:open-no-sync-db))) + (set! *no-sync-db* db) + db)))) + (mutex-unlock! *db-access-mutex*) + res)) (define (db:no-sync-set db var val) (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) (define (db:no-sync-del! db var) @@ -1879,10 +1920,30 @@ res)) res))) (define (db:no-sync-close-db db) (db:safely-close-sqlite3-db db)) + +;; transaction protected lock aquisition +;; either: +;; fails returns (#f . lock-creation-time) +;; succeeds (returns (#t . lock-creation-time) +;; use (db:no-sync-del! db keyname) to release the lock +;; +(define (db:no-sync-get-lock db-in keyname) + (let ((db (db:no-sync-db db-in))) + (sqlite3:with-transaction + db + (lambda () + (handle-exceptions + exn + (let ((lock-time (current-seconds))) + (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)) + `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))) + + ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change @@ -1924,10 +1985,34 @@ (define (db:get-rows vec)(vector-ref vec 1)) ;;====================================================================== ;; R U N S ;;====================================================================== + + + + + +(define (db:get-run-times dbstruct run-patt target-patt) +(let ((res `()) + (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) +;(print qry) +(db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (runname runtime target ) + (set! res (cons (vector runname runtime target) res))) + db + qry + run-patt target-patt) + + res)))) + + (define (db:get-run-name-from-id dbstruct run-id) (db:with-db dbstruct #f ;; this is for the main runs db @@ -2054,10 +2139,48 @@ qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) + +(define-record simple-run target id runname state status owner event_time) +(define-record-printer (simple-run x out) + (fprintf out "#,(simple-run ~S ~S ~S ~S)" + (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) + +;; simple get-runs +;; +(define (db:simple-get-runs dbstruct runpatt count offset target) + (let* ((res '()) + (keys (db:get-keys dbstruct)) + (runpattstr (db:patt->like "runname" runpatt)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (targstr (string-intersperse keys "||'/'||")) + (keystr (conc targstr " AS target," + (string-intersperse remfields ","))) + (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " + ;; Generate: " AND x LIKE 'keypatt' ..." + " AND target LIKE '" target "'" + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) + (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (target id runname state status owner event_time) + (set! res (cons (make-simple-run target id runname state status owner event_time) res))) + db + qrystr + ))) + (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + res)) + ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) @@ -2321,18 +2444,19 @@ (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "area_id")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db - (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") + (conc "SELECT " keystr " FROM runs WHERE id=?;") run-id))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) @@ -2413,11 +2537,11 @@ (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons (list key key-val) res))) + (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db db qry run-id))) keys))) (reverse res))) ;; get key vals for a given run-id @@ -2431,11 +2555,11 @@ (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons key-val res))) + (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db db qry run-id))) keys))) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) @@ -3013,10 +3137,44 @@ (db:first-result-default db "SELECT rundir FROM tests WHERE id=?;" #f ;; default result test-id)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (test-name item-path test-time target ) + (set! res (cons (vector test-name item-path test-time) res))) + db + qry + run-name target) + res)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (test-name item-path test-time target ) + (set! res (cons (vector test-name item-path test-time) res))) + db + qry + run-name target) + res)))) ;;====================================================================== ;; S T E P S ;;====================================================================== @@ -3046,10 +3204,25 @@ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) + + (define (db:get-steps-info-by-id dbstruct test-step-id) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((res (vector #f #f #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile comment) + (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-step-id) + res)))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id @@ -3065,10 +3238,26 @@ (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== + + (define (db:get-data-info-by-id dbstruct test-data-id) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id test-id category variable value expected tol units comment status type ) + (set! res (vector id test-id category variable value expected tol units comment status type))) + db + "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-data-id) + res)))) + ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. @@ -3406,11 +3595,11 @@ db (lambda () ;; NB// Pass the db so it is part fo the transaction (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item - (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test + (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test (running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) (bad-not-started (length (filter (lambda (x) (and (equal? (dbr:counts-state x) "NOT_STARTED") @@ -3419,66 +3608,120 @@ state-status-counts))) ;; (non-completes (filter (lambda (x) ;; (not (equal? (dbr:counts-state x) "COMPLETED"))) ;; state-status-counts)) (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (if (not (equal? state "DELETED")) - (cons state (map dbr:counts-state state-status-counts)) - (map dbr:counts-state state-status-counts))) - *common:std-states* >)) + (delete-duplicates + (if (not (equal? state "DELETED")) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) (all-curr-statuses (common:special-sort ;; worst -> best (delete-duplicates (if (not (equal? state "DELETED")) (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 (equal? x "COMPLETED"))) + (not (member x '("DELETED" "COMPLETED")))) all-curr-states)) - (num-non-completes (length non-completes)) - + (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 - ((> bad-not-started 0) ;; we have an ugly situation, it is completed in the sense we cannot do more. - "COMPLETED") - ((> 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)))) + ((> 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)))) ;; (if (> running 0) ;; "RUNNING" ;; (if (> bad-not-started 0) ;; "COMPLETED" ;; (car all-curr-states)))) - (newstatus (if (or (> bad-not-started 0) - (and (equal? newstate "NOT_STARTED") - (> num-non-completes 0))) - "STARTED" - (car all-curr-statuses)))) + (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") + ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states) ;; " newstate: " newstate " newstatus: " newstatus) ;; NB// Pass the db so it is part of the transaction + (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "len(sscs)="(length state-status-counts) " state-status-counts: " + (apply conc + (map (lambda (x) + (conc + (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) + state-status-counts)) + + ); end debug:print (if tl-test-id - (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)))))))) + (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct + )))))) + (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) tr-res))))) ;; 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* -(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path) - (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=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" - run-id test-name item-path)))) +(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) + + + (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) + (item-state (or item-state-in (db:test-get-state test-info))) + (item-status (or item-status-in (db:test-get-status test-info))) + (other-items-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 + ;; ignore current item because we have changed its value in the current transation so this select will see the old value. + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" + run-id test-name item-path)))) + + ;; add current item to tally outside of sql query + (match-countrec-lambda (lambda (countrec) + (and (equal? (dbr:counts-state countrec) item-state) + (equal? (dbr:counts-status countrec) item-status)))) + + (already-have-count-rec-list + (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status + + (updated-count-rec (if (null? already-have-count-rec-list) + (make-dbr:counts state: item-state status: item-status count: 1) + (let* ((our-count-rec (car already-have-count-rec-list)) + (new-count (add1 (dbr:counts-count our-count-rec)))) + (make-dbr:counts state: item-state status: item-status count: new-count)))) + + (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec)))) + + (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 @@ -4016,72 +4259,125 @@ ;; (conc (db:test-get-testname testdat) ;; "/" ;; (db:test-get-item-path testdat)))) running-tests) ;; calling functions want the entire data '()) + + ;; collection of: for each waiton - + ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: + ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite + ;; if waiton is itemized: + ;; and waiton's items are not expanded, add as unmet prerequisite + ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite + ;; else + ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite + (if (or (not waitons) (null? waitons)) '() - (let* ((unmet-pre-reqs '()) - (result '())) - (for-each + (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) + (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel))))) + (ref-test-is-toplevel (equal? ref-item-path "")) + (ref-test-is-item (not ref-test-is-toplevel)) + (unmet-pre-reqs '()) + (result '()) + (unmet-prereq-items '()) + ) + (for-each ; waitons (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + + (let (;(waiton-is-itemized ...) + ;(waiton-items-are-expanded ...) + (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) - (item-waiton-met #f)) - (for-each - (lambda (test) ;; BB- this is the upstream test - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (let* ((state (db:test-get-state test)) - (status (db:test-get-status test)) - (item-path (db:test-get-item-path test)) ;; BB- this is the upstream itempath - (is-completed (equal? state "COMPLETED")) - (is-running (equal? state "RUNNING")) - (is-killed (equal? state "KILLED")) - (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) + (item-waiton-met #f) + + ) + (for-each ; test expanded from waiton + (lambda (waiton-test) + (let* ((waiton-state (db:test-get-state waiton-test)) + (waiton-status (db:test-get-status waiton-test)) + (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath + (waiton-is-toplevel (equal? waiton-item-path "")) + (waiton-is-item (not waiton-is-toplevel)) + (waiton-is-completed (member waiton-state *common:ended-states*)) + (waiton-is-running (member waiton-state *common:running-states*)) + (waiton-is-killed (member waiton-state *common:badly-ended-states*)) + (waiton-is-ok (member waiton-status *common:well-ended-states*)) ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps))) ;; (equal? ref-item-path waiton-item-path))) (set! ever-seen #t) - (cond - ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test of the waiton being examined - is-completed - (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) + ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***") + (cond + ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed + ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed) + (set! parent-waiton-met #t)) + + ;; case 1, non-item (parent test) is + ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined + waiton-is-completed + ;;(BB> "cond1") + (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait)))))) (set! parent-waiton-met #t)) ;; Special case for toplevel and KILLED - ((and (equal? item-path "") ;; this is the parent test - is-killed + ((and waiton-is-toplevel ;; this is the parent test + waiton-is-killed (member 'toplevel mode)) + ;;(BB> "cond2") (set! parent-waiton-met #t)) ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? - ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items - same-itempath) - (if (and is-completed is-ok) - (set! item-waiton-met #t)) - (if (and (equal? item-path "") ;; if upstream rollup test is completed, parent-waiton-met is set - (or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1 + ((and ref-test-itemized-mode ref-test-is-item same-itempath) + ;;(BB> "cond3") + (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode)) + (set! item-waiton-met #t) + (set! unmet-prereq-items (cons waiton-test unmet-prereq-items))) + (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set + (or waiton-is-completed waiton-is-running)) (set! parent-waiton-met #t))) ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and is-completed - (or is-ok + ((and waiton-is-completed + (or waiton-is-ok (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok - (set! item-waiton-met #t))))) - tests) + (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok + )) + ;;(BB> "cond4") + (set! item-waiton-met #t)) + + ((and waiton-is-completed waiton-is-ok same-itempath) + ;;(BB> "cond5") + (set! item-waiton-met #t)) + (else + #t + ;;(BB> "condelse") + )))) + waiton-tests) ;; both requirements, parent and item-waiton must be met to NOT add item to ;; prereq's not met list - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; appends the string if the full record is not available + ;; (BB> + ;; "\n* waiton-tests "waiton-tests + ;; "\n* parent-waiton-met "parent-waiton-met + ;; "\n* item-waiton-met "item-waiton-met + ;; "\n* ever-seen "ever-seen + ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode + ;; "\n* unmet-prereq-items "unmet-prereq-items + ;; "\n* result (pre) "result + ;; "\n* ever-seen "ever-seen + ;; "\n") + + (cond + ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items))) + (set! result (append unmet-prereq-items result))) + ((not (or parent-waiton-met item-waiton-met)) + (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) + ((not ever-seen) + (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy @@ -4227,10 +4523,11 @@ (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -147,10 +147,16 @@ (define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) (define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) (define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) (define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) (define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; S I M P L E R U N +;;====================================================================== + +;; (defstruct id "runname" "state" "status" "owner" "event_time" ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (make-db:test-data)(make-vector 10)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -313,11 +313,12 @@ (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations (test-name (db:test-get-testname hed)) (item-path (db:test-get-item-path hed)) (state (db:test-get-state hed)) (status (db:test-get-status hed)) - (newitem (list test-name item-path (list test-id state status)))) + (event-time (db:test-get-event_time hed)) + (newitem (list test-name item-path (list test-id state status event-time)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) (define (dcommon:tests-mindat->hash tests-mindat) Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -2093,16 +2093,100 @@

Then in runconfigs.config

Example of using modified.config in a testconfig
cat testconfig
-
 [pre-launch-env-vars]
 [include modified.config]
+ +
+

Managing Old Runs

+
+

It is often desired to keep some older runs around but this must be balanced with the costs of disk space.

+
    +
  1. +

    +Use -remove-keep +

    +
    2. +
  2. +

    +Use -archive (can also be done from the -remove-keep interface) +

    +
    3. +
  3. +

    +use -remove-runs with -keep-records +

    +
    4. +
+
+
For each target, remove all runs but the most recent 3 if they are over 1 week old
+
+
# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
+megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"
+
+
+
+
+

Nested Runs

+
+

A Megatest test can run a full Megatest run in either the same +Megatest area or in another area. This is a powerful way of chaining +complex suites of tests and or actions.

+

If you are not using the current area you can use ezsteps to retrieve +and setup the sub-Megatest run area.

+

In the testconfig:

+
+
+
[subrun]
+
+# Required: wait for the run or just launch it
+#           if no then the run will be an automatic PASS irrespective of the actual result
+runwait yes|no
+
+# Optional: where to execute the run. Default is the current runarea
+runarea /some/path/to/megatest/area
+
+# Optional: method to use to determine pass/fail status of the run
+#   auto (default) - roll up the net state/status of the sub-run
+#   logpro         - use the provided logpro rules, happens automatically if there is a logpro section
+# passfail auto|logpro
+# Example of logpro:
+passfail logpro
+
+# Optional:
+logpro ;; if this section exists then logpro is used to determine pass/fail
+  (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
+
+# Optional: target translator, default is to use the parent target
+target #{shell somescript.sh}
+
+# Optional: runname translator/generator, default is to use the parent runname
+runname #{somescript.sh}
+
+# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
+testpatt %/item1,test2
+
+# Optional: contour spec, use the named contour from the megatest.config contour spec
+contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
+
+# Optional: mode-patt, use this spec for testpatt from runconfigs
+mode-patt TESTPATT
+
+# Optional: tag-expr, use this tag-expr to select tests
+tag-expr quick
+
+# Optional: (not yet implemented), propagate these actions from the parent
+#           test
+#   Note// default is % for all
+propagate remove-runs archive ...
+
+

Programming API

These routines can be called from the megatest repl.

@@ -2160,10 +2244,10 @@
Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -608,15 +608,86 @@ Then in runconfigs.config .Example of using modified.config in a testconfig ------------------------------ cat testconfig - [pre-launch-env-vars] [include modified.config] ------------------------------ +Managing Old Runs +----------------- + +It is often desired to keep some older runs around but this must be balanced with the costs of disk space. + +. Use -remove-keep +. Use -archive (can also be done from the -remove-keep interface) +. use -remove-runs with -keep-records + +.For each target, remove all runs but the most recent 3 if they are over 1 week old +--------------------- +# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel. +megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'" +--------------------- + +Nested Runs +----------- + +A Megatest test can run a full Megatest run in either the same +Megatest area or in another area. This is a powerful way of chaining +complex suites of tests and or actions. + +If you are not using the current area you can use ezsteps to retrieve +and setup the sub-Megatest run area. + +In the testconfig: +--------------- +[subrun] + +# Required: wait for the run or just launch it +# if no then the run will be an automatic PASS irrespective of the actual result +runwait yes|no + +# Optional: where to execute the run. Default is the current runarea +runarea /some/path/to/megatest/area + +# Optional: method to use to determine pass/fail status of the run +# auto (default) - roll up the net state/status of the sub-run +# logpro - use the provided logpro rules, happens automatically if there is a logpro section +# passfail auto|logpro +# Example of logpro: +passfail logpro + +# Optional: +logpro ;; if this section exists then logpro is used to determine pass/fail + (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/) + (expect:fail in "LogFileBody" = 0 "No FAILs allowed" #/FAIL/) + +# Optional: target translator, default is to use the parent target +target #{shell somescript.sh} + +# Optional: runname translator/generator, default is to use the parent runname +runname #{somescript.sh} + +# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec +testpatt %/item1,test2 + +# Optional: contour spec, use the named contour from the megatest.config contour spec +contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature. + +# Optional: mode-patt, use this spec for testpatt from runconfigs +mode-patt TESTPATT + +# Optional: tag-expr, use this tag-expr to select tests +tag-expr quick + +# Optional: (not yet implemented), propagate these actions from the parent +# test +# Note// default is % for all +propagate remove-runs archive ... + +--------------- Programming API --------------- These routines can be called from the megatest repl. ADDED docs/megatest-desktop.png Index: docs/megatest-desktop.png ================================================================== --- /dev/null +++ docs/megatest-desktop.png cannot compute difference between binary files Index: docs/megatest-state-status.dot ================================================================== --- docs/megatest-state-status.dot +++ docs/megatest-state-status.dot @@ -31,11 +31,11 @@ label="{RUNNING|{n/a| PASS | FAIL}}"; ] "COMPLETED" [ shape="record"; - label = "{COMPLETED|{PASS | FAIL | CHECK| SKIP}}"; + label = "{COMPLETED|{PASS | SKIP | WAIVED | FAIL | CHECK| ABORT}}"; ] "RUNNING" -> "COMPLETED"; "RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"]; DELETED emergency-patch-1.scm Index: emergency-patch-1.scm ================================================================== --- emergency-patch-1.scm +++ /dev/null @@ -1,203 +0,0 @@ - - -;; These are called by the server on recipt of /api calls -;; - keep it simple, only return the actual result of the call, i.e. no meta info here -;; -;; - returns #( flag result ) -;; -(define (api:execute-requests dbstruct dat) - (handle-exceptions - exn - (let ((call-chain (get-call-chain))) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat) - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f (vector #f "remote must be called with a vector"))) - ((> *api-process-request-count* 20) ;; 20) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") - (set! *server-overloaded* #t) - (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! - (else - (let* ((cmd-in (vector-ref dat 0)) - (cmd (if (symbol? cmd-in) - cmd-in - (string->symbol cmd-in))) - (params (vector-ref dat 1)) - (start-t (current-milliseconds)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (case cmd - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - - ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) - ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. - ((test-set-state-status-by-id) - - ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) - (db:set-state-status-and-roll-up-items - dbstruct - (list-ref params 0) ; run-id - (list-ref params 1) ; test-name - #f ; item-path - (list-ref params 2) ; state - (list-ref params 3) ; status - (list-ref params 4) ; comment - )) - - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - ((del-var) (apply db:del-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - ((get-tests-tags) (db:get-tests-tags dbstruct)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; NO SYNC DB - ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) - ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) - ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - ((read-test-data*) (apply db:read-test-data* dbstruct params)) - - ;; MISC - ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) - ((general-call) (let ((stmtname (car params)) - (run-id (cadr params)) - (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) - (else - (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) - (conc "ERROR: BAD api call " cmd)))))) - - ;; save all stats - (let ((delta-t (- (current-milliseconds) - start-t))) - (hash-table-set! *db-api-call-time* cmd - (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) - (if writecmd-in-readonly-mode - (vector #f res) - (vector #t res))))))) DELETED emergency-patch-2.scm Index: emergency-patch-2.scm ================================================================== --- emergency-patch-2.scm +++ /dev/null @@ -1,311 +0,0 @@ -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) - (let* ((loadavg (common:get-cpu-load remote-host)) - (first (car loadavg)) - (next (cadr loadavg)) - (adjload (* maxload numcpus)) - (loadjmp (- first next))) - (cond - ((and (> first adjload) - (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) - ((and (> loadjmp numcpus) - (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) - -(define (common:wait-for-homehost-load maxload msg) - (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. - #f - (common:get-homehost))) - (hh (if hh-dat (car hh-dat) #f)) - (numcpus (common:get-num-cpus hh))) - (common:wait-for-normalized-load maxload msg: msg remote-host: hh))) - -;; wait for normalized cpu load to drop below maxload -;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) - (let ((num-cpus (common:get-num-cpus remote-host))) - (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) - -;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) -(define (runs:process-expanded-tests runsdat testdat) - ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). - (let* ((hed (runs:testdat-hed testdat)) - (tal (runs:testdat-tal testdat)) - (reg (runs:testdat-reg testdat)) - (reruns (runs:testdat-reruns testdat)) - (test-name (runs:testdat-test-name testdat)) - (item-path (runs:testdat-item-path testdat)) - (jobgroup (runs:testdat-jobgroup testdat)) - (waitons (runs:testdat-waitons testdat)) - (item-path (runs:testdat-item-path testdat)) - (testmode (runs:testdat-testmode testdat)) - (newtal (runs:testdat-newtal testdat)) - (itemmaps (runs:testdat-itemmaps testdat)) - (test-record (runs:testdat-test-record testdat)) - (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) - - (reglen (runs:dat-reglen runsdat)) - (regfull (runs:dat-regfull runsdat)) - (runname (runs:dat-runname runsdat)) - (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) - (run-id (runs:dat-run-id runsdat)) - (test-patts (runs:dat-test-patts runsdat)) - (required-tests (runs:dat-required-tests runsdat)) - (test-registry (runs:dat-test-registry runsdat)) - (registry-mutex (runs:dat-registry-mutex runsdat)) - (flags (runs:dat-flags runsdat)) - (keyvals (runs:dat-keyvals runsdat)) - (run-info (runs:dat-run-info runsdat)) - (all-tests-registry (runs:dat-all-tests-registry runsdat)) - (run-limits-info (runs:dat-can-run-more-tests runsdat)) - ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (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) - (runs:calc-fails prereqs-not-met) - (begin - (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) - '()))) - (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! - (not (equal? x hed))) - (runs:calc-not-completed prereqs-not-met))) - (loop-list (list hed tal reg reruns)) - ;; configure the load runner - (numcpus (common:get-num-cpus #f)) - (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0"))) ;; use a non-number string to disable - (maxhomehostload (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable - (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) - (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" - (string-intersperse - (map (lambda (t) - (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) - (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) - ", ") ") fails: " fails - "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - - - - (if (and (not (null? prereqs-not-met)) - (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) - - (cond - - ;; Check item path against item-patts, - ;; - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) - #f)) - - ;; Register tests - ;; - ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) - ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs - (let register-loop ((numtries 15)) - (rmt:register-test run-id test-name item-path) - (if (rmt:get-test-id run-id test-name item-path) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) - (if (> numtries 0) - (begin - (thread-sleep! 0.5) - (register-loop (- numtries 1))) - (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) - (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) - (begin - (rmt:register-test run-id test-name "") - (if (rmt:get-test-id run-id test-name "") - (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - (if (and (null? tal)(null? reg)) - (list hed tal (append reg (list hed)) reruns) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - ;; NB// Here we are building reg as we register tests - ;; if regfull we must pop the front item off reg - (if regfull - (append (cdr reg) (list hed)) - (append reg (list hed))) - reruns))) - - ;; At this point hed test registration must be completed. - ;; - ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) - 'start) - (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " - (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.051) - (list hed tal reg reruns)) - - ;; If no resources are available just kill time and loop again - ;; - ((not have-resources) ;; simply try again after waiting a second - (if (runs:lownoise "no resources" 60) - (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - (thread-sleep! 1) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (list (car newtal)(cdr newtal) reg reruns)) - - ;; This is the final stage, everything is in place so launch the test - ;; - ((and have-resources - (or (null? prereqs-not-met) - (and (member 'toplevel testmode) ;; 'toplevel) - (null? non-completed) - (not (member 'exclusive testmode))))) - ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) - ;; we are going to reset all the counters for test retries by setting a new hash table - ;; this means they will increment only when nothing can be run - (set! *max-tries-hash* (make-hash-table)) - ;; well, first lets see if cpu load throttling is enabled. If so wait around until the - ;; average cpu load is under the threshold before continuing - (if maxload ;; only gate if maxload is specified - (common:wait-for-cpuload maxload numcpus waitdelay)) - (if maxhomehostload - (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))) - - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) - (runs:incremental-print-results run-id) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) - #f)) - - ;; must be we have unmet prerequisites - ;; - (else - (debug:print 4 *default-log-port* "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) - (if (and (not (null? prereqs-not-met)) - (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse - (runs:mixed-list-testname-and-testrec->list-of-strings - prereqs-not-met) ", "))) - (if (or (null? fails) - (member 'toplevel testmode)) - (begin - ;; couldn't run, take a breather - (if (runs:lownoise "Waiting for more work to do..." 60) - (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) - (thread-sleep! 1) - (list (car newtal)(cdr newtal) reg reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (or (not (null? reg))(not (null? tal))) - (if (vector? hed) - (begin - (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path - " from the launch list as it has prerequistes that are FAIL") - (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - ;; This next is for the items - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? - )) - (let ((nth-try (hash-table-ref/default test-registry hed 0))) - (cond - ((member "RUNNING" (map db:test-get-state prereqs-not-met)) - (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) - (thread-sleep! 4) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) - ((or (not nth-try) - (and (number? nth-try) - (< nth-try 10))) - (hash-table-set! test-registry hed (if (number? nth-try) - (+ nth-try 1) - 0)) - (if (runs:lownoise (conc "not removing test " hed) 60) - (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) - ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (list hed tal reg reruns) - ;; (list (car newtal)(cdr newtal) reg reruns) - ;; (hash-table-set! test-registry hed 'removed) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) - ((symbol? nth-try) - (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW - (if (null? tal) - #f ;; yes, really - (list (car tal)(cdr tal) reg reruns)) - (begin - (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) - (hash-table-set! test-registry hed 0) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)))) - (else - (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) - ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) - (hash-table-set! test-registry hed 'removed) - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) - ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. - (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL - (list (if (null? tal)(car newtal)(car tal)) - tal - reg - reruns))))) - ;; can't drop this - maybe running? Just keep trying - (let ((runable-tests (runs:runable-tests prereqs-not-met))) - (if (null? runable-tests) - #f ;; I think we are truly done here - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns))))))))) ADDED emergency-patches/emergency-patch-1.scm Index: emergency-patches/emergency-patch-1.scm ================================================================== --- /dev/null +++ emergency-patches/emergency-patch-1.scm @@ -0,0 +1,203 @@ + + +;; These are called by the server on recipt of /api calls +;; - keep it simple, only return the actual result of the call, i.e. no meta info here +;; +;; - returns #( flag result ) +;; +(define (api:execute-requests dbstruct dat) + (handle-exceptions + exn + (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat) + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens + (cond + ((not (vector? dat)) ;; it is an error to not receive a vector + (vector #f (vector #f "remote must be called with a vector"))) + ((> *api-process-request-count* 20) ;; 20) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") + (set! *server-overloaded* #t) + (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! + (else + (let* ((cmd-in (vector-ref dat 0)) + (cmd (if (symbol? cmd-in) + cmd-in + (string->symbol cmd-in))) + (params (vector-ref dat 1)) + (start-t (current-milliseconds)) + (readonly-mode (dbr:dbstruct-read-only dbstruct)) + (readonly-command (member cmd api:read-only-queries)) + (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) + (res + (if writecmd-in-readonly-mode + (conc "attempt to run write command "cmd" on a read-only database") + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl + + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) + ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + + ;; RUNS + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) + ((del-var) (apply db:del-var dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + + ;; MISC + ((sync-inmem->db) (let ((run-id (car params))) + (db:sync-touched dbstruct run-id force-sync: #t))) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + + ;; TESTMETA + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) + + ;; TASKS + ((tasks-add) (apply tasks:add dbstruct params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) + + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + + ;; ARCHIVES + ;; ((archive-get-allocations) + ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) + ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + + ;;====================================================================== + ;; READ ONLY QUERIES + ;;====================================================================== + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-target) (apply db:get-target dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) + + ;; ARCHIVES + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) + + ;; STEPS + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ((read-test-data*) (apply db:read-test-data* dbstruct params)) + + ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:general-call dbstruct stmtname realparams))) + ((sdb-qry) (apply sdb:qry params)) + ((ping) (current-process-id)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) + (else + (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) + (conc "ERROR: BAD api call " cmd)))))) + + ;; save all stats + (let ((delta-t (- (current-milliseconds) + start-t))) + (hash-table-set! *db-api-call-time* cmd + (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) + (if writecmd-in-readonly-mode + (vector #f res) + (vector #t res))))))) ADDED emergency-patches/emergency-patch-2.scm Index: emergency-patches/emergency-patch-2.scm ================================================================== --- /dev/null +++ emergency-patches/emergency-patch-2.scm @@ -0,0 +1,311 @@ +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) + (let* ((loadavg (common:get-cpu-load remote-host)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjload (* maxload numcpus)) + (loadjmp (- first next))) + (cond + ((and (> first adjload) + (> count 0)) + (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg "")) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + ((and (> loadjmp numcpus) + (> count 0)) + (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) + +(define (common:wait-for-homehost-load maxload msg) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (common:get-homehost))) + (hh (if hh-dat (car hh-dat) #f)) + (numcpus (common:get-num-cpus hh))) + (common:wait-for-normalized-load maxload msg: msg remote-host: hh))) + +;; wait for normalized cpu load to drop below maxload +;; +(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) + (let ((num-cpus (common:get-num-cpus remote-host))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) + +;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) +(define (runs:process-expanded-tests runsdat testdat) + ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). + (let* ((hed (runs:testdat-hed testdat)) + (tal (runs:testdat-tal testdat)) + (reg (runs:testdat-reg testdat)) + (reruns (runs:testdat-reruns testdat)) + (test-name (runs:testdat-test-name testdat)) + (item-path (runs:testdat-item-path testdat)) + (jobgroup (runs:testdat-jobgroup testdat)) + (waitons (runs:testdat-waitons testdat)) + (item-path (runs:testdat-item-path testdat)) + (testmode (runs:testdat-testmode testdat)) + (newtal (runs:testdat-newtal testdat)) + (itemmaps (runs:testdat-itemmaps testdat)) + (test-record (runs:testdat-test-record testdat)) + (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) + + (reglen (runs:dat-reglen runsdat)) + (regfull (runs:dat-regfull runsdat)) + (runname (runs:dat-runname runsdat)) + (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) + (run-id (runs:dat-run-id runsdat)) + (test-patts (runs:dat-test-patts runsdat)) + (required-tests (runs:dat-required-tests runsdat)) + (test-registry (runs:dat-test-registry runsdat)) + (registry-mutex (runs:dat-registry-mutex runsdat)) + (flags (runs:dat-flags runsdat)) + (keyvals (runs:dat-keyvals runsdat)) + (run-info (runs:dat-run-info runsdat)) + (all-tests-registry (runs:dat-all-tests-registry runsdat)) + (run-limits-info (runs:dat-can-run-more-tests runsdat)) + ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (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) + (runs:calc-fails prereqs-not-met) + (begin + (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) + '()))) + (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! + (not (equal? x hed))) + (runs:calc-not-completed prereqs-not-met))) + (loop-list (list hed tal reg reruns)) + ;; configure the load runner + (numcpus (common:get-num-cpus #f)) + (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0"))) ;; use a non-number string to disable + (maxhomehostload (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable + (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) + (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" + (string-intersperse + (map (lambda (t) + (if (vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc " WARNING: t is not a vector=" t ))) + prereqs-not-met) + ", ") ") fails: " fails + "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + + + + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + + ;; Don't know at this time if the test have been launched at some time in the past + ;; i.e. is this a re-launch? + (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) + + (cond + + ;; Check item path against item-patts, + ;; + ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run + ;; else the run is stuck, temporarily or permanently + ;; but should check if it is due to lack of resources vs. prerequisites + (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; Register tests + ;; + ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) + ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + (let register-loop ((numtries 15)) + (rmt:register-test run-id test-name item-path) + (if (rmt:get-test-id run-id test-name item-path) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) + (if (> numtries 0) + (begin + (thread-sleep! 0.5) + (register-loop (- numtries 1))) + (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) + (begin + (rmt:register-test run-id test-name "") + (if (rmt:get-test-id run-id test-name "") + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + (if (and (null? tal)(null? reg)) + (list hed tal (append reg (list hed)) reruns) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + ;; NB// Here we are building reg as we register tests + ;; if regfull we must pop the front item off reg + (if regfull + (append (cdr reg) (list hed)) + (append reg (list hed))) + reruns))) + + ;; At this point hed test registration must be completed. + ;; + ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) + 'start) + (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " + (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registry x #f) 'start)) + (hash-table-keys test-registry)) + ", ")) + (thread-sleep! 0.051) + (list hed tal reg reruns)) + + ;; If no resources are available just kill time and loop again + ;; + ((not have-resources) ;; simply try again after waiting a second + (if (runs:lownoise "no resources" 60) + (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + (thread-sleep! 1) + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (list (car newtal)(cdr newtal) reg reruns)) + + ;; This is the final stage, everything is in place so launch the test + ;; + ((and have-resources + (or (null? prereqs-not-met) + (and (member 'toplevel testmode) ;; 'toplevel) + (null? non-completed) + (not (member 'exclusive testmode))))) + ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) + ;; we are going to reset all the counters for test retries by setting a new hash table + ;; this means they will increment only when nothing can be run + (set! *max-tries-hash* (make-hash-table)) + ;; well, first lets see if cpu load throttling is enabled. If so wait around until the + ;; average cpu load is under the threshold before continuing + (if maxload ;; only gate if maxload is specified + (common:wait-for-cpuload maxload numcpus waitdelay)) + (if maxhomehostload + (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))) + + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (runs:incremental-print-results run-id) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; must be we have unmet prerequisites + ;; + (else + (debug:print 4 *default-log-port* "FAILS: " fails) + ;; If one or more of the prereqs-not-met are FAIL then we can issue + ;; a message and drop hed from the items to be processed. + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) + (if (or (null? fails) + (member 'toplevel testmode)) + (begin + ;; couldn't run, take a breather + (if (runs:lownoise "Waiting for more work to do..." 60) + (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) + (thread-sleep! 1) + (list (car newtal)(cdr newtal) reg reruns)) + ;; the waiton is FAIL so no point in trying to run hed ever again + (if (or (not (null? reg))(not (null? tal))) + (if (vector? hed) + (begin + (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path + " from the launch list as it has prerequistes that are FAIL") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + ;; This next is for the items + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? + )) + (let ((nth-try (hash-table-ref/default test-registry hed 0))) + (cond + ((member "RUNNING" (map db:test-get-state prereqs-not-met)) + (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) + (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (thread-sleep! 4) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)) + ((or (not nth-try) + (and (number? nth-try) + (< nth-try 10))) + (hash-table-set! test-registry hed (if (number? nth-try) + (+ nth-try 1) + 0)) + (if (runs:lownoise (conc "not removing test " hed) 60) + (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + ;; (list hed tal reg reruns) + ;; (list (car newtal)(cdr newtal) reg reruns) + ;; (hash-table-set! test-registry hed 'removed) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)) + ((symbol? nth-try) + (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW + (if (null? tal) + #f ;; yes, really + (list (car tal)(cdr tal) reg reruns)) + (begin + (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) + (hash-table-set! test-registry hed 0) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)))) + (else + (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) + (hash-table-set! test-registry hed 'removed) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) + ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. + (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL + (list (if (null? tal)(car newtal)(car tal)) + tal + reg + reruns))))) + ;; can't drop this - maybe running? Just keep trying + (let ((runable-tests (runs:runable-tests prereqs-not-met))) + (if (null? runable-tests) + #f ;; I think we are truly done here + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns))))))))) ADDED emergency-patches/emergency-patch-3.scm Index: emergency-patches/emergency-patch-3.scm ================================================================== --- /dev/null +++ emergency-patches/emergency-patch-3.scm @@ -0,0 +1,81 @@ + ;; To build patch: + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ldd /p/foundry/env/pkgs/megatest/1.64/19/bin/.11/mtest + ;; linux-vdso.so.1 => (0x00002aaaaaaab000) + ;; libchicken.so.7 => /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0//lib/libchicken.so.7 (0x00002aaaaaaad000) + ;; libm.so.6 => /lib64/libm.so.6 (0x00002aaaab0a6000) + ;; libdl.so.2 => /lib64/libdl.so.2 (0x00002aaaab31f000) + ;; libc.so.6 => /lib64/libc.so.6 (0x00002aaaab523000) + ;; /lib64/ld-linux-x86-64.so.2 (0x0000555555554000) + ;; + ;; /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csc -s emergency-patch-3.scm + ;; + + + ;; to test patch: + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; in .megatestrc, add: + ;; (if (and (> megatest-version 1.64) + ;; (< megatest-version 1.6421)) + ;; (begin + ;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-1.so") + ;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-2.so"))) + ;; + + + ;; to productize patch: + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; +(use directory-utils regex) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; 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. +;; +(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area + (let* ((curr-host (get-host-name)) + ;; (attempt-in-progress (server:start-attempted? areapath)) + ;; (dot-server-url (server:check-if-running areapath)) + (curr-ip (server:get-best-guess-address curr-host)) + (curr-pid (current-process-id)) + (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) + (target-host (car homehost)) + (testsuite (common:get-testsuite-name)) + (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) + (cmdln (conc (common:get-megatest-exe) + " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") + " -daemonize " + "") + ;; " -log " logfile + " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) + (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) + (load-limit (configf:lookup-number *configdat* "server" "load-limit" default: 0.9))) + ;; we want the remote server to start in *toppath* so push there + (push-directory areapath) + (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") + (thread-start! log-rotate) + + ;; host.domain.tld match host? + (if (and target-host + ;; look at target host, is it host.domain.tld or ip address and does it + ;; match current ip or hostname + (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) + (not (equal? curr-ip target-host))) + (begin + (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) + (setenv "TARGETHOST" target-host))) + + (setenv "TARGETHOST_LOGF" logfile) + (common:wait-for-normalized-load load-limit " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever + (system (conc "nbfake " cmdln)) + (unsetenv "TARGETHOST_LOGF") + (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) + (thread-join! log-rotate) + (pop-directory))) ADDED get-config-settings.sh Index: get-config-settings.sh ================================================================== --- /dev/null +++ get-config-settings.sh @@ -0,0 +1,2 @@ + grep configf:lookup *.scm | sed 's/^.*:lookup//; s/^-number//; s/^ //' | grep -v '^\(section\|test-conf\|tconfig\|testconfig\|dat\|config\|views-cfgdat\)' | perl -pe 's/^\s*(\*configdat\*|configdat|mtconf)//; s/^\s+//; s/\).*$//; s/"//g' | awk '{print $1,$2}' | sort | grep -v section | sort | uniq + Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -36,10 +36,11 @@ ;; ((if get-label cadr car) (case (string->symbol state) ((COMPLETED) ;; ARCHIVED) (case (string->symbol status) ((PASS) (list "70 249 73" status)) + ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) ((WARN WAIVED) (list "255 172 13" status)) ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) ((ABORT) (list "198 36 166" status)) (else (list "253 33 49" status)))) ((ARCHIVED) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -7,10 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) + (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) @@ -29,11 +30,13 @@ (declare (uses portlogger)) (declare (uses rmt)) (include "common_records.scm") (include "db_records.scm") +(include "js-path.scm") +(require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) @@ -56,12 +59,15 @@ ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) - (link-tree-path (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) + (link-tree-path (common:get-linktree)) + (tmp-area (common:get-db-tmp-area)) + (start-file (conc tmp-area "/.server-start"))) (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port) + ;; set some parameters for the server (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) (handle-exception (lambda (exn chain) @@ -100,13 +106,26 @@ '(/ any)) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) - (send-response body: "hey there!\n" + (send-response body: "hey there!\n" headers: '((content-type text/plain)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "jquery3.1.0.js")) + (send-response body: (http-transport:show-jquery) + headers: '((content-type application/javascript)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "test_log")) + (send-response body: (http-transport:html-test-log $) + headers: '((content-type text/HTML)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "dashboard")) + (send-response body: (http-transport:html-dboard $) + headers: '((content-type text/HTML)))) (else (continue)))))))) + (with-output-to-file start-file (lambda ()(print (current-process-id)))) (http-transport:try-start-server ipaddrstr start-port))) ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server ipaddrstr portnum) @@ -238,10 +257,11 @@ (msg ((condition-property-accessor 'exn 'message) exn))) (set! success #f) (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 *default-log-port* " message: " msg) (debug:print 0 *default-log-port* " cmd: " cmd " params: " params) + (debug:print 0 *default-log-port* " call-chain: " call-chain) (if runremote (remote-conndat-set! runremote #f)) ;; Killing associated server to allow clean retry.") ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) @@ -249,11 +269,11 @@ ;;; (make-property-condition 'commfail 'message "failed to connect to server"))) ;;; "communications failed" (db:obj->string #f)) (with-input-from-request ;; was dat fullurl - (list (cons 'key "thekey") + (list (cons 'key (or *server-id* "thekey")) (cons 'cmd cmd) (cons 'params sparams)) read-string)) transport: 'http) 0)) ;; added this speculatively @@ -300,10 +320,11 @@ exn (begin (print-call-chain *default-log-port*) (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn))) (close-connection! api-dat) + ;;(close-idle-connections!) #t)) #f))) (define (make-http-transport:server-dat)(make-vector 6)) @@ -347,11 +368,13 @@ (define (http-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") - (let* ((server-start-time (current-seconds)) + (let* ((tmp-area (common:get-db-tmp-area)) + (started-file (conc tmp-area "/.server-started")) + (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (let ((sdat #f)) (thread-sleep! 0.01) @@ -389,13 +412,16 @@ (equal? sdat last-sdat) sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) - (server-timeout (server:get-timeout)) + (server-timeout (server:expiration-timeout)) (server-going #f) (server-log-file (args:get-arg "-log"))) ;; always set when we are a server + + (with-output-to-file started-file (lambda ()(print (current-process-id)))) + (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db @@ -443,21 +469,15 @@ (flush-output *default-log-port*))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) - (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) - (adjusted-timeout (if (> hrs-since-start 1) ;; never used! - (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour - server-timeout))) - (if (common:low-noise-print 120 "server timeout") - (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout)) + (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((and *server-run* (> (+ last-access server-timeout) - (current-seconds)) - (< (- (current-seconds) server-start-time) 3600)) ;; do not update log or touch log if we've been running for more than one hour. + (current-seconds))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (let ((curr-time (current-seconds))) (handle-exceptions exn @@ -507,60 +527,116 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch) - ;; lets not even bother to start if there are already three or more server files ready to go - (let* ((num-alive (server:get-num-alive (server:get-list *toppath*)))) - (if (> num-alive 3) + ;; check that a server start is in progress, pause or exit if so + (let* ((tmp-area (common:get-db-tmp-area)) + (server-start (conc tmp-area "/.server-start")) + (server-started (conc tmp-area "/.server-started")) + (start-time (common:lazy-modification-time server-start)) + (started-time (common:lazy-modification-time server-started)) + (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting + (start-time-old (> (- (current-seconds) start-time) 5)) + (cleanup-proc (lambda (msg) + (let* ((serv-fname (conc "server-" (current-process-id) "-" (get-host-name) ".log")) + (full-serv-fname (conc *toppath* "/logs/" serv-fname)) + (new-serv-fname (conc *toppath* "/logs/" "defunct-" serv-fname))) + (debug:print 0 *default-log-port* msg) + (if (common:file-exists? full-serv-fname) + (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname)) + (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname)) + (exit))))) + (if (and (not start-time-old) ;; last server start try was less than five seconds ago + (not server-starting)) (begin - (debug:print 0 *default-log-port* "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up") - (exit)))) + (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting") + (exit))) + ;; lets not even bother to start if there are already three or more server files ready to go + (let* ((num-alive (server:get-num-alive (server:get-list *toppath*)))) + (if (> num-alive 3) + (begin + (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up")) + (exit)))) (common:save-pkt `((action . start) (T . server) (pid . ,(current-process-id))) *configdat* #t) - (let* ((th2 (make-thread (lambda () - (debug:print-info 0 *default-log-port* "Server run thread started") - (http-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-") - )) "Server run")) - (th3 (make-thread (lambda () - (debug:print-info 0 *default-log-port* "Server monitor thread started") - (http-transport:keep-running) - "Keep running")))) - (thread-start! th2) - (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. - (thread-start! th3) - (set! *didsomething* #t) - (thread-join! th2) - (exit))) - -(define (http-transport:server-signal-handler signum) - (signal-mask! signum) - (handle-exceptions - exn - (debug:print 0 *default-log-port* " ... exiting ...") - (let ((th1 (make-thread (lambda () - (thread-sleep! 1)) - "eat response")) - (th2 (make-thread (lambda () - (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") - (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 *default-log-port* " Done.") - (exit 4)) - "exit on ^C timer"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2)))) + (let* ((th2 (make-thread (lambda () + (debug:print-info 0 *default-log-port* "Server run thread started") + (http-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + )) "Server run")) + (th3 (make-thread (lambda () + (debug:print-info 0 *default-log-port* "Server monitor thread started") + (http-transport:keep-running) + "Keep running")))) + (thread-start! th2) + (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. + (thread-start! th3) + (set! *didsomething* #t) + (thread-join! th2) + (exit)))) + +;; (define (http-transport:server-signal-handler signum) +;; (signal-mask! signum) +;; (handle-exceptions +;; exn +;; (debug:print 0 *default-log-port* " ... exiting ...") +;; (let ((th1 (make-thread (lambda () +;; (thread-sleep! 1)) +;; "eat response")) +;; (th2 (make-thread (lambda () +;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") +;; (thread-sleep! 3) ;; give the flush three seconds to do it's stuff +;; (debug:print 0 *default-log-port* " Done.") +;; (exit 4)) +;; "exit on ^C timer"))) +;; (thread-start! th2) +;; (thread-start! th1) +;; (thread-join! th2)))) + +;;=============================================== +;; Java script +;;=============================================== +(define (http-transport:show-jquery) + (let* ((data (tests:readlines *java-script-lib*))) +(string-join data "\n"))) + + ;;====================================================================== ;; web pages ;;====================================================================== +(define (http-transport:html-test-log $) + (let* ((run-id ($ 'runid)) + (test-item ($ 'testname)) + (parts (string-split test-item ":")) + (test-name (car parts)) + + (item-name (if (equal? (length parts) 1) + "" + (cadr parts)))) + ;(print $) +(tests:get-test-log run-id test-name item-name))) + + +(define (http-transport:html-dboard $) + (let* ((page ($ 'page)) + (oup (open-output-string)) + (bdy "--------------------------") + + (ret (tests:dynamic-dboard page))) + (s:output-new oup ret) + (close-output-port oup) + + (set! bdy (get-output-string oup)) + (conc "

Dashboard

" bdy "

" ))) + (define (http-transport:main-page) (let ((linkpath (root-path))) (conc "

" (pathname-strip-directory *toppath*) "

" "" "Run area: " *toppath* ADDED java-script-lib/jquery-3.1.0.slim.min.js Index: java-script-lib/jquery-3.1.0.slim.min.js ================================================================== --- /dev/null +++ java-script-lib/jquery-3.1.0.slim.min.js @@ -0,0 +1,4 @@ +/*! jQuery v3.1.0 -ajax,-ajax/jsonp,-ajax/load,-ajax/parseXML,-ajax/script,-ajax/var/location,-ajax/var/nonce,-ajax/var/rquery,-ajax/xhr,-manipulation/_evalUrl,-event/ajax,-effects,-effects/Tween,-effects/animatedSelector,-deprecated | (c) jQuery Foundation | jquery.org/license */ +!function(a,b){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=a.document?b(a,!0):function(a){if(!a.document)throw new Error("jQuery requires a window with a document");return b(a)}:b(a)}("undefined"!=typeof window?window:this,function(a,b){"use strict";var c=[],d=a.document,e=Object.getPrototypeOf,f=c.slice,g=c.concat,h=c.push,i=c.indexOf,j={},k=j.toString,l=j.hasOwnProperty,m=l.toString,n=m.call(Object),o={};function p(a,b){b=b||d;var c=b.createElement("script");c.text=a,b.head.appendChild(c).parentNode.removeChild(c)}var q="3.1.0 -ajax,-ajax/jsonp,-ajax/load,-ajax/parseXML,-ajax/script,-ajax/var/location,-ajax/var/nonce,-ajax/var/rquery,-ajax/xhr,-manipulation/_evalUrl,-event/ajax,-effects,-effects/Tween,-effects/animatedSelector,-deprecated",r=function(a,b){return new r.fn.init(a,b)},s=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g,t=/^-ms-/,u=/-([a-z])/g,v=function(a,b){return b.toUpperCase()};r.fn=r.prototype={jquery:q,constructor:r,length:0,toArray:function(){return f.call(this)},get:function(a){return null!=a?a<0?this[a+this.length]:this[a]:f.call(this)},pushStack:function(a){var b=r.merge(this.constructor(),a);return b.prevObject=this,b},each:function(a){return r.each(this,a)},map:function(a){return this.pushStack(r.map(this,function(b,c){return a.call(b,c,b)}))},slice:function(){return this.pushStack(f.apply(this,arguments))},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},eq:function(a){var b=this.length,c=+a+(a<0?b:0);return this.pushStack(c>=0&&c0&&b-1 in a)}var x=function(a){var b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u="sizzle"+1*new Date,v=a.document,w=0,x=0,y=ha(),z=ha(),A=ha(),B=function(a,b){return a===b&&(l=!0),0},C={}.hasOwnProperty,D=[],E=D.pop,F=D.push,G=D.push,H=D.slice,I=function(a,b){for(var c=0,d=a.length;c+~]|"+K+")"+K+"*"),S=new RegExp("="+K+"*([^\\]'\"]*?)"+K+"*\\]","g"),T=new RegExp(N),U=new RegExp("^"+L+"$"),V={ID:new RegExp("^#("+L+")"),CLASS:new RegExp("^\\.("+L+")"),TAG:new RegExp("^("+L+"|[*])"),ATTR:new RegExp("^"+M),PSEUDO:new RegExp("^"+N),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+K+"*(even|odd|(([+-]|)(\\d*)n|)"+K+"*(?:([+-]|)"+K+"*(\\d+)|))"+K+"*\\)|)","i"),bool:new RegExp("^(?:"+J+")$","i"),needsContext:new RegExp("^"+K+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+K+"*((?:-\\d)?\\d*)"+K+"*\\)|)(?=[^-]|$)","i")},W=/^(?:input|select|textarea|button)$/i,X=/^h\d$/i,Y=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,$=/[+~]/,_=new RegExp("\\\\([\\da-f]{1,6}"+K+"?|("+K+")|.)","ig"),aa=function(a,b,c){var d="0x"+b-65536;return d!==d||c?b:d<0?String.fromCharCode(d+65536):String.fromCharCode(d>>10|55296,1023&d|56320)},ba=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\x80-\uFFFF\w-]/g,ca=function(a,b){return b?"\0"===a?"\ufffd":a.slice(0,-1)+"\\"+a.charCodeAt(a.length-1).toString(16)+" ":"\\"+a},da=function(){m()},ea=ta(function(a){return a.disabled===!0},{dir:"parentNode",next:"legend"});try{G.apply(D=H.call(v.childNodes),v.childNodes),D[v.childNodes.length].nodeType}catch(fa){G={apply:D.length?function(a,b){F.apply(a,H.call(b))}:function(a,b){var c=a.length,d=0;while(a[c++]=b[d++]);a.length=c-1}}}function ga(a,b,d,e){var f,h,j,k,l,o,r,s=b&&b.ownerDocument,w=b?b.nodeType:9;if(d=d||[],"string"!=typeof a||!a||1!==w&&9!==w&&11!==w)return d;if(!e&&((b?b.ownerDocument||b:v)!==n&&m(b),b=b||n,p)){if(11!==w&&(l=Z.exec(a)))if(f=l[1]){if(9===w){if(!(j=b.getElementById(f)))return d;if(j.id===f)return d.push(j),d}else if(s&&(j=s.getElementById(f))&&t(b,j)&&j.id===f)return d.push(j),d}else{if(l[2])return G.apply(d,b.getElementsByTagName(a)),d;if((f=l[3])&&c.getElementsByClassName&&b.getElementsByClassName)return G.apply(d,b.getElementsByClassName(f)),d}if(c.qsa&&!A[a+" "]&&(!q||!q.test(a))){if(1!==w)s=b,r=a;else if("object"!==b.nodeName.toLowerCase()){(k=b.getAttribute("id"))?k=k.replace(ba,ca):b.setAttribute("id",k=u),o=g(a),h=o.length;while(h--)o[h]="#"+k+" "+sa(o[h]);r=o.join(","),s=$.test(a)&&qa(b.parentNode)||b}if(r)try{return G.apply(d,s.querySelectorAll(r)),d}catch(x){}finally{k===u&&b.removeAttribute("id")}}}return i(a.replace(P,"$1"),b,d,e)}function ha(){var a=[];function b(c,e){return a.push(c+" ")>d.cacheLength&&delete b[a.shift()],b[c+" "]=e}return b}function ia(a){return a[u]=!0,a}function ja(a){var b=n.createElement("fieldset");try{return!!a(b)}catch(c){return!1}finally{b.parentNode&&b.parentNode.removeChild(b),b=null}}function ka(a,b){var c=a.split("|"),e=c.length;while(e--)d.attrHandle[c[e]]=b}function la(a,b){var c=b&&a,d=c&&1===a.nodeType&&1===b.nodeType&&a.sourceIndex-b.sourceIndex;if(d)return d;if(c)while(c=c.nextSibling)if(c===b)return-1;return a?1:-1}function ma(a){return function(b){var c=b.nodeName.toLowerCase();return"input"===c&&b.type===a}}function na(a){return function(b){var c=b.nodeName.toLowerCase();return("input"===c||"button"===c)&&b.type===a}}function oa(a){return function(b){return"label"in b&&b.disabled===a||"form"in b&&b.disabled===a||"form"in b&&b.disabled===!1&&(b.isDisabled===a||b.isDisabled!==!a&&("label"in b||!ea(b))!==a)}}function pa(a){return ia(function(b){return b=+b,ia(function(c,d){var e,f=a([],c.length,b),g=f.length;while(g--)c[e=f[g]]&&(c[e]=!(d[e]=c[e]))})})}function qa(a){return a&&"undefined"!=typeof a.getElementsByTagName&&a}c=ga.support={},f=ga.isXML=function(a){var b=a&&(a.ownerDocument||a).documentElement;return!!b&&"HTML"!==b.nodeName},m=ga.setDocument=function(a){var b,e,g=a?a.ownerDocument||a:v;return g!==n&&9===g.nodeType&&g.documentElement?(n=g,o=n.documentElement,p=!f(n),v!==n&&(e=n.defaultView)&&e.top!==e&&(e.addEventListener?e.addEventListener("unload",da,!1):e.attachEvent&&e.attachEvent("onunload",da)),c.attributes=ja(function(a){return a.className="i",!a.getAttribute("className")}),c.getElementsByTagName=ja(function(a){return a.appendChild(n.createComment("")),!a.getElementsByTagName("*").length}),c.getElementsByClassName=Y.test(n.getElementsByClassName),c.getById=ja(function(a){return o.appendChild(a).id=u,!n.getElementsByName||!n.getElementsByName(u).length}),c.getById?(d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c=b.getElementById(a);return c?[c]:[]}},d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){return a.getAttribute("id")===b}}):(delete d.find.ID,d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){var c="undefined"!=typeof a.getAttributeNode&&a.getAttributeNode("id");return c&&c.value===b}}),d.find.TAG=c.getElementsByTagName?function(a,b){return"undefined"!=typeof b.getElementsByTagName?b.getElementsByTagName(a):c.qsa?b.querySelectorAll(a):void 0}:function(a,b){var c,d=[],e=0,f=b.getElementsByTagName(a);if("*"===a){while(c=f[e++])1===c.nodeType&&d.push(c);return d}return f},d.find.CLASS=c.getElementsByClassName&&function(a,b){if("undefined"!=typeof b.getElementsByClassName&&p)return b.getElementsByClassName(a)},r=[],q=[],(c.qsa=Y.test(n.querySelectorAll))&&(ja(function(a){o.appendChild(a).innerHTML="",a.querySelectorAll("[msallowcapture^='']").length&&q.push("[*^$]="+K+"*(?:''|\"\")"),a.querySelectorAll("[selected]").length||q.push("\\["+K+"*(?:value|"+J+")"),a.querySelectorAll("[id~="+u+"-]").length||q.push("~="),a.querySelectorAll(":checked").length||q.push(":checked"),a.querySelectorAll("a#"+u+"+*").length||q.push(".#.+[+~]")}),ja(function(a){a.innerHTML="";var b=n.createElement("input");b.setAttribute("type","hidden"),a.appendChild(b).setAttribute("name","D"),a.querySelectorAll("[name=d]").length&&q.push("name"+K+"*[*^$|!~]?="),2!==a.querySelectorAll(":enabled").length&&q.push(":enabled",":disabled"),o.appendChild(a).disabled=!0,2!==a.querySelectorAll(":disabled").length&&q.push(":enabled",":disabled"),a.querySelectorAll("*,:x"),q.push(",.*:")})),(c.matchesSelector=Y.test(s=o.matches||o.webkitMatchesSelector||o.mozMatchesSelector||o.oMatchesSelector||o.msMatchesSelector))&&ja(function(a){c.disconnectedMatch=s.call(a,"*"),s.call(a,"[s!='']:x"),r.push("!=",N)}),q=q.length&&new RegExp(q.join("|")),r=r.length&&new RegExp(r.join("|")),b=Y.test(o.compareDocumentPosition),t=b||Y.test(o.contains)?function(a,b){var c=9===a.nodeType?a.documentElement:a,d=b&&b.parentNode;return a===d||!(!d||1!==d.nodeType||!(c.contains?c.contains(d):a.compareDocumentPosition&&16&a.compareDocumentPosition(d)))}:function(a,b){if(b)while(b=b.parentNode)if(b===a)return!0;return!1},B=b?function(a,b){if(a===b)return l=!0,0;var d=!a.compareDocumentPosition-!b.compareDocumentPosition;return d?d:(d=(a.ownerDocument||a)===(b.ownerDocument||b)?a.compareDocumentPosition(b):1,1&d||!c.sortDetached&&b.compareDocumentPosition(a)===d?a===n||a.ownerDocument===v&&t(v,a)?-1:b===n||b.ownerDocument===v&&t(v,b)?1:k?I(k,a)-I(k,b):0:4&d?-1:1)}:function(a,b){if(a===b)return l=!0,0;var c,d=0,e=a.parentNode,f=b.parentNode,g=[a],h=[b];if(!e||!f)return a===n?-1:b===n?1:e?-1:f?1:k?I(k,a)-I(k,b):0;if(e===f)return la(a,b);c=a;while(c=c.parentNode)g.unshift(c);c=b;while(c=c.parentNode)h.unshift(c);while(g[d]===h[d])d++;return d?la(g[d],h[d]):g[d]===v?-1:h[d]===v?1:0},n):n},ga.matches=function(a,b){return ga(a,null,null,b)},ga.matchesSelector=function(a,b){if((a.ownerDocument||a)!==n&&m(a),b=b.replace(S,"='$1']"),c.matchesSelector&&p&&!A[b+" "]&&(!r||!r.test(b))&&(!q||!q.test(b)))try{var d=s.call(a,b);if(d||c.disconnectedMatch||a.document&&11!==a.document.nodeType)return d}catch(e){}return ga(b,n,null,[a]).length>0},ga.contains=function(a,b){return(a.ownerDocument||a)!==n&&m(a),t(a,b)},ga.attr=function(a,b){(a.ownerDocument||a)!==n&&m(a);var e=d.attrHandle[b.toLowerCase()],f=e&&C.call(d.attrHandle,b.toLowerCase())?e(a,b,!p):void 0;return void 0!==f?f:c.attributes||!p?a.getAttribute(b):(f=a.getAttributeNode(b))&&f.specified?f.value:null},ga.escape=function(a){return(a+"").replace(ba,ca)},ga.error=function(a){throw new Error("Syntax error, unrecognized expression: "+a)},ga.uniqueSort=function(a){var b,d=[],e=0,f=0;if(l=!c.detectDuplicates,k=!c.sortStable&&a.slice(0),a.sort(B),l){while(b=a[f++])b===a[f]&&(e=d.push(f));while(e--)a.splice(d[e],1)}return k=null,a},e=ga.getText=function(a){var b,c="",d=0,f=a.nodeType;if(f){if(1===f||9===f||11===f){if("string"==typeof a.textContent)return a.textContent;for(a=a.firstChild;a;a=a.nextSibling)c+=e(a)}else if(3===f||4===f)return a.nodeValue}else while(b=a[d++])c+=e(b);return c},d=ga.selectors={cacheLength:50,createPseudo:ia,match:V,attrHandle:{},find:{},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(a){return a[1]=a[1].replace(_,aa),a[3]=(a[3]||a[4]||a[5]||"").replace(_,aa),"~="===a[2]&&(a[3]=" "+a[3]+" "),a.slice(0,4)},CHILD:function(a){return a[1]=a[1].toLowerCase(),"nth"===a[1].slice(0,3)?(a[3]||ga.error(a[0]),a[4]=+(a[4]?a[5]+(a[6]||1):2*("even"===a[3]||"odd"===a[3])),a[5]=+(a[7]+a[8]||"odd"===a[3])):a[3]&&ga.error(a[0]),a},PSEUDO:function(a){var b,c=!a[6]&&a[2];return V.CHILD.test(a[0])?null:(a[3]?a[2]=a[4]||a[5]||"":c&&T.test(c)&&(b=g(c,!0))&&(b=c.indexOf(")",c.length-b)-c.length)&&(a[0]=a[0].slice(0,b),a[2]=c.slice(0,b)),a.slice(0,3))}},filter:{TAG:function(a){var b=a.replace(_,aa).toLowerCase();return"*"===a?function(){return!0}:function(a){return a.nodeName&&a.nodeName.toLowerCase()===b}},CLASS:function(a){var b=y[a+" "];return b||(b=new RegExp("(^|"+K+")"+a+"("+K+"|$)"))&&y(a,function(a){return b.test("string"==typeof a.className&&a.className||"undefined"!=typeof a.getAttribute&&a.getAttribute("class")||"")})},ATTR:function(a,b,c){return function(d){var e=ga.attr(d,a);return null==e?"!="===b:!b||(e+="","="===b?e===c:"!="===b?e!==c:"^="===b?c&&0===e.indexOf(c):"*="===b?c&&e.indexOf(c)>-1:"$="===b?c&&e.slice(-c.length)===c:"~="===b?(" "+e.replace(O," ")+" ").indexOf(c)>-1:"|="===b&&(e===c||e.slice(0,c.length+1)===c+"-"))}},CHILD:function(a,b,c,d,e){var f="nth"!==a.slice(0,3),g="last"!==a.slice(-4),h="of-type"===b;return 1===d&&0===e?function(a){return!!a.parentNode}:function(b,c,i){var j,k,l,m,n,o,p=f!==g?"nextSibling":"previousSibling",q=b.parentNode,r=h&&b.nodeName.toLowerCase(),s=!i&&!h,t=!1;if(q){if(f){while(p){m=b;while(m=m[p])if(h?m.nodeName.toLowerCase()===r:1===m.nodeType)return!1;o=p="only"===a&&!o&&"nextSibling"}return!0}if(o=[g?q.firstChild:q.lastChild],g&&s){m=q,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n&&j[2],m=n&&q.childNodes[n];while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if(1===m.nodeType&&++t&&m===b){k[a]=[w,n,t];break}}else if(s&&(m=b,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n),t===!1)while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if((h?m.nodeName.toLowerCase()===r:1===m.nodeType)&&++t&&(s&&(l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),k[a]=[w,t]),m===b))break;return t-=e,t===d||t%d===0&&t/d>=0}}},PSEUDO:function(a,b){var c,e=d.pseudos[a]||d.setFilters[a.toLowerCase()]||ga.error("unsupported pseudo: "+a);return e[u]?e(b):e.length>1?(c=[a,a,"",b],d.setFilters.hasOwnProperty(a.toLowerCase())?ia(function(a,c){var d,f=e(a,b),g=f.length;while(g--)d=I(a,f[g]),a[d]=!(c[d]=f[g])}):function(a){return e(a,0,c)}):e}},pseudos:{not:ia(function(a){var b=[],c=[],d=h(a.replace(P,"$1"));return d[u]?ia(function(a,b,c,e){var f,g=d(a,null,e,[]),h=a.length;while(h--)(f=g[h])&&(a[h]=!(b[h]=f))}):function(a,e,f){return b[0]=a,d(b,null,f,c),b[0]=null,!c.pop()}}),has:ia(function(a){return function(b){return ga(a,b).length>0}}),contains:ia(function(a){return a=a.replace(_,aa),function(b){return(b.textContent||b.innerText||e(b)).indexOf(a)>-1}}),lang:ia(function(a){return U.test(a||"")||ga.error("unsupported lang: "+a),a=a.replace(_,aa).toLowerCase(),function(b){var c;do if(c=p?b.lang:b.getAttribute("xml:lang")||b.getAttribute("lang"))return c=c.toLowerCase(),c===a||0===c.indexOf(a+"-");while((b=b.parentNode)&&1===b.nodeType);return!1}}),target:function(b){var c=a.location&&a.location.hash;return c&&c.slice(1)===b.id},root:function(a){return a===o},focus:function(a){return a===n.activeElement&&(!n.hasFocus||n.hasFocus())&&!!(a.type||a.href||~a.tabIndex)},enabled:oa(!1),disabled:oa(!0),checked:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&!!a.checked||"option"===b&&!!a.selected},selected:function(a){return a.parentNode&&a.parentNode.selectedIndex,a.selected===!0},empty:function(a){for(a=a.firstChild;a;a=a.nextSibling)if(a.nodeType<6)return!1;return!0},parent:function(a){return!d.pseudos.empty(a)},header:function(a){return X.test(a.nodeName)},input:function(a){return W.test(a.nodeName)},button:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&"button"===a.type||"button"===b},text:function(a){var b;return"input"===a.nodeName.toLowerCase()&&"text"===a.type&&(null==(b=a.getAttribute("type"))||"text"===b.toLowerCase())},first:pa(function(){return[0]}),last:pa(function(a,b){return[b-1]}),eq:pa(function(a,b,c){return[c<0?c+b:c]}),even:pa(function(a,b){for(var c=0;c=0;)a.push(d);return a}),gt:pa(function(a,b,c){for(var d=c<0?c+b:c;++d1?function(b,c,d){var e=a.length;while(e--)if(!a[e](b,c,d))return!1;return!0}:a[0]}function va(a,b,c){for(var d=0,e=b.length;d-1&&(f[j]=!(g[j]=l))}}else r=wa(r===g?r.splice(o,r.length):r),e?e(null,g,r,i):G.apply(g,r)})}function ya(a){for(var b,c,e,f=a.length,g=d.relative[a[0].type],h=g||d.relative[" "],i=g?1:0,k=ta(function(a){return a===b},h,!0),l=ta(function(a){return I(b,a)>-1},h,!0),m=[function(a,c,d){var e=!g&&(d||c!==j)||((b=c).nodeType?k(a,c,d):l(a,c,d));return b=null,e}];i1&&ua(m),i>1&&sa(a.slice(0,i-1).concat({value:" "===a[i-2].type?"*":""})).replace(P,"$1"),c,i0,e=a.length>0,f=function(f,g,h,i,k){var l,o,q,r=0,s="0",t=f&&[],u=[],v=j,x=f||e&&d.find.TAG("*",k),y=w+=null==v?1:Math.random()||.1,z=x.length;for(k&&(j=g===n||g||k);s!==z&&null!=(l=x[s]);s++){if(e&&l){o=0,g||l.ownerDocument===n||(m(l),h=!p);while(q=a[o++])if(q(l,g||n,h)){i.push(l);break}k&&(w=y)}c&&((l=!q&&l)&&r--,f&&t.push(l))}if(r+=s,c&&s!==r){o=0;while(q=b[o++])q(t,u,g,h);if(f){if(r>0)while(s--)t[s]||u[s]||(u[s]=E.call(i));u=wa(u)}G.apply(i,u),k&&!f&&u.length>0&&r+b.length>1&&ga.uniqueSort(i)}return k&&(w=y,j=v),t};return c?ia(f):f}return h=ga.compile=function(a,b){var c,d=[],e=[],f=A[a+" "];if(!f){b||(b=g(a)),c=b.length;while(c--)f=ya(b[c]),f[u]?d.push(f):e.push(f);f=A(a,za(e,d)),f.selector=a}return f},i=ga.select=function(a,b,e,f){var i,j,k,l,m,n="function"==typeof a&&a,o=!f&&g(a=n.selector||a);if(e=e||[],1===o.length){if(j=o[0]=o[0].slice(0),j.length>2&&"ID"===(k=j[0]).type&&c.getById&&9===b.nodeType&&p&&d.relative[j[1].type]){if(b=(d.find.ID(k.matches[0].replace(_,aa),b)||[])[0],!b)return e;n&&(b=b.parentNode),a=a.slice(j.shift().value.length)}i=V.needsContext.test(a)?0:j.length;while(i--){if(k=j[i],d.relative[l=k.type])break;if((m=d.find[l])&&(f=m(k.matches[0].replace(_,aa),$.test(j[0].type)&&qa(b.parentNode)||b))){if(j.splice(i,1),a=f.length&&sa(j),!a)return G.apply(e,f),e;break}}}return(n||h(a,o))(f,b,!p,e,!b||$.test(a)&&qa(b.parentNode)||b),e},c.sortStable=u.split("").sort(B).join("")===u,c.detectDuplicates=!!l,m(),c.sortDetached=ja(function(a){return 1&a.compareDocumentPosition(n.createElement("fieldset"))}),ja(function(a){return a.innerHTML="","#"===a.firstChild.getAttribute("href")})||ka("type|href|height|width",function(a,b,c){if(!c)return a.getAttribute(b,"type"===b.toLowerCase()?1:2)}),c.attributes&&ja(function(a){return a.innerHTML="",a.firstChild.setAttribute("value",""),""===a.firstChild.getAttribute("value")})||ka("value",function(a,b,c){if(!c&&"input"===a.nodeName.toLowerCase())return a.defaultValue}),ja(function(a){return null==a.getAttribute("disabled")})||ka(J,function(a,b,c){var d;if(!c)return a[b]===!0?b.toLowerCase():(d=a.getAttributeNode(b))&&d.specified?d.value:null}),ga}(a);r.find=x,r.expr=x.selectors,r.expr[":"]=r.expr.pseudos,r.uniqueSort=r.unique=x.uniqueSort,r.text=x.getText,r.isXMLDoc=x.isXML,r.contains=x.contains,r.escapeSelector=x.escape;var y=function(a,b,c){var d=[],e=void 0!==c;while((a=a[b])&&9!==a.nodeType)if(1===a.nodeType){if(e&&r(a).is(c))break;d.push(a)}return d},z=function(a,b){for(var c=[];a;a=a.nextSibling)1===a.nodeType&&a!==b&&c.push(a);return c},A=r.expr.match.needsContext,B=/^<([a-z][^\/\0>:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i,C=/^.[^:#\[\.,]*$/;function D(a,b,c){if(r.isFunction(b))return r.grep(a,function(a,d){return!!b.call(a,d,a)!==c});if(b.nodeType)return r.grep(a,function(a){return a===b!==c});if("string"==typeof b){if(C.test(b))return r.filter(b,a,c);b=r.filter(b,a)}return r.grep(a,function(a){return i.call(b,a)>-1!==c&&1===a.nodeType})}r.filter=function(a,b,c){var d=b[0];return c&&(a=":not("+a+")"),1===b.length&&1===d.nodeType?r.find.matchesSelector(d,a)?[d]:[]:r.find.matches(a,r.grep(b,function(a){return 1===a.nodeType}))},r.fn.extend({find:function(a){var b,c,d=this.length,e=this;if("string"!=typeof a)return this.pushStack(r(a).filter(function(){for(b=0;b1?r.uniqueSort(c):c},filter:function(a){return this.pushStack(D(this,a||[],!1))},not:function(a){return this.pushStack(D(this,a||[],!0))},is:function(a){return!!D(this,"string"==typeof a&&A.test(a)?r(a):a||[],!1).length}});var E,F=/^(?:\s*(<[\w\W]+>)[^>]*|#([\w-]+))$/,G=r.fn.init=function(a,b,c){var e,f;if(!a)return this;if(c=c||E,"string"==typeof a){if(e="<"===a[0]&&">"===a[a.length-1]&&a.length>=3?[null,a,null]:F.exec(a),!e||!e[1]&&b)return!b||b.jquery?(b||c).find(a):this.constructor(b).find(a);if(e[1]){if(b=b instanceof r?b[0]:b,r.merge(this,r.parseHTML(e[1],b&&b.nodeType?b.ownerDocument||b:d,!0)),B.test(e[1])&&r.isPlainObject(b))for(e in b)r.isFunction(this[e])?this[e](b[e]):this.attr(e,b[e]);return this}return f=d.getElementById(e[2]),f&&(this[0]=f,this.length=1),this}return a.nodeType?(this[0]=a,this.length=1,this):r.isFunction(a)?void 0!==c.ready?c.ready(a):a(r):r.makeArray(a,this)};G.prototype=r.fn,E=r(d);var H=/^(?:parents|prev(?:Until|All))/,I={children:!0,contents:!0,next:!0,prev:!0};r.fn.extend({has:function(a){var b=r(a,this),c=b.length;return this.filter(function(){for(var a=0;a-1:1===c.nodeType&&r.find.matchesSelector(c,a))){f.push(c);break}return this.pushStack(f.length>1?r.uniqueSort(f):f)},index:function(a){return a?"string"==typeof a?i.call(r(a),this[0]):i.call(this,a.jquery?a[0]:a):this[0]&&this[0].parentNode?this.first().prevAll().length:-1},add:function(a,b){return this.pushStack(r.uniqueSort(r.merge(this.get(),r(a,b))))},addBack:function(a){return this.add(null==a?this.prevObject:this.prevObject.filter(a))}});function J(a,b){while((a=a[b])&&1!==a.nodeType);return a}r.each({parent:function(a){var b=a.parentNode;return b&&11!==b.nodeType?b:null},parents:function(a){return y(a,"parentNode")},parentsUntil:function(a,b,c){return y(a,"parentNode",c)},next:function(a){return J(a,"nextSibling")},prev:function(a){return J(a,"previousSibling")},nextAll:function(a){return y(a,"nextSibling")},prevAll:function(a){return y(a,"previousSibling")},nextUntil:function(a,b,c){return y(a,"nextSibling",c)},prevUntil:function(a,b,c){return y(a,"previousSibling",c)},siblings:function(a){return z((a.parentNode||{}).firstChild,a)},children:function(a){return z(a.firstChild)},contents:function(a){return a.contentDocument||r.merge([],a.childNodes)}},function(a,b){r.fn[a]=function(c,d){var e=r.map(this,b,c);return"Until"!==a.slice(-5)&&(d=c),d&&"string"==typeof d&&(e=r.filter(d,e)),this.length>1&&(I[a]||r.uniqueSort(e),H.test(a)&&e.reverse()),this.pushStack(e)}});var K=/\S+/g;function L(a){var b={};return r.each(a.match(K)||[],function(a,c){b[c]=!0}),b}r.Callbacks=function(a){a="string"==typeof a?L(a):r.extend({},a);var b,c,d,e,f=[],g=[],h=-1,i=function(){for(e=a.once,d=b=!0;g.length;h=-1){c=g.shift();while(++h-1)f.splice(c,1),c<=h&&h--}),this},has:function(a){return a?r.inArray(a,f)>-1:f.length>0},empty:function(){return f&&(f=[]),this},disable:function(){return e=g=[],f=c="",this},disabled:function(){return!f},lock:function(){return e=g=[],c||b||(f=c=""),this},locked:function(){return!!e},fireWith:function(a,c){return e||(c=c||[],c=[a,c.slice?c.slice():c],g.push(c),b||i()),this},fire:function(){return j.fireWith(this,arguments),this},fired:function(){return!!d}};return j};function M(a){return a}function N(a){throw a}function O(a,b,c){var d;try{a&&r.isFunction(d=a.promise)?d.call(a).done(b).fail(c):a&&r.isFunction(d=a.then)?d.call(a,b,c):b.call(void 0,a)}catch(a){c.call(void 0,a)}}r.extend({Deferred:function(b){var c=[["notify","progress",r.Callbacks("memory"),r.Callbacks("memory"),2],["resolve","done",r.Callbacks("once memory"),r.Callbacks("once memory"),0,"resolved"],["reject","fail",r.Callbacks("once memory"),r.Callbacks("once memory"),1,"rejected"]],d="pending",e={state:function(){return d},always:function(){return f.done(arguments).fail(arguments),this},"catch":function(a){return e.then(null,a)},pipe:function(){var a=arguments;return r.Deferred(function(b){r.each(c,function(c,d){var e=r.isFunction(a[d[4]])&&a[d[4]];f[d[1]](function(){var a=e&&e.apply(this,arguments);a&&r.isFunction(a.promise)?a.promise().progress(b.notify).done(b.resolve).fail(b.reject):b[d[0]+"With"](this,e?[a]:arguments)})}),a=null}).promise()},then:function(b,d,e){var f=0;function g(b,c,d,e){return function(){var h=this,i=arguments,j=function(){var a,j;if(!(b=f&&(d!==N&&(h=void 0,i=[a]),c.rejectWith(h,i))}};b?k():(r.Deferred.getStackHook&&(k.stackTrace=r.Deferred.getStackHook()),a.setTimeout(k))}}return r.Deferred(function(a){c[0][3].add(g(0,a,r.isFunction(e)?e:M,a.notifyWith)),c[1][3].add(g(0,a,r.isFunction(b)?b:M)),c[2][3].add(g(0,a,r.isFunction(d)?d:N))}).promise()},promise:function(a){return null!=a?r.extend(a,e):e}},f={};return r.each(c,function(a,b){var g=b[2],h=b[5];e[b[1]]=g.add,h&&g.add(function(){d=h},c[3-a][2].disable,c[0][2].lock),g.add(b[3].fire),f[b[0]]=function(){return f[b[0]+"With"](this===f?void 0:this,arguments),this},f[b[0]+"With"]=g.fireWith}),e.promise(f),b&&b.call(f,f),f},when:function(a){var b=arguments.length,c=b,d=Array(c),e=f.call(arguments),g=r.Deferred(),h=function(a){return function(c){d[a]=this,e[a]=arguments.length>1?f.call(arguments):c,--b||g.resolveWith(d,e)}};if(b<=1&&(O(a,g.done(h(c)).resolve,g.reject),"pending"===g.state()||r.isFunction(e[c]&&e[c].then)))return g.then();while(c--)O(e[c],h(c),g.reject);return g.promise()}});var P=/^(Eval|Internal|Range|Reference|Syntax|Type|URI)Error$/;r.Deferred.exceptionHook=function(b,c){a.console&&a.console.warn&&b&&P.test(b.name)&&a.console.warn("jQuery.Deferred exception: "+b.message,b.stack,c)},r.readyException=function(b){a.setTimeout(function(){throw b})};var Q=r.Deferred();r.fn.ready=function(a){return Q.then(a)["catch"](function(a){r.readyException(a)}),this},r.extend({isReady:!1,readyWait:1,holdReady:function(a){a?r.readyWait++:r.ready(!0)},ready:function(a){(a===!0?--r.readyWait:r.isReady)||(r.isReady=!0,a!==!0&&--r.readyWait>0||Q.resolveWith(d,[r]))}}),r.ready.then=Q.then;function R(){d.removeEventListener("DOMContentLoaded",R),a.removeEventListener("load",R),r.ready()}"complete"===d.readyState||"loading"!==d.readyState&&!d.documentElement.doScroll?a.setTimeout(r.ready):(d.addEventListener("DOMContentLoaded",R), +a.addEventListener("load",R));var S=function(a,b,c,d,e,f,g){var h=0,i=a.length,j=null==c;if("object"===r.type(c)){e=!0;for(h in c)S(a,b,h,c[h],!0,f,g)}else if(void 0!==d&&(e=!0,r.isFunction(d)||(g=!0),j&&(g?(b.call(a,d),b=null):(j=b,b=function(a,b,c){return j.call(r(a),c)})),b))for(;h1,null,!0)},removeData:function(a){return this.each(function(){W.remove(this,a)})}}),r.extend({queue:function(a,b,c){var d;if(a)return b=(b||"fx")+"queue",d=V.get(a,b),c&&(!d||r.isArray(c)?d=V.access(a,b,r.makeArray(c)):d.push(c)),d||[]},dequeue:function(a,b){b=b||"fx";var c=r.queue(a,b),d=c.length,e=c.shift(),f=r._queueHooks(a,b),g=function(){r.dequeue(a,b)};"inprogress"===e&&(e=c.shift(),d--),e&&("fx"===b&&c.unshift("inprogress"),delete f.stop,e.call(a,g,f)),!d&&f&&f.empty.fire()},_queueHooks:function(a,b){var c=b+"queueHooks";return V.get(a,c)||V.access(a,c,{empty:r.Callbacks("once memory").add(function(){V.remove(a,[b+"queue",c])})})}}),r.fn.extend({queue:function(a,b){var c=2;return"string"!=typeof a&&(b=a,a="fx",c--),arguments.length\x20\t\r\n\f]+)/i,ja=/^$|\/(?:java|ecma)script/i,ka={option:[1,""],thead:[1,"","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};ka.optgroup=ka.option,ka.tbody=ka.tfoot=ka.colgroup=ka.caption=ka.thead,ka.th=ka.td;function la(a,b){var c="undefined"!=typeof a.getElementsByTagName?a.getElementsByTagName(b||"*"):"undefined"!=typeof a.querySelectorAll?a.querySelectorAll(b||"*"):[];return void 0===b||b&&r.nodeName(a,b)?r.merge([a],c):c}function ma(a,b){for(var c=0,d=a.length;c-1)e&&e.push(f);else if(j=r.contains(f.ownerDocument,f),g=la(l.appendChild(f),"script"),j&&ma(g),c){k=0;while(f=g[k++])ja.test(f.type||"")&&c.push(f)}return l}!function(){var a=d.createDocumentFragment(),b=a.appendChild(d.createElement("div")),c=d.createElement("input");c.setAttribute("type","radio"),c.setAttribute("checked","checked"),c.setAttribute("name","t"),b.appendChild(c),o.checkClone=b.cloneNode(!0).cloneNode(!0).lastChild.checked,b.innerHTML="",o.noCloneChecked=!!b.cloneNode(!0).lastChild.defaultValue}();var pa=d.documentElement,qa=/^key/,ra=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,sa=/^([^.]*)(?:\.(.+)|)/;function ta(){return!0}function ua(){return!1}function va(){try{return d.activeElement}catch(a){}}function wa(a,b,c,d,e,f){var g,h;if("object"==typeof b){"string"!=typeof c&&(d=d||c,c=void 0);for(h in b)wa(a,h,c,d,b[h],f);return a}if(null==d&&null==e?(e=c,d=c=void 0):null==e&&("string"==typeof c?(e=d,d=void 0):(e=d,d=c,c=void 0)),e===!1)e=ua;else if(!e)return a;return 1===f&&(g=e,e=function(a){return r().off(a),g.apply(this,arguments)},e.guid=g.guid||(g.guid=r.guid++)),a.each(function(){r.event.add(this,b,e,d,c)})}r.event={global:{},add:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.get(a);if(q){c.handler&&(f=c,c=f.handler,e=f.selector),e&&r.find.matchesSelector(pa,e),c.guid||(c.guid=r.guid++),(i=q.events)||(i=q.events={}),(g=q.handle)||(g=q.handle=function(b){return"undefined"!=typeof r&&r.event.triggered!==b.type?r.event.dispatch.apply(a,arguments):void 0}),b=(b||"").match(K)||[""],j=b.length;while(j--)h=sa.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n&&(l=r.event.special[n]||{},n=(e?l.delegateType:l.bindType)||n,l=r.event.special[n]||{},k=r.extend({type:n,origType:p,data:d,handler:c,guid:c.guid,selector:e,needsContext:e&&r.expr.match.needsContext.test(e),namespace:o.join(".")},f),(m=i[n])||(m=i[n]=[],m.delegateCount=0,l.setup&&l.setup.call(a,d,o,g)!==!1||a.addEventListener&&a.addEventListener(n,g)),l.add&&(l.add.call(a,k),k.handler.guid||(k.handler.guid=c.guid)),e?m.splice(m.delegateCount++,0,k):m.push(k),r.event.global[n]=!0)}},remove:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.hasData(a)&&V.get(a);if(q&&(i=q.events)){b=(b||"").match(K)||[""],j=b.length;while(j--)if(h=sa.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n){l=r.event.special[n]||{},n=(d?l.delegateType:l.bindType)||n,m=i[n]||[],h=h[2]&&new RegExp("(^|\\.)"+o.join("\\.(?:.*\\.|)")+"(\\.|$)"),g=f=m.length;while(f--)k=m[f],!e&&p!==k.origType||c&&c.guid!==k.guid||h&&!h.test(k.namespace)||d&&d!==k.selector&&("**"!==d||!k.selector)||(m.splice(f,1),k.selector&&m.delegateCount--,l.remove&&l.remove.call(a,k));g&&!m.length&&(l.teardown&&l.teardown.call(a,o,q.handle)!==!1||r.removeEvent(a,n,q.handle),delete i[n])}else for(n in i)r.event.remove(a,n+b[j],c,d,!0);r.isEmptyObject(i)&&V.remove(a,"handle events")}},dispatch:function(a){var b=r.event.fix(a),c,d,e,f,g,h,i=new Array(arguments.length),j=(V.get(this,"events")||{})[b.type]||[],k=r.event.special[b.type]||{};for(i[0]=b,c=1;c-1:r.find(e,this,null,[i]).length),d[e]&&d.push(f);d.length&&g.push({elem:i,handlers:d})}return h\x20\t\r\n\f]*)[^>]*)\/>/gi,ya=/\s*$/g;function Ca(a,b){return r.nodeName(a,"table")&&r.nodeName(11!==b.nodeType?b:b.firstChild,"tr")?a.getElementsByTagName("tbody")[0]||a:a}function Da(a){return a.type=(null!==a.getAttribute("type"))+"/"+a.type,a}function Ea(a){var b=Aa.exec(a.type);return b?a.type=b[1]:a.removeAttribute("type"),a}function Fa(a,b){var c,d,e,f,g,h,i,j;if(1===b.nodeType){if(V.hasData(a)&&(f=V.access(a),g=V.set(b,f),j=f.events)){delete g.handle,g.events={};for(e in j)for(c=0,d=j[e].length;c1&&"string"==typeof q&&!o.checkClone&&za.test(q))return a.each(function(e){var f=a.eq(e);s&&(b[0]=q.call(this,e,f.html())),Ha(f,b,c,d)});if(m&&(e=oa(b,a[0].ownerDocument,!1,a,d),f=e.firstChild,1===e.childNodes.length&&(e=f),f||d)){for(h=r.map(la(e,"script"),Da),i=h.length;l")},clone:function(a,b,c){var d,e,f,g,h=a.cloneNode(!0),i=r.contains(a.ownerDocument,a);if(!(o.noCloneChecked||1!==a.nodeType&&11!==a.nodeType||r.isXMLDoc(a)))for(g=la(h),f=la(a),d=0,e=f.length;d0&&ma(g,!i&&la(a,"script")),h},cleanData:function(a){for(var b,c,d,e=r.event.special,f=0;void 0!==(c=a[f]);f++)if(T(c)){if(b=c[V.expando]){if(b.events)for(d in b.events)e[d]?r.event.remove(c,d):r.removeEvent(c,d,b.handle);c[V.expando]=void 0}c[W.expando]&&(c[W.expando]=void 0)}}}),r.fn.extend({detach:function(a){return Ia(this,a,!0)},remove:function(a){return Ia(this,a)},text:function(a){return S(this,function(a){return void 0===a?r.text(this):this.empty().each(function(){1!==this.nodeType&&11!==this.nodeType&&9!==this.nodeType||(this.textContent=a)})},null,a,arguments.length)},append:function(){return Ha(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ca(this,a);b.appendChild(a)}})},prepend:function(){return Ha(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ca(this,a);b.insertBefore(a,b.firstChild)}})},before:function(){return Ha(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this)})},after:function(){return Ha(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this.nextSibling)})},empty:function(){for(var a,b=0;null!=(a=this[b]);b++)1===a.nodeType&&(r.cleanData(la(a,!1)),a.textContent="");return this},clone:function(a,b){return a=null!=a&&a,b=null==b?a:b,this.map(function(){return r.clone(this,a,b)})},html:function(a){return S(this,function(a){var b=this[0]||{},c=0,d=this.length;if(void 0===a&&1===b.nodeType)return b.innerHTML;if("string"==typeof a&&!ya.test(a)&&!ka[(ia.exec(a)||["",""])[1].toLowerCase()]){a=r.htmlPrefilter(a);try{for(;c1)}}),r.fn.delay=function(b,c){return b=r.fx?r.fx.speeds[b]||b:b,c=c||"fx",this.queue(c,function(c,d){var e=a.setTimeout(c,b);d.stop=function(){a.clearTimeout(e)}})},function(){var a=d.createElement("input"),b=d.createElement("select"),c=b.appendChild(d.createElement("option"));a.type="checkbox",o.checkOn=""!==a.value,o.optSelected=c.selected,a=d.createElement("input"),a.value="t",a.type="radio",o.radioValue="t"===a.value}();var Xa,Ya=r.expr.attrHandle;r.fn.extend({attr:function(a,b){return S(this,r.attr,a,b,arguments.length>1)},removeAttr:function(a){return this.each(function(){r.removeAttr(this,a)})}}),r.extend({attr:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return"undefined"==typeof a.getAttribute?r.prop(a,b,c):(1===f&&r.isXMLDoc(a)||(e=r.attrHooks[b.toLowerCase()]||(r.expr.match.bool.test(b)?Xa:void 0)),void 0!==c?null===c?void r.removeAttr(a,b):e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:(a.setAttribute(b,c+""),c):e&&"get"in e&&null!==(d=e.get(a,b))?d:(d=r.find.attr(a,b),null==d?void 0:d))},attrHooks:{type:{set:function(a,b){if(!o.radioValue&&"radio"===b&&r.nodeName(a,"input")){var c=a.value;return a.setAttribute("type",b),c&&(a.value=c),b}}}},removeAttr:function(a,b){var c,d=0,e=b&&b.match(K);if(e&&1===a.nodeType)while(c=e[d++])a.removeAttribute(c)}}),Xa={set:function(a,b,c){return b===!1?r.removeAttr(a,c):a.setAttribute(c,c),c}},r.each(r.expr.match.bool.source.match(/\w+/g),function(a,b){var c=Ya[b]||r.find.attr;Ya[b]=function(a,b,d){var e,f,g=b.toLowerCase();return d||(f=Ya[g],Ya[g]=e,e=null!=c(a,b,d)?g:null,Ya[g]=f),e}});var Za=/^(?:input|select|textarea|button)$/i,$a=/^(?:a|area)$/i;r.fn.extend({prop:function(a,b){return S(this,r.prop,a,b,arguments.length>1)},removeProp:function(a){return this.each(function(){delete this[r.propFix[a]||a]})}}),r.extend({prop:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return 1===f&&r.isXMLDoc(a)||(b=r.propFix[b]||b,e=r.propHooks[b]),void 0!==c?e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:a[b]=c:e&&"get"in e&&null!==(d=e.get(a,b))?d:a[b]},propHooks:{tabIndex:{get:function(a){var b=r.find.attr(a,"tabindex");return b?parseInt(b,10):Za.test(a.nodeName)||$a.test(a.nodeName)&&a.href?0:-1}}},propFix:{"for":"htmlFor","class":"className"}}),o.optSelected||(r.propHooks.selected={get:function(a){var b=a.parentNode;return b&&b.parentNode&&b.parentNode.selectedIndex,null},set:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}}),r.each(["tabIndex","readOnly","maxLength","cellSpacing","cellPadding","rowSpan","colSpan","useMap","frameBorder","contentEditable"],function(){r.propFix[this.toLowerCase()]=this});var _a=/[\t\r\n\f]/g;function ab(a){return a.getAttribute&&a.getAttribute("class")||""}r.fn.extend({addClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).addClass(a.call(this,b,ab(this)))});if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=ab(c),d=1===c.nodeType&&(" "+e+" ").replace(_a," ")){g=0;while(f=b[g++])d.indexOf(" "+f+" ")<0&&(d+=f+" ");h=r.trim(d),e!==h&&c.setAttribute("class",h)}}return this},removeClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).removeClass(a.call(this,b,ab(this)))});if(!arguments.length)return this.attr("class","");if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=ab(c),d=1===c.nodeType&&(" "+e+" ").replace(_a," ")){g=0;while(f=b[g++])while(d.indexOf(" "+f+" ")>-1)d=d.replace(" "+f+" "," ");h=r.trim(d),e!==h&&c.setAttribute("class",h)}}return this},toggleClass:function(a,b){var c=typeof a;return"boolean"==typeof b&&"string"===c?b?this.addClass(a):this.removeClass(a):r.isFunction(a)?this.each(function(c){r(this).toggleClass(a.call(this,c,ab(this),b),b)}):this.each(function(){var b,d,e,f;if("string"===c){d=0,e=r(this),f=a.match(K)||[];while(b=f[d++])e.hasClass(b)?e.removeClass(b):e.addClass(b)}else void 0!==a&&"boolean"!==c||(b=ab(this),b&&V.set(this,"__className__",b),this.setAttribute&&this.setAttribute("class",b||a===!1?"":V.get(this,"__className__")||""))})},hasClass:function(a){var b,c,d=0;b=" "+a+" ";while(c=this[d++])if(1===c.nodeType&&(" "+ab(c)+" ").replace(_a," ").indexOf(b)>-1)return!0;return!1}});var bb=/\r/g,cb=/[\x20\t\r\n\f]+/g;r.fn.extend({val:function(a){var b,c,d,e=this[0];{if(arguments.length)return d=r.isFunction(a),this.each(function(c){var e;1===this.nodeType&&(e=d?a.call(this,c,r(this).val()):a,null==e?e="":"number"==typeof e?e+="":r.isArray(e)&&(e=r.map(e,function(a){return null==a?"":a+""})),b=r.valHooks[this.type]||r.valHooks[this.nodeName.toLowerCase()],b&&"set"in b&&void 0!==b.set(this,e,"value")||(this.value=e))});if(e)return b=r.valHooks[e.type]||r.valHooks[e.nodeName.toLowerCase()],b&&"get"in b&&void 0!==(c=b.get(e,"value"))?c:(c=e.value,"string"==typeof c?c.replace(bb,""):null==c?"":c)}}}),r.extend({valHooks:{option:{get:function(a){var b=r.find.attr(a,"value");return null!=b?b:r.trim(r.text(a)).replace(cb," ")}},select:{get:function(a){for(var b,c,d=a.options,e=a.selectedIndex,f="select-one"===a.type,g=f?null:[],h=f?e+1:d.length,i=e<0?h:f?e:0;i-1)&&(c=!0);return c||(a.selectedIndex=-1),f}}}}),r.each(["radio","checkbox"],function(){r.valHooks[this]={set:function(a,b){if(r.isArray(b))return a.checked=r.inArray(r(a).val(),b)>-1}},o.checkOn||(r.valHooks[this].get=function(a){return null===a.getAttribute("value")?"on":a.value})});var db=/^(?:focusinfocus|focusoutblur)$/;r.extend(r.event,{trigger:function(b,c,e,f){var g,h,i,j,k,m,n,o=[e||d],p=l.call(b,"type")?b.type:b,q=l.call(b,"namespace")?b.namespace.split("."):[];if(h=i=e=e||d,3!==e.nodeType&&8!==e.nodeType&&!db.test(p+r.event.triggered)&&(p.indexOf(".")>-1&&(q=p.split("."),p=q.shift(),q.sort()),k=p.indexOf(":")<0&&"on"+p,b=b[r.expando]?b:new r.Event(p,"object"==typeof b&&b),b.isTrigger=f?2:3,b.namespace=q.join("."),b.rnamespace=b.namespace?new RegExp("(^|\\.)"+q.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,b.result=void 0,b.target||(b.target=e),c=null==c?[b]:r.makeArray(c,[b]),n=r.event.special[p]||{},f||!n.trigger||n.trigger.apply(e,c)!==!1)){if(!f&&!n.noBubble&&!r.isWindow(e)){for(j=n.delegateType||p,db.test(j+p)||(h=h.parentNode);h;h=h.parentNode)o.push(h),i=h;i===(e.ownerDocument||d)&&o.push(i.defaultView||i.parentWindow||a)}g=0;while((h=o[g++])&&!b.isPropagationStopped())b.type=g>1?j:n.bindType||p,m=(V.get(h,"events")||{})[b.type]&&V.get(h,"handle"),m&&m.apply(h,c),m=k&&h[k],m&&m.apply&&T(h)&&(b.result=m.apply(h,c),b.result===!1&&b.preventDefault());return b.type=p,f||b.isDefaultPrevented()||n._default&&n._default.apply(o.pop(),c)!==!1||!T(e)||k&&r.isFunction(e[p])&&!r.isWindow(e)&&(i=e[k],i&&(e[k]=null),r.event.triggered=p,e[p](),r.event.triggered=void 0,i&&(e[k]=i)),b.result}},simulate:function(a,b,c){var d=r.extend(new r.Event,c,{type:a,isSimulated:!0});r.event.trigger(d,null,b)}}),r.fn.extend({trigger:function(a,b){return this.each(function(){r.event.trigger(a,b,this)})},triggerHandler:function(a,b){var c=this[0];if(c)return r.event.trigger(a,b,c,!0)}}),r.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(a,b){r.fn[b]=function(a,c){return arguments.length>0?this.on(b,null,a,c):this.trigger(b)}}),r.fn.extend({hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}}),o.focusin="onfocusin"in a,o.focusin||r.each({focus:"focusin",blur:"focusout"},function(a,b){var c=function(a){r.event.simulate(b,a.target,r.event.fix(a))};r.event.special[b]={setup:function(){var d=this.ownerDocument||this,e=V.access(d,b);e||d.addEventListener(a,c,!0),V.access(d,b,(e||0)+1)},teardown:function(){var d=this.ownerDocument||this,e=V.access(d,b)-1;e?V.access(d,b,e):(d.removeEventListener(a,c,!0),V.remove(d,b))}}});var eb=/\[\]$/,fb=/\r?\n/g,gb=/^(?:submit|button|image|reset|file)$/i,hb=/^(?:input|select|textarea|keygen)/i;function ib(a,b,c,d){var e;if(r.isArray(b))r.each(b,function(b,e){c||eb.test(a)?d(a,e):ib(a+"["+("object"==typeof e&&null!=e?b:"")+"]",e,c,d)});else if(c||"object"!==r.type(b))d(a,b);else for(e in b)ib(a+"["+e+"]",b[e],c,d)}r.param=function(a,b){var c,d=[],e=function(a,b){var c=r.isFunction(b)?b():b;d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(null==c?"":c)};if(r.isArray(a)||a.jquery&&!r.isPlainObject(a))r.each(a,function(){e(this.name,this.value)});else for(c in a)ib(c,a[c],b,e); +return d.join("&")},r.fn.extend({serialize:function(){return r.param(this.serializeArray())},serializeArray:function(){return this.map(function(){var a=r.prop(this,"elements");return a?r.makeArray(a):this}).filter(function(){var a=this.type;return this.name&&!r(this).is(":disabled")&&hb.test(this.nodeName)&&!gb.test(a)&&(this.checked||!ha.test(a))}).map(function(a,b){var c=r(this).val();return null==c?null:r.isArray(c)?r.map(c,function(a){return{name:b.name,value:a.replace(fb,"\r\n")}}):{name:b.name,value:c.replace(fb,"\r\n")}}).get()}}),r.fn.extend({wrapAll:function(a){var b;return this[0]&&(r.isFunction(a)&&(a=a.call(this[0])),b=r(a,this[0].ownerDocument).eq(0).clone(!0),this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstElementChild)a=a.firstElementChild;return a}).append(this)),this},wrapInner:function(a){return r.isFunction(a)?this.each(function(b){r(this).wrapInner(a.call(this,b))}):this.each(function(){var b=r(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){var b=r.isFunction(a);return this.each(function(c){r(this).wrapAll(b?a.call(this,c):a)})},unwrap:function(a){return this.parent(a).not("body").each(function(){r(this).replaceWith(this.childNodes)}),this}}),r.expr.pseudos.hidden=function(a){return!r.expr.pseudos.visible(a)},r.expr.pseudos.visible=function(a){return!!(a.offsetWidth||a.offsetHeight||a.getClientRects().length)},o.createHTMLDocument=function(){var a=d.implementation.createHTMLDocument("").body;return a.innerHTML="
",2===a.childNodes.length}(),r.parseHTML=function(a,b,c){if("string"!=typeof a)return[];"boolean"==typeof b&&(c=b,b=!1);var e,f,g;return b||(o.createHTMLDocument?(b=d.implementation.createHTMLDocument(""),e=b.createElement("base"),e.href=d.location.href,b.head.appendChild(e)):b=d),f=B.exec(a),g=!c&&[],f?[b.createElement(f[1])]:(f=oa([a],b,g),g&&g.length&&r(g).remove(),r.merge([],f.childNodes))};function jb(a){return r.isWindow(a)?a:9===a.nodeType&&a.defaultView}r.offset={setOffset:function(a,b,c){var d,e,f,g,h,i,j,k=r.css(a,"position"),l=r(a),m={};"static"===k&&(a.style.position="relative"),h=l.offset(),f=r.css(a,"top"),i=r.css(a,"left"),j=("absolute"===k||"fixed"===k)&&(f+i).indexOf("auto")>-1,j?(d=l.position(),g=d.top,e=d.left):(g=parseFloat(f)||0,e=parseFloat(i)||0),r.isFunction(b)&&(b=b.call(a,c,r.extend({},h))),null!=b.top&&(m.top=b.top-h.top+g),null!=b.left&&(m.left=b.left-h.left+e),"using"in b?b.using.call(a,m):l.css(m)}},r.fn.extend({offset:function(a){if(arguments.length)return void 0===a?this:this.each(function(b){r.offset.setOffset(this,a,b)});var b,c,d,e,f=this[0];if(f)return f.getClientRects().length?(d=f.getBoundingClientRect(),d.width||d.height?(e=f.ownerDocument,c=jb(e),b=e.documentElement,{top:d.top+c.pageYOffset-b.clientTop,left:d.left+c.pageXOffset-b.clientLeft}):d):{top:0,left:0}},position:function(){if(this[0]){var a,b,c=this[0],d={top:0,left:0};return"fixed"===r.css(c,"position")?b=c.getBoundingClientRect():(a=this.offsetParent(),b=this.offset(),r.nodeName(a[0],"html")||(d=a.offset()),d={top:d.top+r.css(a[0],"borderTopWidth",!0),left:d.left+r.css(a[0],"borderLeftWidth",!0)}),{top:b.top-d.top-r.css(c,"marginTop",!0),left:b.left-d.left-r.css(c,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var a=this.offsetParent;while(a&&"static"===r.css(a,"position"))a=a.offsetParent;return a||pa})}}),r.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(a,b){var c="pageYOffset"===b;r.fn[a]=function(d){return S(this,function(a,d,e){var f=jb(a);return void 0===e?f?f[b]:a[d]:void(f?f.scrollTo(c?f.pageXOffset:e,c?e:f.pageYOffset):a[d]=e)},a,d,arguments.length)}}),r.each(["top","left"],function(a,b){r.cssHooks[b]=Na(o.pixelPosition,function(a,c){if(c)return c=Ma(a,b),Ka.test(c)?r(a).position()[b]+"px":c})}),r.each({Height:"height",Width:"width"},function(a,b){r.each({padding:"inner"+a,content:b,"":"outer"+a},function(c,d){r.fn[d]=function(e,f){var g=arguments.length&&(c||"boolean"!=typeof e),h=c||(e===!0||f===!0?"margin":"border");return S(this,function(b,c,e){var f;return r.isWindow(b)?0===d.indexOf("outer")?b["inner"+a]:b.document.documentElement["client"+a]:9===b.nodeType?(f=b.documentElement,Math.max(b.body["scroll"+a],f["scroll"+a],b.body["offset"+a],f["offset"+a],f["client"+a])):void 0===e?r.css(b,c,h):r.style(b,c,e,h)},b,g?e:void 0,g)}})}),"function"==typeof define&&define.amd&&define("jquery",[],function(){return r});var kb=a.jQuery,lb=a.$;return r.noConflict=function(b){return a.$===r&&(a.$=lb),b&&a.jQuery===r&&(a.jQuery=kb),r},b||(a.jQuery=a.$=r),r}); ADDED js-path.scm Index: js-path.scm ================================================================== --- /dev/null +++ js-path.scm @@ -0,0 +1,1 @@ +(define *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -79,20 +79,31 @@ #f))) (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) - (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) - (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each + ;; (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 (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each + (paramparts (if (string? stepparams) + (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams)) + '())) + (subrun (alist-ref "subrun" paramparts equal?)) (stepcmd (list-ref stepparts 3)) (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (common:file-exists? logpro-file))) + (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams + ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) + (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig (begin (with-output-to-file logpro-file (lambda () @@ -101,11 +112,11 @@ (print tconfig-logpro))) (set! logpro-used #t))) ;; NB// can safely assume we are in test-area directory (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts - " stepparms: " stepparms " stepcmd: " stepcmd) + " stepparams: " stepparams " stepcmd: " stepcmd) ;; ;; first source the previous environment ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) ;; (if (and prevstep (common:file-exists? prev-env)) @@ -119,12 +130,19 @@ ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 - (pid (process-run "/bin/bash" (list "-c" cmd)))) - + (pid #f)) + (let ((proc (lambda () + (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) + (if subrun + (begin + (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.") + (common:without-vars proc "^MT_.*")) + (proc))) + (with-output-to-file "Makefile.ezsteps" (lambda () (print stepname ".log :") (print "\t" cmd) (if (common:file-exists? (conc stepname ".logpro")) @@ -240,11 +258,11 @@ (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) -(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) +(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m) ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; Since we should have a clean slate at this time there is no need to do @@ -274,11 +292,11 @@ (thread-sleep! 2) (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) - (if ezsteps + (if (or ezsteps subrun) (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) @@ -293,29 +311,86 @@ ;; after all that, still no testconfig? Time to abort (if (not testconfig) (begin (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") (exit 1))) - (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) - ;; if ezsteps was defined then we are sure to have at least one step but check anyway - (if (not (> (length ezstepslst) 0)) - (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length") - (let loop ((ezstep (car ezstepslst)) - (tal (cdr ezstepslst)) - (prevstep #f)) - ;; check exit-info (vector-ref exit-info 1) - (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) - (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) - (stepname (car ezstep))) - ;; if logpro-used read in the stepname.dat file - (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) - (launch:load-logpro-dat run-id test-id stepname)) - (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) - (if (not (null? tal)) - (loop (car tal) (cdr tal) stepname)) - (debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))))))) + + ;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry + ;; 1. get section [runarun] + ;; 2. unset MT_* vars + ;; 3. fix target + ;; 4. fix runname + ;; 5. fix testpatt or calculate it from contour + ;; 6. launch the run + ;; 7. roll up the run result and or roll up the logpro processed result + (if (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested + (let* ((runarea (configf:lookup testconfig "subrun" "runarea")) + (passfail (configf:lookup testconfig "subrun" "passfail")) + (target (configf:lookup testconfig "subrun" "target")) + (runname (configf:lookup testconfig "subrun" "runname")) + (contour (configf:lookup testconfig "subrun" "contour")) + (testpatt (configf:lookup testconfig "subrun" "testpatt")) + (mode-patt (configf:lookup testconfig "subrun" "mode-patt")) + (tag-expr (configf:lookup testconfig "subrun" "tag-expr")) + (run-wait (configf:lookup testconfig "subrun" "runwait")) + (logpro (configf:lookup testconfig "subrun" "logpro")) + (compact-stem (string-substitute "[/*]" "_" (conc target "-" runname "-" (or testpatt mode-patt tag-expr)))) + (log-file (conc compact-stem ".log")) + (mt-cmd (conc "megatest -run -target " target + " -runname " (or runname (get-environment-variable "MT_RUNNAME")) + (conc " -start-dir " (if runarea runarea *toppath*)) + (if testpatt (conc " -testpatt " testpatt) "") + (if mode-patt (conc " -modepatt " mode-patt) "") + (if tag-expr (conc " -tag-expr" tag-expr) "") + (if (equal? run-wait "yes") " -run-wait " "") + " -log " log-file))) + ;; change directory to runarea, create it if needed, we do NOT create the directory + ;; (if runarea + ;; (if (directory-exists? runarea) + ;; (change-directory runarea) + ;; (begin + ;; (debug:print 0 *default-log-port* "ERROR: for sub-megatest run the runarea \"" runarea "\" does not exist! EXITING.") + ;; (exit 1)))) + ;; (let ((subrun (conc *toppath* "/subrun") #t)) + ;; (create-directory subrun) + ;; (change-directory subrun))) + + ;; by this point we are in the right place to run the subrun and we have a Megatest command to run + ;; (filter (lambda (x)(string-match "MT_.*" (car x))) (get-environment-variables)) + ;; (common:without-vars mt-cmd "^MT_.*") + (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"") + (set! ezsteps #t) ;; set the needed flag + (set! ezstepslst (append (or ezstepslst '()) + (list (list "subrun" (conc "{subrun=true} " mt-cmd))))) + (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun + (if runarea (configf:set-section-var testconfig "setup" "submegatest" runarea)) + (configf:write-alist testconfig "testconfig.subrun") + )) + + ;; process the ezsteps + (if ezsteps + (begin + (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + (if (not (> (length ezstepslst) 0)) + (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length") + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (prevstep #f)) + (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"") + ;; check exit-info (vector-ref exit-info 1) + (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) + (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) + (stepname (car ezstep))) + ;; if logpro-used read in the stepname.dat file + (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) + (launch:load-logpro-dat run-id test-id stepname)) + (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) + (if (not (null? tal)) + (loop (car tal) (cdr tal) stepname)) + (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))))))))) (define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30"))) (start-seconds (current-seconds)) (calc-minutes (lambda () @@ -423,10 +498,11 @@ (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) + (subrun (assoc/default 'subrun cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) ;; (transport (assoc/default 'transport cmdinfo)) ;; not used ;; (serverinf (assoc/default 'serverinf cmdinfo)) ;; (port (assoc/default 'port cmdinfo)) (serverurl (assoc/default 'serverurl cmdinfo)) @@ -448,85 +524,78 @@ (keyvals #f) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes - (let ((fulln (conc testpath "/" runscript))) + (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path - ) ;; (rollup-status 0) + (check-work-area (lambda () + ;; NFS might not have propagated the directory meta data to the run host - give it time if needed + (let loop ((count 0)) + (if (or (common:directory-exists? work-area) + (> count 10)) + (change-directory work-area) + (begin + (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") + (thread-sleep! 10) + (loop (+ count 1))))) + + (if (not (string=? (common:real-path work-area)(common:real-path (current-directory)))) + (begin + (debug:print 0 *default-log-port* + "INFO: we are expecting to be in directory " work-area "\n" + " but we are actually in the directory " (current-directory) "\n" + " doing another change dir.") + (change-directory work-area))) + + ;; spot check that the files in testpath are available. Too often NFS delays cause problems here. + (let ((files (glob (conc testpath "/*"))) + (bad-files '())) + (for-each + (lambda (fullname) + (let* ((fname (pathname-strip-directory fullname)) + (targn (conc work-area "/" fname))) + (if (not (file-exists? targn)) + (set! bad-files (cons fname bad-files))))) + files) + (if (not (null? bad-files)) + (begin + (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.") + (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", ")) + (launch:test-copy testpath work-area)))) + ;; one more time, change to the work-area directory + (change-directory work-area))) + ) ;; let* + + (if contour (setenv "MT_CONTOUR" contour)) + + ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... + ;; + (setenv "MT_TESTSUITENAME" areaname) + (setenv "MT_RUN_AREA_HOME" top-path) + (set! *toppath* top-path) + (change-directory *toppath*) ;; temporarily switch to the run area home + (setenv "MT_TEST_RUN_DIR" work-area) + + (launch:setup) ;; should be properly in the run area home now (if contour (setenv "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; (setenv "MT_TESTSUITENAME" areaname) (setenv "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) + (change-directory *toppath*) ;; temporarily switch to the run area home (setenv "MT_TEST_RUN_DIR" work-area) - ;; On NFS it can be slow and unreliable to get needed startup information. - ;; i. Check if we are on the homehost, if so, proceed - ;; ii. Check if host and port passed in via CMDINFO are valid and if - ;; possible use them. - (let ((bestadrs (server:get-best-guess-address (get-host-name))) - (needcare #f)) - (if (equal? homehost bestadrs) ;; we are likely on the homehost - (debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost) - (let ((host-port (if serverurl (string-split serverurl ":") #f))) - (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote* - (if (string? homehost) - (if (and host-port - (> (length host-port) 1)) - (let* ((host (car host-port)) - (port (cadr host-port)) - (start-res (http-transport:client-connect host port)) - (ping-res (rmt:login-no-auto-client-setup start-res))) - (if (and start-res - ping-res) - ;; (begin ;; let ((url (http-transport:server-dat-make-url start-res))) - (begin - (remote-conndat-set! *runremote* start-res) - ;; (remote-server-url-set! *runremote* url) - ;; (if (server:ping url) - (debug:print-info 0 *default-log-port* "connected to " host ":" port " using CMDINFO data.")) - (begin - (debug:print-info 0 *default-log-port* "have CMDINFO data but failed to connect to " host ":" port) - (set! *runremote* #f)) - ;; (remote-conndat-set! *runremote* #f)) - )) - (begin - (set! *runremote* #f) - (debug:print-info 0 *default-log-port* (if host-port - (conc "received invalid host-port information " host-port) - "no host-port information received")) - ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare. - (set! needcare #t))) - (begin - (set! *runremote* #f) - (debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.") - (set! needcare #t))))) - (if needcare ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host - (let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory - (handle-exceptions - exn - (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn)) - (create-directory logdir #t))))) - - ;; NFS might not have propagated the directory meta data to the run host - give it time if needed - (let loop ((count 0)) - (if (or (common:file-exists? top-path) - (> count 10)) - (change-directory top-path) - (begin - (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") - (thread-sleep! 10) - (loop (+ count 1))))) - (launch:setup) ;; should be properly in the top-path now - (set! tconfigreg (tests:get-all)) + (launch:setup) ;; should be properly in the run area home now + + (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) @@ -556,11 +625,12 @@ (begin (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.") (exit)))) (test-pid (db:test-get-process_id test-info))) (cond - ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun + ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag. + ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) @@ -585,10 +655,14 @@ (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) + ;; validate that the test run area is available + (check-work-area) + + ;; still need to go back to run area home for next couple steps (change-directory *toppath*) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? @@ -596,20 +670,22 @@ (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars - (for-each (lambda (section) - (for-each (lambda (varval) - (let ((var (car varval)) - (val (cadr varval))) - (if (and (string? var)(string? val)) - (begin - (setenv var (config:eval-string-in-environment val))) ;; val) - (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) - (configf:get-section rconfig section))) - (list "default" target))) + (for-each + (lambda (section) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if (and (string? var)(string? val)) + (begin + (setenv var (config:eval-string-in-environment val))) ;; val) + (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) + (configf:get-section rconfig section))) + (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (common:file-exists? work-area) @@ -617,10 +693,13 @@ (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) + + ;; now we can switch to the work-area? + (change-directory work-area) ;;(bb-check-path msg: "launch:execute post block 1.5") ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config @@ -702,11 +781,11 @@ ;; (keep-going #t) (misc-flags (let ((ht (make-hash-table))) (hash-table-set! ht 'keep-going #t) ht)) (runit (lambda () - (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m))) + (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m))) (monitorjob (lambda () (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) @@ -945,12 +1024,24 @@ (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... sections: sections))) (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) (rccachef (cdr cachefiles))) - (if rccachef (configf:write-alist runconfigdat rccachef)) - (if mtcachef (configf:write-alist *configdat* mtcachef)) + ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 + ;; TODO - consider 1) using simple-lock to bracket cache write + ;; 2) cache in hash on server, since need to do rmt: anyway to lock. + + (if rccachef + (common:fail-safe + (lambda () + (configf:write-alist runconfigdat rccachef)) + (conc "Could not write cache file - "rccachef))) + (if mtcachef + (common:fail-safe + (lambda () + (configf:write-alist *configdat* mtcachef)) + (conc "Could not write cache file - "mtcachef))) (set! *runconfigdat* runconfigdat) (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table (set! *configdat* (make-hash-table)) ))) @@ -1015,12 +1106,26 @@ ;; one more attempt to cache the configs for future reading (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) (rccachef (cdr cachefiles))) - (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef))) (configf:write-alist *runconfigdat* rccachef)) - (if (and mtcachef *configdat* (not (common:file-exists? mtcachef))) (configf:write-alist *configdat* mtcachef)) + + ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 + ;; TODO - consider 1) using simple-lock to bracket cache write + ;; 2) cache in hash on server, since need to do rmt: anyway to lock. + (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef))) + (common:fail-safe + (lambda () + (configf:write-alist *runconfigdat* rccachef)) + (conc "Could not write cache file - "rccachef)) + ) + (if (and mtcachef *configdat* (not (common:file-exists? mtcachef))) + (common:fail-safe + (lambda () + (configf:write-alist *configdat* mtcachef)) + (conc "Could not write cache file - "mtcachef)) + ) (if (and rccachef mtcachef *runconfigdat* *configdat*) (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) @@ -1040,10 +1145,26 @@ (cdr res) (begin (if (common:low-noise-print 20 "No valid disks or no disk with enough space") (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) (exit 1))))))) ;; TODO - move the exit to the calling location and return #f + +(define (launch:test-copy test-src-path test-path) + (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) + (if cmd + ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH + (string-substitute "TEST_TARG_PATH" test-path + (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) + #f))) + (cmd (if ovrcmd + ovrcmd + (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" + " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) + (status (system cmd))) + (if (not (eq? status 0)) + (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))) + ;; Desired directory structure: ;; ;; - - -. ;; | @@ -1205,23 +1326,11 @@ (if (not (directory? test-path)) (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes (if (and test-src-path (directory? test-path)) (begin - (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) - (if cmd - ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH - (string-substitute "TEST_TARG_PATH" test-path - (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) - #f))) - (cmd (if ovrcmd - ovrcmd - (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" - " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) - (status (system cmd))) - (if (not (eq? status 0)) - (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))) + (launch:test-copy test-src-path test-path) (list lnkpathf lnkpath )) (if (and test-src-path (> remtries 0)) (begin (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; @@ -1235,11 +1344,24 @@ ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex - (let* ((item-path (item-list->path itemdat)) + (let* ( ;; (lock-key (conc "test-" test-id)) + ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) + ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds + ;; (if (car lock) + ;; #t + ;; (if (> (current-seconds) expire-time) + ;; (begin + ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path) + ;; (rmt:no-sync-del! lock-key) ;; destroy the lock + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; + ;; (begin + ;; (thread-sleep! 1) + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) + (item-path (item-list->path itemdat)) (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 1))) (if (> launch-delay delta) (begin @@ -1269,11 +1391,12 @@ (if (equal? ush "no") ;; must use "no" to NOT use shell #f ush) #t))) ;; default is yes (runscript (config-lookup tconfig "setup" "runscript")) - (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big + (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag + (subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun ;; (diskspace (config-lookup tconfig "requirements" "diskspace")) ;; (memory (config-lookup tconfig "requirements" "memory")) ;; (hosts (config-lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed (remote-megatest (config-lookup *configdat* "setup" "executable")) (run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim") @@ -1353,11 +1476,12 @@ (list 'run-id run-id ) (list 'test-id test-id ) ;; (list 'item-path item-path ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) - (list 'ezsteps ezsteps) + (list 'ezsteps ezsteps) + (list 'subrun subrun) (list 'target mt_target) (list 'contour contour) (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) @@ -1411,10 +1535,11 @@ (car fullcmd)) (if useshell '() (cdr fullcmd))))) (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. + ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) (with-output-to-file "mt_launch.log" (lambda () (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6502) +(define megatest-version 1.6503) Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -20,11 +20,11 @@ # the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing # ext-tests path=ext-tests; targtrans=prefix-contour; ext path=ext-tests [contours] -# mode-patt/tag-expr +# selector=tag-expr/mode-patt quick areas=ext; selector=/QUICKPATT quick2 areafn=check-area; selector=/QUICKPATT # quick areas=fullrun,ext-tests; selector=QUICKPATT/quick # full areas=fullrun,ext-tests; selector=MAXPATT/ # short areas=fullrun,ext-tests; selector=MAXPATT/ @@ -37,9 +37,20 @@ ext matt:admin mattw:owner [accesstypes] admin run rerun resume remove set-ss owner run rerun resume remove -jerk set-ss +badguy set-ss [setup] maxload 1.2 + +[listeners] +localhost:12345 contact=matt@kiatoa.com +localhost:54321 contact=matt@kiatoa.com + +[listener] +script nbfake echo + + +[server] +timeout 1 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -51,33 +51,58 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") +(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file +(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file + +;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file +;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) + +;; usage logging, careful with this, it is not designed to deal with all real world challenges! +;; +(if (and *usage-log-file* + (file-write-access? *usage-log-file*)) + (with-output-to-file + *usage-log-file* + (lambda () + (print + (if *usage-use-seconds* + (current-seconds) + (time->string + (seconds->local-time (current-seconds)) + "%Yww%V.%w %H:%M:%S")) + " " + (current-user-name) " " + (current-directory) " " + "\"" (string-intersperse (argv) " ") "\"")) + #:append)) ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys ;; -daemonize : fork into background and disconnect from stdin/out (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright Matt Welland 2006-2015 - + license GPL, Copyright Matt Welland 2006-2017 + Usage: megatest [options] -h : this help -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") Launching and managing runs -run : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt - Optionally use :state and :status + Optionally use :state and :status, use -keep-records to remove only + the run data. -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a and then run the specified testpatt with -preclean -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean @@ -87,10 +112,16 @@ -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test -clean-cache : remove the cached megatest.config and runconfigs.config files -no-cache : do not use the cached config files. + -one-pass : launch as many tests as you can but do not wait for more to be ready + -remove-keep N action : remove all but N most recent runs per target + * Use -actions print,remove-runs,archive to specify action to take + * Add param -age 120d,3h,20m to apply only to runs older than the + specified age + * Add -precmd to insert a wrapper command in front of the commands run Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs -testpatt patt1/patt2,patt3/... : % is wildcard @@ -144,10 +175,11 @@ -testdata-csv [categorypatt/]varpatt : dump testdata for given category Misc -start-dir path : switch to this directory before running megatest -contour cname : add a level of hierarcy to the linktree and run paths + -area-tag tagname : add a tag to an area while syncking to pgdb -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db -sync-to dest : sync to new postgresql central style database @@ -181,10 +213,17 @@ -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified in the [archive-disks] section. cmd: keep-html, restore, save, save-remove -generate-html : create a simple html tree for browsing your runs + -list-run-time : list time requered to complete runs. It supports following switches + -run-patt -target-patt -dumpmode + -list-test-time : list time requered to complete each test in a run. It following following arguments + -runname -target -dumpmode + + + Diff report -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname and either -diff-email or -diff-html) -src-target @@ -251,11 +290,14 @@ ":expected" ":tol" ":units" ;; misc "-start-dir" + "-run-patt" + "-target-patt" "-contour" + "-area-tag" "-server" "-transport" "-port" "-extract-ods" "-pathmod" @@ -262,11 +304,19 @@ "-env2file" "-envcap" "-envdelta" "-setvars" "-set-state-status" + + ;; move runs stuff here + "-remove-keep" "-set-run-status" + "-age" + "-archive" + "-actions" + "-precmd" + "-debug" ;; for *verbosity* > 2 "-create-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file @@ -276,11 +326,10 @@ "-run-id" "-ping" "-refdb2dat" "-o" "-log" - "-archive" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" @@ -320,13 +369,15 @@ "-lock" "-unlock" "-list-servers" "-kill-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + "-one-pass" ;; "-local" ;; run some commands using local db access "-generate-html" - + "-list-run-time" + "-list-test-time" ;; misc queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" @@ -338,10 +389,11 @@ "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests, respects -testpatt, defaults to % "-run" ;; alias for -runall "-remove-runs" + "-keep-records" ;; use with -remove-runs to remove only the run data "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" "-create-megatest-area" @@ -349,11 +401,10 @@ "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" - "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" @@ -961,11 +1012,11 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on action) +(define (operate-on action #!key (mode #f)) ;; #f is "use default" (let* ((runrec (runs:runrec-make-record)) (target (common:args-get-target))) (cond ((not target) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg") @@ -990,19 +1041,36 @@ target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") state: (common:args-get-state) status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status")))) + new-state-status: (args:get-arg "-set-state-status") + mode: mode))) (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" (lambda (target runname keys keyvals) - (operate-on 'remove-runs)))) + (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") + 'remove-data-only + 'remove-all))))) + +(if (args:get-arg "-remove-keep") + (general-run-call + "-remove-keep" + "remove keep" + (lambda (target runname keys keyvals) + (let ((actions (map string->symbol + (string-split + (or (args:get-arg "-actions") + "print") + ",")))) ;; default to printing the output + (runs:remove-all-but-last-n-runs-per-target target runname + (string->number (args:get-arg "-remove-keep")) + actions: actions))))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" @@ -1550,11 +1618,11 @@ (lambda (target runname keys keyvals) (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") - "FAIL,INCOMPLETE,ABORT,CHECK"))) + "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) (hash-table-set! args:arg-hash "-preclean" #t) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") @@ -2157,22 +2225,31 @@ ;; 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-sync-to-megatest.db") - (begin - (db:multi-db-sync - (db:setup #f) - 'new2old - ) + (let ((res (db:multi-db-sync + (db:setup #f) + 'new2old))) + (print "Synced " res " records to megatest.db") (set! *didsomething* #t))) (if (args:get-arg "-sync-to") (let ((toppath (launch:setup))) (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) (set! *didsomething* #t))) +(if (args:get-arg "-list-test-time") + (let* ((toppath (launch:setup))) + (task:get-test-times) + (set! *didsomething* #t))) + +(if (args:get-arg "-list-run-time") + (let* ((toppath (launch:setup))) + (task:get-run-times) + (set! *didsomething* #t))) + (if (args:get-arg "-generate-html") (let* ((toppath (launch:setup))) (if (tests:create-html-tree #f) (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) ADDED minimt/Makefile Index: minimt/Makefile ================================================================== --- /dev/null +++ minimt/Makefile @@ -0,0 +1,12 @@ +minimt : minimt.scm db.scm setup.scm direct.scm + csc minimt.scm + +run : minimt + export PATH="$(PWD)":$(PATH) ; minimt runrun foo/bar run1 + +runseq : clean run + sleep 5;tail -F runtest/*log + +clean : + rm -rf runtest/* + ADDED minimt/db.scm Index: minimt/db.scm ================================================================== --- /dev/null +++ minimt/db.scm @@ -0,0 +1,173 @@ +;; pretend to be a simplified Megatest + +(use sql-de-lite defstruct) + +;; init the db - NOTE: takes a db NOT a dbconn +;; +(define (init-db db) + (with-transaction + db + (lambda () + (for-each + (lambda (qrystr) + (exec (sql db qrystr))) + '("CREATE TABLE IF NOT EXISTS runs + (id INTEGER PRIMARY KEY, + target TEXT NOT NULL, + run_name TEXT NOT NULL, + state TEXT NOT NULL, + status TEXT NOT NULL, + CONSTRAINT runs_constraint UNIQUE (run_name));" + "CREATE TABLE IF NOT EXISTS tests + (id INTEGER PRIMARY KEY, + run_id INTEGER NOT NULL, + test_name TEXT NOT NULL, + state TEXT NOT NULL, + status TEXT NOT NULL, + start_time INTEGER DEFAULT (strftime('%s','now')), + end_time INTEGER DEFAULT -1, + CONSTRAINT tests_constraint UNIQUE (run_id,test_name));" + "CREATE TABLE IF NOT EXISTS steps + (id INTEGER PRIMARY KEY, + test_id INTEGER NOT NULL, + step_name TEXT NOT NULL, + state TEXT NOT NULL, + status TEXT NOT NULL, + CONSTRAINT step_constraint UNIQUE (test_id,step_name));"))))) + +(defstruct dbconn-dat + dbh ;; the database handle + writeable ;; do we have write access? + path ;; where the db lives + name ;; name of the db + ) + +;; open the database, return a dbconn struct +(define (open-create-db path fname init) + (let* ((fullname (conc path "/" fname)) + (already-exists (file-exists? fullname)) + (write-access (and (file-write-access? path) + (or (not already-exists) + (and already-exists + (file-write-access? fullname))))) + (db (if (or already-exists write-access) + (open-database fullname) + (begin + (print "FATAL: No existing db and no write access thus cannot create " fullname) ;; no db and no write access cannot proceed. + (exit 1)))) + (dbconn (make-dbconn-dat))) + (set-busy-handler! db (busy-timeout 120000)) ;; set a busy timeout + (exec (sql db "PRAGMA synchronous=0;")) + (if (and init write-access (not already-exists)) + (init db)) + (dbconn-dat-dbh-set! dbconn db) + (dbconn-dat-writeable-set! dbconn write-access) + (dbconn-dat-path-set! dbconn path) + (dbconn-dat-name-set! dbconn fname) + dbconn)) + +(define-inline (get-db dbconn) + (dbconn-dat-dbh dbconn)) + +;; RUNS + +;; create a run +(define (create-run dbconn target run-name) + (exec (sql (get-db dbconn) "INSERT INTO runs (run_name,target,state,status) VALUES (?,?,'NEW','na');") + run-name target)) + +;; get a run id +(define (get-run-id dbconn target run-name) + (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM runs WHERE target=? AND run_name=?;") + target run-name))) + +;; TESTS + +(defstruct test-dat + id + run-id + test-name + state + status) + +;; create a test +(define (create-test dbconn run-id test-name) + (exec (sql (get-db dbconn) "INSERT INTO tests (run_id,test_name,state,status) VALUES (?,?,'NOT_STARTED','na');") + run-id test-name)) + +;; get a test id +(define (get-test-id dbconn run-id test-name) + (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM tests WHERE run_id=? AND test_name=?;") + run-id test-name))) + +(define-inline (test-row->test-dat row) + (make-test-dat + id: (list-ref row 0) + run-id: (list-ref row 1) + test-name: (list-ref row 2) + state: (list-ref row 3) + status: (list-ref row 4))) + +;; get the data for given test-id +(define (test-get-record dbconn test-id) + (let* ((row (query fetch-row (sql (get-db dbconn) "SELECT id,run_id,test_name,state,status FROM tests WHERE test_id=?;") + test-id))) + (test-row->test-dat row))) + +;; get a bunch of tests data +(define (test-get-tests dbconn run-ids test-name-patt) + (let* ((rows (query fetch-rows + (sql (get-db dbconn) + (conc "SELECT id,run_id,test_name,state,status FROM tests WHERE test_name LIKE ? AND run_id IN (" + (string-intersperse (map conc run-ids) ",") ");")) + test-name-patt))) + (map test-row->test-dat rows))) + +(define (test-set-state-status dbconn test-id new-state new-status) + (exec (sql (get-db dbconn) "UPDATE tests SET state=?,status=?,end_time=? WHERE id=?;") + new-state new-status (current-seconds) test-id)) + +;; STEPS + +;; create a step +(define (create-step dbconn test-id step-name) + (exec (sql (get-db dbconn) "INSERT INTO steps (test_id,step_name,state,status) VALUES (?,?,'NOT_STARTED','na');") + test-id step-name)) + +;; get a step id +(define (get-step-id dbconn test-id step-name) + (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM steps WHERE test_id=? AND step_name=?;") + test-id step-name))) + +(define (step-set-state-status dbconn step-id new-state new-status) + (exec (sql (get-db dbconn) "UPDATE steps SET state=?,status=? WHERE id=?;") + new-state new-status step-id)) + +;;====================================================================== +;; Statistics gathering +;;====================================================================== + +(define *stats* (make-hash-table)) + +(define (update-stats key duration) + (let ((rec (or (hash-table-ref/default *stats* key #f) + (let ((new (vector 0 0 0))) + (hash-table-set! *stats* key new) + new)))) + (vector-set! rec 0 (+ (vector-ref rec 0) 1)) ;; num calls + (vector-set! rec 1 (+ (vector-ref rec 1) duration)) ;; total duration + (if (> duration (vector-ref rec 2) ) + (vector-set! rec 2 duration)))) + +(define (statwrap name proc) + (lambda params + (let ((start-time (current-milliseconds)) + (res (apply proc params))) + (update-stats name (- (current-milliseconds) start-time)) + res))) + +(define (print-stats statdat) + (hash-table-for-each + statdat + (lambda (key val) + (print key " count: " (vector-ref val 0) " avg: " (/ (vector-ref val 1)(vector-ref val 0)) " max: " (vector-ref val 2))))) ADDED minimt/direct.scm Index: minimt/direct.scm ================================================================== --- /dev/null +++ minimt/direct.scm @@ -0,0 +1,11 @@ +;; direct API, call the db calls directly +(define rmt:create-run (statwrap 'create-run create-run)) +(define rmt:create-step (statwrap 'create-step create-step)) +(define rmt:create-test (statwrap 'create-test create-test)) +(define rmt:get-test-id (statwrap 'get-test-id get-test-id)) +(define rmt:get-run-id (statwrap 'get-run-id get-run-id)) +(define rmt:open-create-db (statwrap 'open open-create-db)) +(define rmt:step-set-state-status (statwrap 'step-set-state-status step-set-state-status)) +(define rmt:test-set-state-status (statwrap 'test-set-state-status test-set-state-status)) +(define rmt:test-get-tests (statwrap 'test-get-tests test-get-tests)) + ADDED minimt/minimt.scm Index: minimt/minimt.scm ================================================================== --- /dev/null +++ minimt/minimt.scm @@ -0,0 +1,86 @@ +(use posix) + +(include "db.scm") + +;; define following in setup.scm +;; *remotehost* => host for "tests" +;; *homehost* => host for servers +;; *homepath* => directory from which to run +;; *numtests* => how many tests to simulate for each run +;; *numruns* => how many runs to simulate +;; +(include "setup.scm") + +(include "direct.scm") ;; direct db calls + +;; RUN A TEST +(define (run-test dbconn run-id test-name) + (rmt:create-test dbconn run-id test-name) + (let ((test-id (rmt:get-test-id dbconn run-id test-name))) + (rmt:test-set-state-status dbconn test-id "LAUNCHED" "na") + (thread-sleep! *launchdelay*) + (rmt:test-set-state-status dbconn test-id "RUNNING" "na") + (let loop ((step-num 0)) + (let ((step-name (conc "step" step-num))) + (rmt:create-step dbconn test-id step-name) + (let ((step-id (get-step-id dbconn test-id step-name))) + (rmt:step-set-state-status dbconn step-id "START" -1) + (thread-sleep! *stepdelay*) + (rmt:step-set-state-status dbconn step-id "END" 0) + (print" STEP: " step-name " done."))) + (if (< step-num *numsteps*) + (loop (+ step-num 1)))) + ;; we will do a large but bogus read to simulate the logic in Megatest + (rmt:test-get-tests dbconn `(,run-id) "%") + (rmt:test-set-state-status dbconn test-id "COMPLETED" (if (> (random 10) 2) "PASS" "FAIL")) + (print "TEST: " test-name " done.") + (print "Stats:") + (print-stats *stats*) + test-id)) + +;; RUN A RUN +(define (run-run dbconn target run-name num-tests) + (rmt:create-run dbconn target run-name) + (let ((run-id (rmt:get-run-id dbconn target run-name))) + (let loop ((test-num 0)) + (system (conc "NBFAKE_LOG=test-" test-num "-run-id-" run-id ".log NBFAKE_HOST=" *remotehost* " nbfake minimt runtest " run-id " test-" test-num)) + (if (< test-num num-tests) + (loop (+ test-num 1)))))) + +;; Do what is asked +(let ((args (cdr (argv)))) + (if (< (length args) 1) + (print + "Usage: minimt [options]" " + runtest run-id testname + runrun target runname") + (let ((cmd (car args)) + (dbconn (rmt:open-create-db *homepath* "mt.db" init-db))) + (thread-sleep! 0.5) ;; be sure the db is written out to disk? Should really not be needed. + (change-directory *homepath*) + (case (string->symbol cmd) + ((runtest) + (let ((run-id (string->number (cadr args))) + (test-name (caddr args))) + (print "Launching test " test-name " for run-id " run-id) + (run-test dbconn run-id test-name))) + ((runrun) + (let ((target (cadr args)) + (run-name (caddr args))) + (run-run dbconn target run-name *numtests*) + (print "Use: sqlite3 runtest/mt.db 'select max(end_time)-min(start_time) from tests;' to see the total run time") + )) + ((runall) + (for-each + (lambda (target) + (let loop ((run-num 0)) + (thread-sleep! *rundelay*) + (system (conc "NBFAKE_LOG=run-" target "-" run-num ".log nbfake minimt runrun " target " run-" run-num)) + (if (< run-num *numruns*) + (loop (+ run-num 1))))) + *targets*)) + ((server) + (start-server dbconn)) + (else + (print "Command: " cmd " not recognised. Run without params to see help."))) + (close-database (dbconn-dat-dbh dbconn))))) ADDED minimt/queued.scm Index: minimt/queued.scm ================================================================== --- /dev/null +++ minimt/queued.scm @@ -0,0 +1,209 @@ + +(use nanomsg defstruct srfi-18) + +;;====================================================================== +;; Commands +;;====================================================================== + +(define *commands* (make-hash-table)) + +(defstruct cmd + key + proc + ctype ;; command type; 'r (read), 'w (write) or 't (transaction) + ) + +(define (register-command key ctype proc) + (hash-table-set! *commands* + key + (make-cmd key: key ctype: ctype proc: proc))) + +(define (get-proc key) + (cmd-proc (hash-table-ref key *commands*))) + +(for-each + (lambda (dat) + (apply register-command dat)) + `( (create-run w ,create-run) + (create-step w ,create-step) + (create-test w ,create-test) + (get-test-id r ,get-test-id) + (get-run-id r ,get-run-id) + ;; (open-db w ,open-create-db) + (step-set-ss w ,step-set-state-status) + (test-set-ss w ,test-set-state-status) + (test-get-tests r ,test-get-tests) )) + +;;====================================================================== +;; Server/client stuff +;;====================================================================== + +(define-inline (encode data) + (with-output-to-string + (lambda () + (write data)))) + +(define-inline (decode data) + (with-input-from-string + data + (lambda () + (read)))) + +;;====================================================================== +;; Command queue +;;====================================================================== + +(defstruct qitem + command + params + host-port) + +(define *cmd-queue* '()) +(define *queue-mutex* (make-mutex)) + +(define (queue-push cmddat) + (mutex-lock! *queue-mutex*) + (set! *cmd-queue* (cons cmddat *cmd-queue*)) + (mutex-unlock! *queue-mutex*)) + +;; get all the cmds of type ctype and return them, also remove them from the queue +(define (queue-take ctype) + (mutex-lock! *queue-mutex*) + (let ((res (filter (lambda (x)(eq? (cmd-ctype x) ctype)) *cmd-queue*)) + (rem (filter (lambda (x)(not (eq? (cmd-ctype x) ctype))) *cmd-queue*))) + (set! *queue* rem) + (mutex-unlock! *queue-mutex*) + res)) + +(define (queue-process-commands dbconn commands) + (for-each + (lambda (qitem) + (let ((soc (request-connect (qitem-host-port qitem))) ;; we will be sending the data back to host-port via soc + (cmd (hash-table-ref/default *commands* (qitem-command qitem) #f))) + (if cmd + (let* ((res (apply (get-proc cmd) dbconn (qitem-params qitem))) + (pkg (encode `((r . ,res))))) + (nn-send soc pkg) + (if (not (eq? (nn-recv soc)) "ok") + (print "Client failed to receive properly the data from " cmd " request")))))) + commands)) + +;; the continuously running queue processor +;; +(define ((queue-processor dbconn)) + (let loop () + (queue-process-commands dbconn (queue-take 'r)) ;; reads first, probably largest numbers of them + (queue-process-commands dbconn (queue-take 'w)) ;; writes next + (queue-process-commands dbconn (queue-take 't)) ;; lastly process transactions + (thread-sleep! 0.2) ;; open up the db for any other processes to access + (loop))) + +;;====================================================================== +;; Client stuff +;;====================================================================== + +;; client struct +(defstruct client + host-port + socket + last-access) + +(define *clients* (make-hash-table)) ;; host:port -> client struct +(define *client-mutex* (make-mutex)) + +;; add a channel or return existing channel, this is a normal req +;; +(define (request-connect host-port) + (mutex-lock! *client-mutex*) + (let* ((curr (hash-table-ref/default *clients* host-port #f))) + (if curr + (begin + (mutex-unlock! *client-mutex*) + curr) + (let ((req (nn-socket 'req))) + (nn-connect req host-port) ;; "inproc://test") + (hash-table-set! *clients* host-port req) + (mutex-unlock! *client-mutex*) + req)))) + +;; open up a channel to the server and send a package of info for the server to act on +;; host-port needs to be found and provided +;; +(define (generic-db-access host-port) + (let* ((soc (request-connect host-port)) + ;; NEED *MY* host/port also to let the server know where to send the results + ))) + + +(define (client-send-receive soc msg) + (nn-send soc msg) + (nn-recv soc)) + +;;====================================================================== +;; Server +;;====================================================================== + +(defstruct srvdat + host + port + soc) + +;; remember, everyone starts a server, both client and the actual server alike. +;; clients start a server for the server to return results to. +;; +(define (start-raw-server #!key (given-host-name #f)) + (let ((srvdat (let loop ((portnum 10000)) + (handle-exceptions + exn + (if (< portnum 64000) + (loop (+ portnum 1)) + #f) + (let* ((rep (nn-socket 'rep))) + (nn-bind rep (conc "tcp://*:" portnum)) ;; "inproc://test") + (make-srvdat port: portnum soc: rep))))) + (host-name (or give-host-name (get-host-name))) + (soc (srvdat-soc srvdat))) + (srvdat-host-set! srvdat host-name) + srvdat)) + +;; The actual *server* side server +;; +(define (start-server dbconn #!key (given-host-name #f)) + (let* ((srvdat (start-raw-server given-host-name: given-host-name)) + (host-name (srvdat-host srvdat)) + (soc (srvdat-soc srvdat))) + + ;; start the queue processor + (thread-start! (queue-processory dbconn) "Queue processor") + ;; msg is an alist + ;; 'r host:port <== where to return the data + ;; 'p params <== data to apply the command to + ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default + ;; 'c command <== look up the function to call using this key + ;; + (let loop ((msg-in (nn-recv soc))) + (if (not (equal? msg-in "quit")) + (let* ((dat (decode msg-in)) + (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client + (params (alist-ref 'p dat)) + (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) + (all-good (and host-port params command (hash-table-exists? *commands* command)))) + (if all-good + (let ((cmddat (make-qitem + command: command + host-port: host-port + params: params))) + (queue-push cmddat) ;; put request into the queue + (nn-send soc "queued")) ;; reply with "queued" + (print "ERROR: BAD request " dat)) + (loop (nn-recv soc))))) + (nn-close soc))) + +;;====================================================================== +;; Gasket layer +;;====================================================================== + +(define rmt:open-create-db open-create-db) +(define (rmt:create-run . params) + + ADDED minimt/setup.scm Index: minimt/setup.scm ================================================================== --- /dev/null +++ minimt/setup.scm @@ -0,0 +1,17 @@ +(define *remotehost* "orion") +(define *homehost* "zeus") +(define *homepath* "/nfs/phoebe/disk1/home/mfs_matt/data/megatest/minimt/runtest") +(define *numsteps* 20) +(define *numtests* 20) +(define *numruns* 5) +(define *targets* '("targ1")) +(define *testdelay* 0) +(define *rundelay* 0) +(define *launchdelay* 0) +(define *stepdelay* 0) + +(use trace) +(trace-call-sites #t) +(trace +;; open-create-db + ) Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -21,10 +21,14 @@ DROP TABLE IF EXISTS test_data; DROP TABLE IF EXISTS test_rundat; DROP TABLE IF EXISTS archives; DROP TABLE IF EXISTS session_vars; DROP TABLE IF EXISTS sessions; +DROP TABLE IF EXISTS tags; +DROP TABLE IF EXISTS users; +DROP TABLE IF EXISTS webviews; +DROP TABLE IF EXISTS area_tags; CREATE TABLE IF NOT EXISTS session_vars ( id SERIAL PRIMARY KEY, session_id INTEGER, page TEXT, @@ -41,10 +45,21 @@ area_name TEXT NOT NULL, area_path TEXT NOT NULL, last_sync INTEGER DEFAULT 0, CONSTRAINT areaconstraint UNIQUE (area_name)); +CREATE TABLE IF NOT EXISTS tags ( + id SERIAL PRIMARY KEY, + tag_name TEXT NOT NULL, + CONSTRAINT tagconstraint UNIQUE (tag_name)); + +CREATE TABLE IF NOT EXISTS area_tags ( + id SERIAL PRIMARY KEY, + tag_id INTEGER DEFAULT 0, + area_id INTEGER DEFAULT 0, + CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id)); + INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.'); CREATE TABLE IF NOT EXISTS ttype ( id SERIAL PRIMARY KEY, target_spec TEXT DEFAULT ''); @@ -61,11 +76,11 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT extract(epoch from now()), area_id INTEGER DEFAULT 0, - CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name)); + CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id)); CREATE TABLE IF NOT EXISTS run_stats ( id SERIAL PRIMARY KEY, run_id INTEGER, state TEXT, @@ -208,9 +223,27 @@ status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT); +CREATE TABLE IF NOT EXISTS users( + id SERIAL PRIMARY KEY , + usename TEXT NOT NULL, + fullname TEXT NOT NULL, + email TEXT NOT NULL, + deleted INTEGER default 0 +); + +CREATE TABLE IF NOT EXISTS webviews( + id SERIAL PRIMARY KEY , + owner_id INTEGER NOT NULL, + name TEXT NOT NULL, + ttype_id INTEGER DEFAULT 0, + view_specifics TEXT , + col TEXT NOT NULL, + row TEXT NOT NULL, + deleted INTEGER default 0 +); -- TRUNCATE archive_blocks, archive_allocations, extradat, metadat, -- access_log, tests, test_steps, test_data, test_rundat, archives, runs, -- run_stats, test_meta, tasks_queue, archive_disks; Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -177,38 +177,51 @@ (event-time (db:test-get-event_time test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) ;; (mutex-lock! *triggers-mutex*) - (if (and test-name - test-rundir) ;; #f means no dir set yet - ;; (common:file-exists? test-rundir) - ;; (directory? test-rundir)) - (call-with-environment-variables - (list (cons "MT_TEST_NAME" (or test-name "no such test")) - (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) - (cons "MT_ITEMPATH" (or item-path ""))) - (lambda () - (if (directory-exists? test-rundir) - (push-directory test-rundir) - (push-directory *toppath*)) - (set! tconfig (mt:lazy-read-test-config test-name)) - (for-each (lambda (trigger) - (let* ((munged-trigger (string-translate trigger "/ " "--")) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus + "\n error: " ((condition-property-accessor 'exn 'message) exn) + "\n test-rundir="test-rundir + "\n test-name="test-name + "\n item-path="item-path + "\n state="state + "\n status="status + "\n") + (print-call-chain (current-error-port)) + #f) + (if (and test-name + test-rundir) ;; #f means no dir set yet + ;; (common:file-exists? test-rundir) + ;; (directory? test-rundir)) + (call-with-environment-variables + (list (cons "MT_TEST_NAME" (or test-name "no such test")) + (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) + (cons "MT_ITEMPATH" (or item-path ""))) + (lambda () + (if (directory-exists? test-rundir) + (push-directory test-rundir) + (push-directory *toppath*)) + (set! tconfig (mt:lazy-read-test-config test-name)) + (for-each (lambda (trigger) + (let* ((munged-trigger (string-translate trigger "/ " "--")) (logname (conc "last-trigger-" munged-trigger ".log"))) - ;; first any triggers from the testconfig - (let ((cmd (configf:lookup tconfig "triggers" trigger))) - (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status))) - ;; next any triggers from megatest.config - (let ((cmd (configf:lookup *configdat* "triggers" trigger))) - (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status))))) - (list - (conc state "/" status) - (conc state "/") - (conc "/" status))) + ;; first any triggers from the testconfig + (let ((cmd (configf:lookup tconfig "triggers" trigger))) + (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status))) + ;; next any triggers from megatest.config + (let ((cmd (configf:lookup *configdat* "triggers" trigger))) + (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status))))) + (list + (conc state "/" status) + (conc state "/") + (conc "/" status))) (pop-directory)) - )) + ))) ;; (mutex-unlock! *triggers-mutex*) ))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -1,6 +1,6 @@ -;; Copyright 2006-2017, Matthew Welland. +; Copyright 2006-2017, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -14,11 +14,11 @@ (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) - (prefix nanomsg nmsg:)) + nanomsg) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) @@ -120,10 +120,14 @@ gendot : generate a graphviz dot file from pkts. Contour actions: process : runs import, rungen and dispatch +Trigger propagation actions: + tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section + tlisten -port N : listen for trigger info on port N + Selectors -immediate : apply this action immediately, default is to queue up actions -area areapatt1,area2... : apply this action only to the specified areas -target key1/key2/... : run for key1, key2, etc. -test-patt p1/p2,p3/... : % is wildcard @@ -182,10 +186,11 @@ ("-load" . #f) ;; load and exectute a scheme file ("-log" . #f) ("-msg" . M) ("-start-dir" . S) ("-set-vars" . v) + ("-config" . r) )) (define *switch-keys* '( ("-h" . #f) ("-help" . #f) @@ -368,11 +373,11 @@ (if (and (not (null? remargs)) (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") - (member *action* '("db")) ;; very loose checks on db. + (member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen (equal? *action* "show") ;; just keep going if list ))) (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) (if (or (args:any? "-h" "help" "-help" "--help") @@ -380,12 +385,82 @@ (begin (print help) (exit 1))) ;;====================================================================== +;; Nanomsg transport +;;====================================================================== + +(define-inline (encode data) + (with-output-to-string + (lambda () + (write data)))) + +(define-inline (decode data) + (with-input-from-string + data + (lambda () + (read)))) + +(define (is-port-in-use port-num) + (let* ((ret #f)) + (let-values (((inp oup pid) + (process "netstat" (list "-tulpn" )))) + (let loop ((inl (read-line inp))) + (if (not (eof-object? inl)) + (begin + (if (string-search (regexp (conc ":" port-num)) inl) + (begin + ;(print "Output: " inl) + (set! ret #t)) + (loop (read-line inp))))))) +ret)) + +;;start a server, returns the connection +;; +(define (start-nn-server portnum ) + (let ((rep (nn-socket 'rep))) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + (print "ERROR: Failed to start server \"" emsg "\"") + (exit 1)) + + (nn-bind rep (conc "tcp://*:" portnum))) + rep)) +;; open connection to server, send message, close connection +;; +(define (open-send-close-nn host-port msg #!key (timeout 3)) ;; default timeout is 3 seconds + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f)) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + (print "ERROR: Failed to connect/send to " uri " message was \"" emsg "\"") + #f) + (nn-connect req uri) + (nn-send req msg) + ;; NEED timer here! + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (set! res (if (equal? resp "ok") + #t + #f)))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) +;;====================================================================== ;; Runs ;;====================================================================== ;; make a runname ;; @@ -964,11 +1039,11 @@ (if (and (> cpuload maxload) (member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit (print "WARNING: cpuload too high, skipping processing of " uuid) (begin (print "RUNNING: " fullcmd) - (system fullcmd) + (system fullcmd) ;; replace with process ... (mark-processed pdb (list (alist-ref 'id pktdat))) (let-values (((ack-uuid ack-pkt) (add-z-card (construct-sdat 'P uuid 'T (case (string->symbol action) @@ -1121,11 +1196,49 @@ (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-sqlite3.sql"))) (if (common:file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((junk) - (rmt:get-keys)))))))) + (rmt:get-keys)))))) + ((tsend) + (if (null? remargs) + (print "ERROR: missing data to send to trigger listeners") + (let* ((msg (car remargs)) + (mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (listeners (configf:get-section mtconf "listeners")) + (prev-seen (make-hash-table))) ;; catch duplicates + (for-each + (lambda (listener) + (let ((host-port (car listener)) + (remdat (cdr listener))) + (print "sending " msg " to " host-port) + (open-send-close-nn host-port msg timeout: 2))) + listeners)))) + ((tlisten) + (if (null? remargs) + (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"") + (let ((portnum (string->number (car remargs)))) + + (if (not portnum) + (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs)) + (begin + (if (not (is-port-in-use portnum)) + (let* ((rep (start-nn-server portnum)) + (mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (script (configf:lookup mtconf "listener" "script"))) + (print "Listening on port " portnum " for messages") + (let loop ((instr (nn-recv rep))) + (print "received " instr ", running \"" script " " instr "\"") + (system (conc script " '" instr "'")) + (nn-send rep "ok") + (loop (nn-recv rep)))) + (print "ERROR: Port " portnum " already in use. Try another port"))))))) + + )) ;; the end + ;; If HTTP_HOST is defined then we must be in the cgi environment ;; so run stml and exit ;; (if (get-environment-variable "HTTP_HOST") ADDED nexttag.rb Index: nexttag.rb ================================================================== --- /dev/null +++ nexttag.rb @@ -0,0 +1,46 @@ +#!/usr/bin/env ruby + + +def get_next_tag(branch) + + + + abort "Not on a version branch like v1.64 (got: >#{branch}<)" unless branch.match(/^v\d\.\d\d$/) + + #puts "this branch: #{branch}" + + tag_pat = /#{branch}(\d\d)/ + remote=`fsl remote`.chomp.sub(/^file:\/\//,'') # get tagset from origin + cmd="fossil tag -R '#{remote}' list" + tags = `#{cmd}`.split /\n/ + abort "fossil command failed [#{cmd}]" if $? != 0 + branch_tags = tags.find_all{|x| x.match(tag_pat) }.sort + if branch_tags.length == 0 + return branch + "01" + else + latest_tag = branch_tags.last + m1 = latest_tag.match(tag_pat) + minor_digits = m1[1].to_i + 1 + if (minor_digits % 10) == 0 + minor_digits += 1 + end + new_tag=sprintf("%s%02d", branch, minor_digits) + return new_tag + end +end + +branch = `fossil branch`.sub(/\A.*\* /m,'').sub(/\n.*\z/m,'') +tag= get_next_tag(branch) + +puts "TODO: Write to megatest-version.scm:" +puts ";; Always use two or four digit decimal +;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. + +(declare (unit megatest-version)) + +(define megatest-version #{tag.sub(/^v/,'')}) + +" + +puts "TODO: fossil tag add #{tag} #{branch}" +puts "" Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -74,16 +74,19 @@ (let* ((fh (open-input-pipe cmd)) (res (port-proc->list fh proc)) (status (close-input-pipe fh))) (if (eq? status 0) res #f))) -(define (process:cmd-run->list cmd) - (let* ((fh (open-input-pipe cmd)) - (res (port->list fh)) - (status (close-input-pipe fh))) - (list res status))) - +(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) + (common:with-env-vars + delta-env-alist-or-hash-table + (lambda () + (let* ((fh (open-input-pipe cmd)) + (res (port->list fh)) + (status (close-input-pipe fh))) + (list res status))))) + (define (port->list fh) (if (eof-object? fh) #f (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -126,24 +126,25 @@ ;; This block was for pre-emptively resetting the connection if there had been no communication for some time. ;; I don't think it adds any value. If the server is not there, just fail and start a new connection. ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout) ;; - ;; ;;DOT CASE4 [label="reset\nconnection"]; - ;; ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} - ;; ;;DOT CASE4 -> "rmt:send-receive"; - ;; ;; reset the connection if it has been unused too long - ;; ((and runremote - ;; (remote-conndat runremote) - ;; (let ((expire-time (+ (- start-time (remote-server-timeout runremote))(random 10)))) ;; Subtract or add the random value? Seems like it should be substract but Neither fixes the "WARNING: failure in with-input-from-request to #.\n message: Server closed connection before sending response" - ;; (< (http-transport:server-dat-get-last-access (remote-conndat runremote)) expire-time))) - ;; (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") - ;; (http-transport:close-connections area-dat: runremote) - ;; (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. - ;; (mutex-unlock! *rmt-mutex*) - ;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) - + ;;DOT CASE4 [label="reset\nconnection"]; + ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} + ;;DOT CASE4 -> "rmt:send-receive"; + ;; reset the connection if it has been unused too long + ((and runremote + (remote-conndat runremote) + (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on + (+ (http-transport:server-dat-get-last-access (remote-conndat runremote)) + (remote-server-timeout runremote)))) + (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") + (http-transport:close-connections area-dat: runremote) + (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. + (mutex-unlock! *rmt-mutex*) + (rmt:send-receive cmd rid params attemptnum: attemptnum)) + ;;DOT CASE5 [label="local\nread"]; ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5}; ;;DOT CASE5 -> "rmt:open-qry-close-locally"; ;; on homehost and this is a read @@ -228,13 +229,13 @@ ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11}; ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"]; ;;DOT CASE11 -> "RESULT" [label="call succeeded"]; ;; not on homehost, do server query (else - (mutex-unlock! *rmt-mutex*) + ;; (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") - (mutex-lock! *rmt-mutex*) + ;; (mutex-lock! *rmt-mutex*) (let* ((conninfo (remote-conndat runremote)) (dat (case (remote-transport runremote) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away (http-transport:client-api-send-receive 0 conninfo cmd params) ((commfail)(vector #f "communications fail")) @@ -242,18 +243,26 @@ (else (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported") (exit)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) - (if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time + (if (and (vector? conninfo) (< 5 (vector-length conninfo))) + (http-transport:server-dat-update-last-access conninfo) ;; refresh access time + (begin + (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo) + (set! conninfo #f) + (remote-conndat-set! *runremote* #f) + (http-transport:close-connections area-dat: runremote))) ;; (mutex-unlock! *rmt-mutex*) (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) (mutex-unlock! *rmt-mutex*) (if success ;; success only tells us that the transport was successful, have to examine the data to see if there was a detected issue at the other end (if (and (vector? res) (eq? (vector-length res) 2) (eq? (vector-ref res 1) 'overloaded)) ;; since we are looking at the data to carry the error we'll use a fairly obtuse combo to minimise the chances of some sort of collision. + ;; this is the case where the returned data is bad or the server is overloaded and we want + ;; to ease off the queries (let ((wait-delay (+ attemptnum (* attemptnum 10)))) (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") (mutex-lock! *rmt-mutex*) (http-transport:close-connections area-dat: runremote) (set! *runremote* #f) ;; force starting over @@ -261,14 +270,16 @@ (thread-sleep! wait-delay) (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) res) ;; All good, return res (begin (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) - (remote-conndat-set! runremote #f) + (mutex-lock! *rmt-mutex*) + (remote-conndat-set! runremote #f) (http-transport:close-connections area-dat: runremote) (remote-server-url-set! runremote #f) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") ;; (if (not (server:check-if-running *toppath*)) ;; (server:start-and-wait *toppath*)) (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) ;;DOT } @@ -489,10 +500,14 @@ (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) (rmt:send-receive 'get-target run-id (list run-id))) + +(define (rmt:get-run-times runpatt targetpatt) + (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) + ;;====================================================================== ;; T E S T S ;;====================================================================== @@ -540,10 +555,13 @@ ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) +(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) + (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) + ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids @@ -667,10 +685,13 @@ (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) (define (rmt:get-raw-run-stats run-id) (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) +(define (rmt:get-test-times runname target) + (rmt:send-receive 'get-test-times #f (list runname target ))) + ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) @@ -696,10 +717,13 @@ (rmt:send-receive 'delete-old-deleted-test-records #f '())) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) +(define (rmt:simple-get-runs runpatt count offset target) + (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target))) + (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) (rmt:send-receive 'get-prev-run-ids #f (list run-id))) @@ -804,19 +828,24 @@ (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) +(define (rmt:get-steps-info-by-id test-step-id) + (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id))) + ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt))) +(define (rmt:get-data-info-by-id test-data-id) + (rmt:send-receive 'get-data-info-by-id #f (list test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) @@ -858,10 +887,13 @@ (rmt:send-receive 'no-sync-get/default #f `(,var ,default))) (define (rmt:no-sync-del! var) (rmt:send-receive 'no-sync-del! #f `(,var))) +(define (rmt:no-sync-get-lock keyname) + (rmt:send-receive 'no-sync-get-lock #f `(,keyname))) + ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) Index: rpctest/rpctest-continuous-client.scm ================================================================== --- rpctest/rpctest-continuous-client.scm +++ rpctest/rpctest-continuous-client.scm @@ -17,11 +17,11 @@ (print "Operation: " operation ", param: " param) ;; have a pool of db's to pick from (define *dbpool* '()) (define *pool-mutex* (make-mutex)) -1 + (define (get-db) (mutex-lock! *pool-mutex*) (if (null? *dbpool*) (begin (mutex-unlock! *pool-mutex*) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -191,11 +191,12 @@ (args:get-arg "-one-pass")) (exit 0)) (thread-sleep! (cond ((> (runs:dat-can-run-more-tests-count runsdat) 20) (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) - 2);; obviously haven't had any work to do for a while + (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.1) ;; was 2 + );; obviously haven't had any work to do for a while (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) @@ -265,10 +266,59 @@ (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf) (system (conc run-pre-hook " >> " actual-logf " 2>&1")) (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run."))) (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run."))))) +(define (runs:run-post-hook run-id) + (let* ((run-post-hook (configf:lookup *configdat* "runs" "post-hook")) + (existing-tests (if run-post-hook + (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + 'dashboard) + '())) + (log-dir (conc *toppath* "/logs")) + (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (full-log-fname (conc log-dir "/" log-file))) + (if run-post-hook + ;; (if (null? existing-tests) + ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run."))))) + (let* ((use-log-dir (if (not (directory-exists? log-dir)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir) + #f) + (create-directory log-dir #t) + #t) + #t)) + (start-time (current-seconds)) + (actual-logf (if use-log-dir full-log-fname log-file))) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file)) + (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf) + (system (conc run-post-hook " >> " actual-logf " 2>&1")) + (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) + +;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. +(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) + (let* ((tests-in-testpatt + (map + (lambda (test-patt-item) + (car (string-split test-patt-item "/"))) + (string-split test-patt ","))) + (waitors-upon-not-mentioned (lset-difference equal? waitors-upon tests-in-testpatt))) + (null? waitors-upon-not-mentioned))) + ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names @@ -283,10 +333,11 @@ ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done + (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) ;; (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (allowed-tests #f)) @@ -325,13 +376,13 @@ (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand)) - ;; force the starting of a server - (debug:print 0 *default-log-port* "waiting on server...") - (server:start-and-wait *toppath*) + ;; force the starting of a server -- removed BB 17ww28 - no longer needed. + ;;(debug:print 0 *default-log-port* "waiting on server...") + ;;(server:start-and-wait *toppath*) (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (set! runconf (if (common:file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (begin @@ -425,16 +476,18 @@ ;; ;; What happended, this code is now duplicated in tests!? ;; ;;====================================================================== - (if (not (null? test-names)) + (if (not (null? test-names)) ;; BEGIN test-names loop (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (setenv "MT_TEST_NAME" hed) ;; - (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry))) + (let*-values (((waitons waitors config) + (tests:get-waitons hed all-tests-registry))) (debug:print-info 8 *default-log-port* "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (or (member hed waitons) (member hed waitors)) @@ -442,31 +495,42 @@ (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!") (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)) (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors)))) ;; (items (items:get-items-from-config config))) - (if (not (hash-table-ref/default test-records hed #f)) - (hash-table-set! test-records - hed (vector hed ;; 0 - config ;; 1 - waitons ;; 2 + (if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once + (hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue + hed (vector hed ;; 0 ;; testname + config ;; 1 + waitons ;; 2 (config-lookup config "requirements" "priority") ;; priority 3 - (tests:get-items config) ;; expand the [items] and or [itemstable] into explict items + (tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items #f ;; itemsdat 5 #f ;; spare - used for item-path waitors ;; ))) - (for-each + ;; update waitors-upon here + (for-each + (lambda (waiton) + (let* ((current-waitors-upon (hash-table-ref/default waitors-upon waiton '()))) + (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] is "current-waitors-upon ) + (when (not (member hed current-waitors-upon)) + (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] << "hed ) + (hash-table-set! waitors-upon waiton (cons hed current-waitors-upon))))) + (if (list? waitons) waitons '())) + (debug:print-info 8 *default-log-port* " process waitons&waitors of "hed": "(delete-duplicates (append waitons waitors))) + (for-each (lambda (waiton) (if (and waiton (not (member waiton test-names))) - (let* ((waiton-record (hash-table-ref/default test-records waiton #f)) + (let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? test-patts (hash-table-ref/default waitors-upon waiton '()))) + (waiton-record (hash-table-ref/default test-records waiton #f)) (waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f)) (waiton-itemized (and waiton-tconfig (or (hash-table-ref/default waiton-tconfig "items" #f) (hash-table-ref/default waiton-tconfig "itemstable" #f)))) (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) - (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) + (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) ;; BB: items expanded here - chained-waiton goes awry by now. (debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt ;; is this satisfied by merely appending "/" to the waiton name added to the list? ;; @@ -475,22 +539,25 @@ ;; if we have this waiton already processed once we can analzye it for extending ;; tests to be run, since we can't properly process waitons unless they have been ;; initially added we add them again to be processed on second round AND add the hed ;; back in to also be processed on second round ;; - (if waiton-tconfig - (begin - (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read - (if waiton-itemized - (begin - (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts) - (set! required-tests (cons (conc waiton "/") required-tests)) - (set! test-patts new-test-patts)) - (begin - (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests") - (set! required-tests (cons waiton required-tests)) - (set! test-patts new-test-patts)))) + (if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig. + (if waiton-itemized + (if waitors-in-testpatt + (begin + (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts) + (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read + (set! required-tests (cons (conc waiton "/") required-tests)) + (set! test-patts new-test-patts)) + (begin + (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it") + (set! tal (append (cons waiton tal)(list hed))))) + (begin + (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests") + (set! required-tests (cons waiton required-tests)) + (set! test-patts new-test-patts))) (begin (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it") (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts @@ -499,14 +566,15 @@ ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons ))) (delete-duplicates (append waitons waitors))) (let ((remtests (delete-duplicates (append waitons tal)))) + (debug:print-info 8 *default-log-port* " remtests are "remtests) (if (not (null? remtests)) (begin ;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", ")) - (loop (car remtests)(cdr remtests)))))))) + (loop (car remtests)(cdr remtests)))))))) ;; END test-names loop (if (not (null? required-tests)) (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) @@ -520,30 +588,20 @@ (begin (print-call-chain) (print " message: " ((condition-property-accessor 'exn 'message) exn))) (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) - ;; (handle-exceptions - ;; exn - ;; (begin - ;; (print-call-chain (current-error-port)) - ;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) - ;; (if (> run-queue-retries 0) - ;; (begin - ;; (set! run-queue-retries (- run-queue-retries 1)) - ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) "runs:run-tests-queue")) - (th2 (make-thread (lambda () + (th2 (make-thread (lambda () ;; BBQ: why are we visiting ALL runs here? ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (if keep-going (handle-exceptions exn (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id) - (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) + (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27) run-ids))) "runs: mark-incompletes"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) @@ -574,31 +632,52 @@ ;; but have items in reg; loop with (car reg)(cdr reg) '() reruns ;; If reg is empty => all done (define (runs:queue-next-hed tal reg n regfull) (if regfull - (car reg) + (if (null? reg) #f (car reg)) (if (null? tal) ;; tal is used up, pop from reg - (car reg) + (if (null? reg) #f (car reg)) (car tal)))) (define (runs:queue-next-tal tal reg n regfull) (if regfull tal (if (null? tal) ;; must transfer from reg - (cdr reg) + (if (null? reg) '() (cdr reg)) (cdr tal)))) (define (runs:queue-next-reg tal reg n regfull) (if regfull - (cdr reg) + (if (null? reg) '() (cdr reg)) ;; EXPLORE: reorder (cdr reg) such that looping is more efficient (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal '() reg))) +;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216 +;; +(define (runs:loop-values tal reg reglen regfull reruns) + (list (runs:queue-next-hed tal reg reglen regfull) ;; hed + (runs:queue-next-tal tal reg reglen regfull) ;; tal + (runs:queue-next-reg tal reg reglen regfull) ;; reg + reruns)) ;; reruns + +;; objective - iterate thru tests +;; => want to prioritize tests we haven't seen before +;; => sometimes need to squeeze things in (added to reg) +;; => review of a previously seen test is higher priority of never visited test +;; reg - list of previously visited tests +;; tal - list of never visited tests +;; prefer next hed to be from reg than tal. + (define runs:nothing-left-in-queue-count 0) +;; 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) (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 @@ -605,15 +684,26 @@ (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)) (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))) + (runnables (runs:calc-runnable prereqs-not-met)) + (unexpanded-prereqs + (filter (lambda (testname) + (let* ((test-rec (hash-table-ref test-records testname)) + (items (tests:testqueue-get-items test-rec))) + ;;(BB> "HEY " testname "=>"items) + (or (procedure? items)(eq? items 'have-procedure)))) + waitons)) + + + ) (debug:print-info 4 *default-log-port* "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) "\n non-completed: " (runs:pretty-string non-completed) @@ -634,14 +724,11 @@ (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) + (runs:loop-values tal reg reglen regfull reruns) (begin (debug:print-info 0 *default-log-port* "Nothing left in the queue!") ;; If get here twice then we know we've tried to expand all items ;; since there must be a logic issue with the handling of loops in the ;; items expand phase we will brute force an exit here. @@ -650,11 +737,20 @@ (debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") (exit 0)) (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) #f))) - ;; + ;; desired result of below cond branch: + ;; we want to expand items in our test of interest (hed) in the following cases: + ;; case 1 - mode is itemmatch or itemwait: + ;; - all prereq tests have been expanded + ;; - at least one prereq's items have completed + ;; case 2 - mode is toplevel + ;; - prereqs are completed. + ;; - or no prereqs can complete + ;; case 3 - mode not specified + ;; - prereqs are completed and passed (we could consider removing "and passed" -- it would change behavior from current) ((or (null? prereqs-not-met) (and (member 'toplevel testmode) (null? non-completed))) (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) @@ -705,41 +801,37 @@ (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue") (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) (if (and (null? trimmed-tal) (null? trimmed-reg)) #f - (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) - (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) - (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) - reruns))) + (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns) + )) (list (car newtal)(append (cdr newtal) reg) '() reruns)))) - ((and (null? fails) + ((and (null? fails) ;; have not-started tests, but unable to run them. everything looks completed with no prospect of unsticking something that is stuck. we should mark hed as moribund and exit or continue if there are more tests to consider (null? prereq-fails) (null? non-completed)) (if (runs:can-keep-running? hed 20) (begin (runs:inc-cant-run-tests hed) - (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) + (debug:print-info 0 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) ;; ;; getting here likely means the system is way overloaded, kill a full minute before continuing - (thread-sleep! 60) + (thread-sleep! 60) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)))) + (runs:loop-values tal reg reglen regfull reruns) + ))) ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) @@ -747,32 +839,28 @@ (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (if (not (null? prereq-fails)) - (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") - (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) + ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed) + ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work. (if (or (not (null? reg))(not (null? tal))) (begin (hash-table-set! test-registry hed 'CANNOTRUN) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))) + (runs:loop-values tal reg reglen regfull (cons hed reruns)) + ) #f)) ;; #f flags do not loop - + ((and (not (null? fails))(member 'toplevel testmode)) (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over. (else (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") - ;; (list (runs:queue-next-hed tal reg reglen regfull) - ;; (runs:queue-next-tal tal reg reglen regfull) - ;; (runs:queue-next-reg tal reg reglen regfull) - ;; reruns) (list (car newtal)(cdr newtal) reg reruns))))) (define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) (if (null? inlst) '() @@ -792,10 +880,13 @@ ;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) (define (runs:process-expanded-tests runsdat testdat) ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). + (debug:print 2 *default-log-port* "runs:process-expanded-tests; testdat:" ) + (debug:print 2 *default-log-port* (with-output-to-string + (lambda () (pp (runs:testdat->alist testdat) )))) (let* ((hed (runs:testdat-hed testdat)) (tal (runs:testdat-tal testdat)) (reg (runs:testdat-reg testdat)) (reruns (runs:testdat-reruns testdat)) (test-name (runs:testdat-test-name testdat)) @@ -829,11 +920,11 @@ (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) + (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) '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! @@ -863,23 +954,20 @@ ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) - (cond + (cond ; cond 894- 1067 ;; Check item path against item-patts, ;; ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) + (runs:loop-values tal reg reglen regfull reruns) #f)) ;; Register tests ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) @@ -900,11 +988,11 @@ (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) - (list (runs:queue-next-hed tal reg reglen regfull) + (list (runs:queue-next-hed tal reg reglen regfull) ;; cannot replace with a call to runs:loop-values as the logic is different for reg (runs:queue-next-tal tal reg reglen regfull) ;; NB// Here we are building reg as we register tests ;; if regfull we must pop the front item off reg (if regfull (append (cdr reg) (list hed)) @@ -957,14 +1045,11 @@ (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) + (runs:loop-values tal reg reglen regfull reruns) #f)) ;; must be we have unmet prerequisites ;; (else @@ -984,68 +1069,67 @@ (if (runs:lownoise "Waiting for more work to do..." 60) (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) (thread-sleep! 1) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again - (if (or (not (null? reg))(not (null? tal))) - (if (vector? hed) + (begin + (let ((my-test-id (rmt:get-test-id run-id test-name item-path))) + (mt:test-set-state-status-by-id run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2")) + + + + (if (or (not (null? reg))(not (null? tal))) + (if (vector? hed) (begin (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) + + (if (not (null? fails)) + ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) + ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) ) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? - )) - (let ((nth-try (hash-table-ref/default test-registry hed 0))) + (runs:loop-values tal reg reglen regfull reruns)) + (let ((nth-try (hash-table-ref/default test-registry hed 0))) ;; hed not a vector... + (debug:print 2 *default-log-port* "nth-try("hed")="nth-try) (cond ((member "RUNNING" (map db:test-get-state prereqs-not-met)) (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) - (thread-sleep! 4) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) - ((or (not nth-try) + (thread-sleep! 0.1) + (runs:loop-values tal reg reglen regfull reruns)) + ((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try (and (number? nth-try) - (< nth-try 10))) + (< nth-try 2))) (hash-table-set! test-registry hed (if (number? nth-try) (+ nth-try 1) 0)) (if (runs:lownoise (conc "not removing test " hed) 60) (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (list hed tal reg reruns) - ;; (list (car newtal)(cdr newtal) reg reruns) - ;; (hash-table-set! test-registry hed 'removed) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) - ((symbol? nth-try) + (runs:loop-values newtal reg reglen regfull reruns)) + ((symbol? nth-try) ;; BB: 'done matches here in one case where prereq itemwait failed. This is first "try" (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW (if (null? tal) #f ;; yes, really (list (car tal)(cdr tal) reg reruns)) (begin (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) - (hash-table-set! test-registry hed 0) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)))) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry.")) + ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) + (mt:test-set-state-status-by-testname run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f) + (hash-table-set! test-registry hed 'removed) ;; was 0 + (if (not (and (null? reg) (null? tal))) + (runs:loop-values tal reg reglen regfull reruns) + #f)))) (else (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) @@ -1054,18 +1138,20 @@ (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) - ;; can't drop this - maybe running? Just keep trying - (let ((runable-tests (runs:runable-tests prereqs-not-met))) - (if (null? runable-tests) - #f ;; I think we are truly done here - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns))))))))) + ;; ELSE: can't drop this - maybe running? Just keep trying + + ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment + (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met? + (if (null? runable-tests) + #f ;; I think we are truly done here + (runs:loop-values newtal reg reglen regfull reruns))) + ;;) ;;from old experiment + ) ;; end if (or (not (null? reg))(not (null? tal))) + )))))) ;; scan a list of tests looking to see if any are potentially runnable ;; (define (runs:runable-tests tests) (filter (lambda (t) @@ -1165,50 +1251,50 @@ ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) (let* ((run-info (rmt:get-run-info run-id)) - (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) - (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registry (make-hash-table)) - (registry-mutex (make-mutex)) - (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) - (reglen (if (number? reglen-in) reglen-in 1)) - (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle - (last-time-some-running (current-seconds)) - ;; (tdbdat (tasks:open-db)) - (runsdat (make-runs:dat - ;; hed: hed - ;; tal: tal - ;; reg: reg - ;; reruns: reruns - reglen: reglen - regfull: #f ;; regfull - ;; test-record: test-record - runname: runname - ;; test-name: test-name - ;; item-path: item-path - ;; jobgroup: jobgroup - max-concurrent-jobs: max-concurrent-jobs - run-id: run-id - ;; waitons: waitons - ;; testmode: testmode - test-patts: test-patts - required-tests: required-tests - test-registry: test-registry - registry-mutex: registry-mutex - flags: flags - 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 - ))) + (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) + (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) + (test-registry (make-hash-table)) + (registry-mutex (make-mutex)) + (num-retries 0) + (max-retries (config-lookup *configdat* "setup" "maxretries")) + (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) + (reglen (if (number? reglen-in) reglen-in 1)) + (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle + (last-time-some-running (current-seconds)) + ;; (tdbdat (tasks:open-db)) + (runsdat (make-runs:dat + ;; hed: hed + ;; tal: tal + ;; reg: reg + ;; reruns: reruns + reglen: reglen + regfull: #f ;; regfull + ;; test-record: test-record + runname: runname + ;; test-name: test-name + ;; item-path: item-path + ;; jobgroup: jobgroup + max-concurrent-jobs: max-concurrent-jobs + run-id: run-id + ;; waitons: waitons + ;; testmode: testmode + test-patts: test-patts + required-tests: required-tests + test-registry: test-registry + registry-mutex: registry-mutex + flags: flags + 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 (for-each (lambda (trec) (let ((id (db:test-get-id trec)) @@ -1219,11 +1305,11 @@ (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st))))) tests-info) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) + (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) (runs:incremental-print-results run-id) @@ -1270,23 +1356,24 @@ itemmaps: itemmaps ;; prereqs-not-met: prereqs-not-met ))) (runs:dat-regfull-set! runsdat regfull) + ;; -- removed BB 17ww28 - no longer needed. ;; every 15 minutes verify the server is there for this run - (if (and (common:low-noise-print 240 "try start server" run-id) - (not (or (and *runremote* - (remote-server-url *runremote*) - (server:ping (remote-server-url *runremote*))) - (server:check-if-running *toppath*)))) - (server:kind-run *toppath*)) + ;; (if (and (common:low-noise-print 240 "try start server" run-id) + ;; (not (or (and *runremote* + ;; (remote-server-url *runremote*) + ;; (server:ping (remote-server-url *runremote*))) + ;; (server:check-if-running *toppath*)))) + ;; (server:kind-run *toppath*)) (if (> num-running 0) (set! last-time-some-running (current-seconds))) - (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) - (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) + (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) + (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) @@ -1408,15 +1495,15 @@ (loop (car tal)(cdr tal) reg reruns))) ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS - ((or (procedure? items)(eq? items 'have-procedure)) + ((or (procedure? items)(eq? items 'have-procedure)) ;; BB - target vars are env vars here? to allow expansion of [items]\nsomething [system echo $SOMETARGVAR], which is wonky (let ((can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) (if (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))) + (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 (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) @@ -1440,11 +1527,12 @@ ((not (null? reg)) ;; could we get here with leftovers? (debug:print-info 0 *default-log-port* "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - ))) + ))) ;; end loop on sorted test names + ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) @@ -1465,21 +1553,22 @@ (thread-sleep! 5) ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! + (runs:run-post-hook run-id) (debug:print-info 1 *default-log-port* "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) - (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) + (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...* (not (member (db:test-get-status test) '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))))) prereqs-not-met)) -(define (runs:calc-prereq-fail prereqs-not-met) +(define (runs:calc-prereq-fail prereqs-not-met) ;; REMOVEME since NOT_STARTED/PREQ_FAIL is now COMPLETED/PREQ_FAIL (filter (lambda (test) (and (vector? test) ;; not (string? test)) (equal? (db:test-get-state test) "NOT_STARTED") (not (member (db:test-get-status test) '("n/a" "KEEP_TRYING"))))) @@ -1740,19 +1829,97 @@ (+ 1 x)) 0 real-dir) ;; then the entire directory (runs:recursive-delete-with-error-msg real-dir)) +;; cleanup often needs to remove all but the last N runs per target +;; +;; target-patts a1/b1/c1,a2/b2/c2 ... +;; +;; This will fail if called with empty target or a bad target (i.e. missing or extra fields) +;; +(define (runs:get-hash-by-target target-patts runpatt) + (let* ((targets (string-split target-patts ",")) + (keys (rmt:get-keys)) + (res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... ) + (for-each + (lambda (target-patt) + (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt))) + (for-each + (lambda (run) + (let ((target (simple-run-target run))) + (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '()))))) + runs))) + targets) + res-ht)) + +;; delete runs older than X (weeks, days, months years etc.) +;; delete redundant runs within a target - N is the input +;; delete redundant runs within a target IFF older than given date/time AND keep at least N +;; +(define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print))) + (let* ((runs-ht (runs:get-hash-by-target target-patts runpatt)) + (age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f)) + (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400))) + (precmd (or (args:get-arg "-precmd") ""))) + (print "Actions: " actions) + (for-each + (lambda (target) + (let* ((runs (hash-table-ref runs-ht target)) + (sorted (sort runs (lambda (a b)(> (simple-run-event_time a)(simple-run-event_time b))))) + (to-remove (let* ((len (length sorted)) + (trim-amt (- len num-to-keep))) + (if (> trim-amt 0) + (take sorted trim-amt) + '())))) + (hash-table-set! runs-ht target to-remove) + (print target ":") + (for-each + (lambda (run) + (let ((remove (member run to-remove (lambda (a b) + (eq? (simple-run-id a) + (simple-run-id b)))))) + (if (and age (> (simple-run-event_time run) age-mark)) + (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age")) + (for-each + (lambda (action) + (case action + ((print) + (print " " (simple-run-runname run) + " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") + " " (if remove "REMOVE" ""))) + ((remove-runs) + (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))) + ((archive) + (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))))) + actions)))) + sorted))) + ;; (print "Sorted: " (map simple-run-event_time sorted)) + ;; (print "Remove: " (map simple-run-event_time to-remove)))) + (hash-table-keys runs-ht)) + runs-ht)) + +;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep) +;; (let ((data (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep))) +;; (for-each +;; (lambda (target) +;; (let ((runs-to-remove (hash-table-ref data target ))) +;; (for-each +;; (lambda (run) +;; (print "megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")) +;; runs-to-remove))) +;; (hash-table-keys data)))) + ;; Remove runs ;; fields are passing in through ;; action: ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) ;; (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) @@ -1760,11 +1927,12 @@ (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) - (bup-mutex (make-mutex))) + (bup-mutex (make-mutex)) + (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (let* ((write-access-actions '(remove-runs set-state-status archive run-wait)) (dbfile (conc *toppath* "/megatest.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode @@ -1936,13 +2104,15 @@ (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (rmt:delete-run run-id) - (rmt:delete-old-deleted-test-records) - ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) + (if (not keep-records) + (begin + (rmt:delete-run run-id) + (rmt:delete-old-deleted-test-records))) + ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 *default-log-port* "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -1956,12 +2126,28 @@ (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (common:file-exists? run-dir) ;; (resolve-pathname run-dir) (common:nice-path run-dir) - #f))) - (case mode + #f)) + (clean-mode (or mode 'remove-all)) + (test-id (db:test-get-id test)) + ;; (lock-key (conc "test-" test-id)) + ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) + ;; (expire-time (+ (current-seconds) 30))) ;; give up on getting the lock and steal it after 15 seconds + ;; (if (car lock) + ;; #t + ;; (if (> (current-seconds) expire-time) + ;; (begin + ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to clean test with id " test-id) + ;; (rmt:no-sync-del! lock-key) ;; destroy the lock + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; + ;; (begin + ;; (thread-sleep! 1) + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time))))))) + ) + (case clean-mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir @@ -1993,14 +2179,16 @@ (not (member run-dir (list "n/a" "/tmp/badname")))) (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (case mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) + (case clean-mode + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))) + ;; (rmt:no-sync-del! lock-key) + )) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== ADDED sample-sauth-paths.scm Index: sample-sauth-paths.scm ================================================================== --- /dev/null +++ sample-sauth-paths.scm @@ -0,0 +1,5 @@ +(define *db-path* "/path/to/db") +(define *exe-path* "/path/to/store/suids") +(define *exe-src* "/path/to/spublish/and/sretrieve/executables") +(define *sauth-path* "/path/to/production/sauthorize/exe") +(define *super-users* '("user1" "user2")) ADDED sauth-common.scm Index: sauth-common.scm ================================================================== --- /dev/null +++ sauth-common.scm @@ -0,0 +1,302 @@ + +;; 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 + (debug: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)) + + + + +;; 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 "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 sauthorize.scm Index: sauthorize.scm ================================================================== --- /dev/null +++ sauthorize.scm @@ -0,0 +1,643 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(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)) +(declare (uses megatest-version)) + +(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 : list the users that can access the area. + sauth open --group : Open up an area. User needs to be the owner of the area to open it. + --code + --retrieve|--publish [--additional-grps ] + sauth update --retrieve|--publish : update the binaries with the lates changes + sauth grant --area : Grant permission to read or write to a area that is alrady opend up. + --expiration yyyy/mm/dd --retrieve|--publish + [--restrict ] + sauth read-shell : Open sretrieve shell for reading. + sauth write-shell : 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 [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 [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 --group --code --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 --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 @@ -20,10 +20,11 @@ (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) (declare (uses http-transport)) +;;(declare (uses rpc-transport)) (declare (uses launch)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") @@ -60,11 +61,11 @@ ;; (define (server:launch run-id transport-type) (case transport-type ((http)(http-transport:launch)) ;;((nmsg)(nmsg-transport:launch run-id)) - ((rpc) (rpc-transport:launch run-id)) + ;;((rpc) (rpc-transport:launch run-id)) (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -122,11 +123,12 @@ " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") " -daemonize " "") ;; " -log " logfile " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) - (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))) + (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) + (load-limit (configf:lookup-number *configdat* "jobtools" "maxhomehostload" default: 3.0))) ;; we want the remote server to start in *toppath* so push there (push-directory areapath) (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") (thread-start! log-rotate) @@ -139,11 +141,11 @@ (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) - (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever + (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) (thread-join! log-rotate) (pop-directory))) @@ -254,11 +256,11 @@ (mod-time (list-ref rec 0))) ;; (print "start-time: " start-time " mod-time: " mod-time) (and start-time mod-time (> (- now start-time) 0) ;; been running at least 0 seconds (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds - (< (- now start-time) + (< (- now start-time) (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600")) 180) (random 360))) ;; under one hour running time +/- 180 )) #f)) @@ -448,20 +450,18 @@ (set! *db-last-access* (current-seconds)) ;; might not be needed. (if (equal? *toppath* toppath) #t #f))) -;; timeout is in hours -(define (server:get-timeout) - (let ((tmo (configf:lookup *configdat* "server" "timeout"))) +;; 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) - (string->number tmo)) - (* 60 60 (string->number tmo)) - ;; (* 3 24 60 60) ;; default to three days - ;;(* 60 60 1) ;; default to one hour - (* 60 5) ;; default to five minutes - ))) + (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below + (* 3600 (string->number tmo)) + 60))) (define (server:get-best-guess-address hostname) (let ((res #f)) (for-each (lambda (adr) @@ -477,55 +477,115 @@ ;; moving this here as it needs access to db and cannot be in common. ;; (define (server:writable-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) + (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) - (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) + (sync-duration 0) ;; run time of the sync in milliseconds + ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) + ) (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls (debug:print-info 2 *default-log-port* "Periodic sync thread started.") - (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) + (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (let* (;;(dbstruct (db:setup)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (mtpath (db:dbdat-get-path mtdb))) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + (mtpath (db:dbdat-get-path mtdb)) + (tmp-area (common:get-db-tmp-area)) + (start-file (conc tmp-area "/.start-sync")) + (end-file (conc tmp-area "/.end-sync"))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write (sync-in-progress *db-sync-in-progress*) + (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) (should-sync (and (not *time-to-exit*) - (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum + (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed (start-time (current-seconds)) + (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) (mt-mod-time (file-modification-time mtpath)) - (recently-synced (< (- start-time mt-mod-time) 4)) - (will-sync (and (or need-sync should-sync) + (last-sync-start (if (common:file-exists? start-file) + (file-modification-time start-file) + 0)) + (last-sync-end (if (common:file-exists? end-file) + (file-modification-time end-file) + 10)) + (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period + (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! + (< mt-mod-time last-sync-start))) + (sync-done (<= last-sync-start last-sync-end)) + (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) + (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting + (or need-sync should-sync) + (or sync-done sync-stale) (not sync-in-progress) (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync) + (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress + " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync + " sync-done=" sync-done " sync-period=" sync-period) + (if (and (> sync-period 5) + (common:low-noise-print 30 "sync-period")) + (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) (if will-sync (set! *db-sync-in-progress* #t)) (mutex-unlock! *db-multi-sync-mutex*) (if will-sync - (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive - (if (> res 0) ;; some records were transferred, keep the db alive - (begin - (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")))) + (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! + (sync-start (current-milliseconds))) + (with-output-to-file start-file (lambda ()(print (current-process-id)))) + + ;; put lock here + + ;; (if (or (not max-sync-duration) + ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally + (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive + (set! sync-duration (- (current-milliseconds) sync-start)) + (if (> res 0) ;; some records were transferred, keep the db alive + (begin + (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) + (with-output-to-file end-file (lambda ()(print (current-process-id)))) + + ;; release lock here + (mutex-unlock! *db-multi-sync-mutex*))) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) @@ -544,7 +604,7 @@ (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) ;; time to exit, close the no-sync db here (db:no-sync-close-db no-sync-db) (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) ADDED show-uncalled-procedures.scm Index: show-uncalled-procedures.scm ================================================================== --- /dev/null +++ show-uncalled-procedures.scm @@ -0,0 +1,13 @@ +(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: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -7,61 +7,48 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use defstruct) - -;; (use ssax) -;; (use sxml-serializer) -;; (use sxml-modifications) -;; (use regex) -;; (use srfi-69) -;; (use regex-case) -;; (use posix) -;; (use json) -;; (use csv) +(use scsh-process) +(use refdb) (use srfi-18) +(use srfi-19) (use format) - -;; (require-library ini-file) -;; (import (prefix ini-file ini:)) - (use sql-de-lite 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") +;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. +(include "sauth-paths.scm") +(include "sauth-common.scm") +(define (toplevel-command . args) #f) +(use readline) ;; ;; GLOBALS ;; (define *spublish:current-tab-number* 0) (define *args-hash* (make-hash-table)) -(define spublish:help (conc "Usage: spublish [action [params ...]] - - ls : list contents of target area - cp|publish : copy file to target area - mkdir : maks directory in target area - rm : remove file from target area - ln : creates a symlink - log : - +(define spublish:help (conc "Usage: spublish [action [params ...]] + + ls : list contents of target area + cp|publish : copy file to target area + mkdir : maks directory in target area + rm : remove file from target area + ln : creates a symlink + options: -m \"message\" : describe what was done - +Note: All the target locations relative to base path Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -71,237 +58,240 @@ ;;====================================================================== ;; DB ;;====================================================================== -(define (spublish:initialize-db db) - (for-each - (lambda (qry) - (exec (sql db qry))) - (list - "CREATE TABLE IF NOT EXISTS actions - (id INTEGER PRIMARY KEY, - action TEXT NOT NULL, - submitter TEXT NOT NULL, - datetime TIMESTAMP DEFAULT (strftime('%s','now')), - srcpath TEXT NOT NULL, - comment TEXT DEFAULT '' NOT NULL, - state TEXT DEFAULT 'new');" - ))) - -(define (spublish:register-action db action submitter source-path comment) - (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment) - VALUES(?,?,?,?)") - action - submitter - source-path - comment)) +(define *default-log-port* (current-error-port)) +(define *verbosity* 1) + +;(define (spublish:initialize-db db) +; (for-each +; (lambda (qry) +; (exec (sql db qry))) +; (list +; "CREATE TABLE IF NOT EXISTS actions +; (id INTEGER PRIMARY KEY, +; action TEXT NOT NULL, +; submitter TEXT NOT NULL, +; datetime TIMESTAMP DEFAULT (strftime('%s','now')), +; srcpath TEXT NOT NULL, +; comment TEXT DEFAULT '' NOT NULL, +; state TEXT DEFAULT 'new');" +; ))) + +;(define (spublish:register-action db action submitter source-path comment) +; (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment) +; VALUES(?,?,?,?)") +; action +; submitter +; source-path +; comment)) ;; (call-with-database ;; (lambda (db) ;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout ;; ...)) ;; Create the sqlite db -(define (spublish:db-do configdat proc) - (let ((path (configf:lookup configdat "database" "location"))) - (if (not path) - (begin - (print "[database]\nlocation /some/path\n\n Is missing from the config file!") - (exit 1))) - (if (and path - (directory? path) - (file-read-access? path)) - (let* ((dbpath (conc path "/spublish.db")) - (writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath))) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath - ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - (call-with-database - dbpath - (lambda (db) - ;; (print "calling proc " proc " on db " db) - (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout - (if (not dbexists)(spublish:initialize-db db)) - (proc db))))) - (print "ERROR: invalid path for storing database: " path)))) - -;; copy in file to dest, validation is done BEFORE calling this -;; -(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment) - (let ((dest-dir-path (conc target-dir "/" dest-dir)) - (targ-path (conc target-dir "/" dest-dir "/" targ-file))) - (if (file-exists? targ-path) - (begin - (print "ERROR: target file already exists, remove it before re-publishing") - (exit 1))) - (if (not(file-exists? dest-dir-path)) - (begin - (print "ERROR: target directory " dest-dir-path " does not exists." ) - (exit 1))) - - (spublish:db-do - configdat - (lambda (db) - (spublish:register-action db "cp" submitter source-path comment))) - (let* (;; (target-path (configf:lookup "settings" "target-path")) - (th1 (make-thread - (lambda () - (file-copy source-path targ-path #t)) - (print " ... file " targ-path " copied to" targ-path) - ;; (let ((pid (process-run "cp" (list source-path target-dir)))) - ;; (process-wait pid))) - "copy thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) - -;; copy directory to dest, validation is done BEFORE calling this -;; - -(define (spublish:tar configdat submitter target-dir dest-dir comment) - (let ((dest-dir-path (conc target-dir "/" dest-dir))) - (if (not(file-exists? dest-dir-path)) - (begin - (print "ERROR: target directory " dest-dir-path " does not exists." ) - (exit 1))) - ;;(print dest-dir-path ) - (spublish:db-do - configdat - (lambda (db) - (spublish:register-action db "tar" submitter dest-dir-path comment))) - (change-directory dest-dir-path) - (process-wait (process-run "/bin/tar" (list "xf" "-"))) - (print "Data copied to " dest-dir-path) - - (cons #t "Successfully saved data"))) - - -(define (spublish:validate target-dir targ-mk) - (let* ((normal-path (normalize-pathname targ-mk)) - (targ-path (conc target-dir "/" normal-path))) - (if (string-contains normal-path "..") - (begin - (print "ERROR: Path " targ-mk " resolved outside target area " target-dir ) - (exit 1))) - - (if (not (string-contains targ-path target-dir)) - (begin - (print "ERROR: You cannot update data outside " target-dir ".") - (exit 1))) - (print "Path " targ-mk " is valid.") - )) +;(define (spublish:db-do configdat proc) +; (let ((path (configf:lookup configdat "database" "location"))) +; (if (not path) +; (begin +; (print "[database]\nlocation /some/path\n\n Is missing from the config file!") +; (exit 1))) +; (if (and path +; (directory? path) +; (file-read-access? path)) +; (let* ((dbpath (conc path "/spublish.db")) +; (writeable (file-write-access? dbpath)) +; (dbexists (file-exists? dbpath))) +; (handle-exceptions +; exn +; (begin +; (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath +; ((condition-property-accessor 'exn 'message) exn)) +; (exit 1)) +; (call-with-database +; dbpath +; (lambda (db) +; ;; (print "calling proc " proc " on db " db) +; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout +; (if (not dbexists)(spublish:initialize-db db)) +; (proc db))))) +; (print "ERROR: invalid path for storing database: " path)))) +; +;;; copy in file to dest, validation is done BEFORE calling this +;;; +;(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment) +; (let ((dest-dir-path (conc target-dir "/" dest-dir)) +; (targ-path (conc target-dir "/" dest-dir "/" targ-file))) +; (if (file-exists? targ-path) +; (begin +; (print "ERROR: target file already exists, remove it before re-publishing") +; (exit 1))) +; (if (not(file-exists? dest-dir-path)) +; (begin +; (print "ERROR: target directory " dest-dir-path " does not exists." ) +; (exit 1))) +; +; (spublish:db-do +; configdat +; (lambda (db) +; (spublish:register-action db "cp" submitter source-path comment))) +; (let* (;; (target-path (configf:lookup "settings" "target-path")) +; (th1 (make-thread +; (lambda () +; (file-copy source-path targ-path #t)) +; (print " ... file " targ-path " copied to " targ-path) +; ;; (let ((pid (process-run "cp" (list source-path target-dir)))) +; ;; (process-wait pid))) +; "copy thread")) +; (th2 (make-thread +; (lambda () +; (let loop () +; (thread-sleep! 15) +; (display ".") +; (flush-output) +; (loop))) +; "action is happening thread"))) +; (thread-start! th1) +; (thread-start! th2) +; (thread-join! th1)) +; (cons #t "Successfully saved data"))) +; +;;; copy directory to dest, validation is done BEFORE calling this +;;; +; +;(define (spublish:tar configdat submitter target-dir dest-dir comment) +; (let ((dest-dir-path (conc target-dir "/" dest-dir))) +; (if (not(file-exists? dest-dir-path)) +; (begin +; (print "ERROR: target directory " dest-dir-path " does not exists." ) +; (exit 1))) +; ;;(print dest-dir-path ) +; (spublish:db-do +; configdat +; (lambda (db) +; (spublish:register-action db "tar" submitter dest-dir-path comment))) +; (change-directory dest-dir-path) +; (process-wait (process-run "/bin/tar" (list "xf" "-"))) +; (print "Data copied to " dest-dir-path) +; +; (cons #t "Successfully saved data"))) + + +;(define (spublish:validate target-dir targ-mk) +; (let* ((normal-path (normalize-pathname targ-mk)) +; (targ-path (conc target-dir "/" normal-path))) +; (if (string-contains normal-path "..") +; (begin +; (print "ERROR: Path " targ-mk " resolved outside target area " target-dir ) +; (exit 1))) +; +; (if (not (string-contains targ-path target-dir)) +; (begin +; (print "ERROR: You cannot update data outside " target-dir ".") +; (exit 1))) +; (print "Path " targ-mk " is valid.") +; )) ;; make directory in dest ;; -(define (spublish:mkdir configdat submitter target-dir targ-mk comment) - (let ((targ-path (conc target-dir "/" targ-mk))) - - (if (file-exists? targ-path) - (begin - (print "ERROR: target Directory " targ-path " already exist!!") - (exit 1))) - (spublish:db-do - configdat - (lambda (db) - (spublish:register-action db "mkdir" submitter targ-mk comment))) - (let* ((th1 (make-thread - (lambda () - (create-directory targ-path #t) - (print " ... dir " targ-path " created")) - "mkdir thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) +;(define (spublish:mkdir configdat submitter target-dir targ-mk comment) +; (let ((targ-path (conc target-dir "/" targ-mk))) +; +; (if (file-exists? targ-path) +; (begin +; (print "ERROR: target Directory " targ-path " already exist!!") +; (exit 1))) +; (spublish:db-do +; configdat +; (lambda (db) +; (spublish:register-action db "mkdir" submitter targ-mk comment))) +; (let* ((th1 (make-thread +; (lambda () +; (create-directory targ-path #t) +; (print " ... dir " targ-path " created")) +; "mkdir thread")) +; (th2 (make-thread +; (lambda () +; (let loop () +; (thread-sleep! 15) +; (display ".") +; (flush-output) +; (loop))) +; "action is happening thread"))) +; (thread-start! th1) +; (thread-start! th2) +; (thread-join! th1)) +; (cons #t "Successfully saved data"))) ;; create a symlink in dest ;; -(define (spublish:ln configdat submitter target-dir targ-link link-name comment) - (let ((targ-path (conc target-dir "/" link-name))) - (if (file-exists? targ-path) - (begin - (print "ERROR: target file " targ-path " already exist!!") - (exit 1))) - (if (not (file-exists? targ-link )) - (begin - (print "ERROR: target file " targ-link " does not exist!!") - (exit 1))) - - (spublish:db-do - configdat - (lambda (db) - (spublish:register-action db "ln" submitter link-name comment))) - (let* ((th1 (make-thread - (lambda () - (create-symbolic-link targ-link targ-path ) - (print " ... link " targ-path " created")) - "symlink thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) +;(define (spublish:ln configdat submitter target-dir targ-link link-name comment) +; (let ((targ-path (conc target-dir "/" link-name))) +; (if (file-exists? targ-path) +; (begin +; (print "ERROR: target file " targ-path " already exist!!") +; (exit 1))) +; (if (not (file-exists? targ-link )) +; (begin +; (print "ERROR: target file " targ-link " does not exist!!") +; (exit 1))) +; +; (spublish:db-do +; configdat +; (lambda (db) +; (spublish:register-action db "ln" submitter link-name comment))) +; (let* ((th1 (make-thread +; (lambda () +; (create-symbolic-link targ-link targ-path ) +; (print " ... link " targ-path " created")) +; "symlink thread")) +; (th2 (make-thread +; (lambda () +; (let loop () +; (thread-sleep! 15) +; (display ".") +; (flush-output) +; (loop))) +; "action is happening thread"))) +; (thread-start! th1) +; (thread-start! th2) +; (thread-join! th1)) +; (cons #t "Successfully saved data"))) ;; remove copy of file in dest ;; -(define (spublish:rm configdat submitter target-dir targ-file comment) - (let ((targ-path (conc target-dir "/" targ-file))) - (if (not (file-exists? targ-path)) - (begin - (print "ERROR: target file " targ-path " not found, nothing to remove.") - (exit 1))) - (spublish:db-do - configdat - (lambda (db) - (spublish:register-action db "rm" submitter targ-file comment))) - (let* ((th1 (make-thread - (lambda () - (delete-file targ-path) - (print " ... file " targ-path " removed")) - "rm thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) +;(define (spublish:rm configdat submitter target-dir targ-file comment) +; (let ((targ-path (conc target-dir "/" targ-file))) +; (if (not (file-exists? targ-path)) +; (begin +; (print "ERROR: target file " targ-path " not found, nothing to remove.") +; (exit 1))) +; (spublish:db-do +; configdat +; (lambda (db) +; (spublish:register-action db "rm" submitter targ-file comment))) +; (let* ((th1 (make-thread +; (lambda () +; (delete-file targ-path) +; (print " ... file " targ-path " removed")) +; "rm thread")) +; (th2 (make-thread +; (lambda () +; (let loop () +; (thread-sleep! 15) +; (display ".") +; (flush-output) +; (loop))) +; "action is happening thread"))) +; (thread-start! th1) +; (thread-start! th2) +; (thread-join! th1)) +; (cons #t "Successfully saved data"))) (define (spublish:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) (create-directory trashdir #t) @@ -323,182 +313,476 @@ ;;====================================================================== ;; MISC ;;====================================================================== -(define (spublish: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 (spublish:find name paths) - (if (null? paths) - #f - (let loop ((hed (car paths)) - (tal (cdr paths))) - (if (file-exists? (conc hed "/" name)) - hed - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))) +;(define (spublish: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 (spublish:find name paths) +; (if (null? paths) +; #f +; (let loop ((hed (car paths)) +; (tal (cdr paths))) +; (if (file-exists? (conc hed "/" name)) +; hed +; (if (null? tal) +; #f +; (loop (car tal)(cdr tal))))))) + +;;======================================================================== +;;Shell +;;======================================================================== +(define (spublish:get-accessable-projects area) + (let* ((projects `())) + (if (spublish:has-permission area) + (set! projects (cons area projects)) + (begin + (print "User cannot access area " area "!!") + (exit 1))) + projects)) + +;; function to find sheets to which use has access +(define (spublish:has-permission area) + ;(print "in spublish:has-permission") + (let* ((username (current-user-name)) + (ret-val #f)) + (cond + ((equal? (is-admin username) #t) + (set! ret-val #t)) + ((equal? (is-user "publish" username area) #t) + (set! ret-val #t)) + ((equal? (is-user "writer-admin" username area) #t) + (set! ret-val #t)) + + ((equal? (is-user "area-admin" username area) #t) + (set! ret-val #t)) + (else + (set! ret-val #f))) + ret-val)) + +(define (is_directory target-path) + (let* ((retval #f)) + (sauthorize:do-as-calling-user + (lambda () + ;(print (current-effective-user-id) ) + (if (directory? target-path) + (set! retval #t)))) + ;(print (current-effective-user-id)) + retval)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; shell functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (spublish:shell-cp src-path target-path) + (cond + ((not (file-exists? target-path)) + (sauth:print-error (conc " target Directory " target-path " does not exist!!"))) + ((not (file-exists? src-path)) + (sauth:print-error (conc "Source path " src-path " does not exist!!" ))) + (else + (if (is_directory src-path) + (begin + (let* ((parent-dir src-path) + (start-dir target-path)) + (run (pipe + (begin (system (conc "cd " parent-dir " ;tar chf - ." ))) + (begin (change-directory start-dir) + ;(print "123") + (run-cmd "tar" (list "xf" "-"))))) + (print "Copied data to " start-dir))) + (begin + (let*((parent-dir (pathname-directory src-path)) + (start-dir target-path) + (filename (if (pathname-extension src-path) + (conc(pathname-file src-path) "." (pathname-extension src-path)) + (pathname-file src-path)))) + ;(print "parent-dir " parent-dir " start-dir " start-dir) + (run (pipe + (begin (system (conc "cd " parent-dir ";tar chf - " filename ))) + (begin (change-directory start-dir) + (run-cmd "tar" (list "xf" "-"))))) + (print "Copied data to " start-dir))))))) + + +(define (spublish:shell-mkdir targ-path) + (if (file-exists? targ-path) + (begin + (print "Info: Target Directory " targ-path " already exist!!")) + (let* ((th1 (make-thread + (lambda () + (create-directory targ-path #t) + (print " ... dir " targ-path " created")) + "mkdir thread")) + (th2 (make-thread + (lambda () + (let loop () + (thread-sleep! 15) + (display ".") + (flush-output) + (loop))) + "action is happening thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (cons #t "Successfully saved data")))) + + +(define (spublish:shell-rm targ-path iport) + (if (not (file-exists? targ-path)) + (begin + (sauth:print-error (conc "target path " targ-path " does not exist!!"))) + (begin + (print "Are you sure you want to delete " targ-path "?[y/n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (let* ((th1 (make-thread + (lambda () + (if (symbolic-link? targ-path) + (delete-file targ-path ) + (if (directory? targ-path) + (delete-directory targ-path #t) + (delete-file targ-path ))) + (print " ... path " targ-path " deleted")) + "rm thread")) + (th2 (make-thread + (lambda () + (let loop () + (thread-sleep! 15) + (display ".") + (flush-output) + (loop))) + "action is happening thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (cons #t "Successfully saved data"))))))) + +(define (spublish:shell-ln src-path target-path sub-path) + (if (not (file-exists? sub-path)) + (sauth:print-error (conc "Path " sub-path " does not exist!! cannot proceed with link creation!!")) + (begin + (if (not (file-exists? src-path)) + (sauth:print-error (conc "Path " src-path " does not exist!! cannot proceed with link creation!!")) + (begin + (if (file-exists? target-path) + (sauth:print-error (conc "Path " target-path "already exist!! cannot proceed with link creation!!")) + (begin + (create-symbolic-link src-path target-path ) + (print " ... link " target-path " created")))))))) + +(define (spublish:shell-help) +(conc "Usage: [action [params ...]] + + ls [target path] : list contents of target area. + cd : To change the current directory within the sretrive shell. + pwd : Prints the full pathname of the current directory within the sretrive shell. + mkdir : creates directory. Note it does not create's a path recursive manner. + rm : removes files and emoty directories + cp : copy a file/dir to target path. if src is a dir it automatically makes a recursive copy. + ln TARGET LINK_NAME : creates a symlink +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash) +) + +(define (toplevel-command . args) #f) + +(define (spublish:shell area) + ; (print area) + (use readline) + + (let* ((path '()) + (prompt "spublish> ") + (args (argv)) + (usr (current-user-name) ) + (top-areas (spublish:get-accessable-projects area)) + (close-port #f) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (iport (make-readline-port prompt))) + ;(print base-path) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + ; (print "here") + (let loop ((inl (read-line iport))) + (if (not (or (or (eof-object? inl) + (equal? inl "exit")) (port-closed? iport))) + (let* ((parts (string-split inl)) + (cmd (if (null? parts) #f (car parts)))) + (if (and (not cmd) (not (port-closed? iport))) + (loop (read-line)) + (case (string->symbol cmd) + ((cd) + (if (> (length parts) 1) ;; have a parameter + (begin + (let*((arg (cadr parts)) + (resolved-path (sauth-common:resolve-path arg path top-areas)) + (target-path (sauth-common:get-target-path path arg top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (equal? resolved-path #f) (not (file-exists? target-path))) + (print "Invalid argument " arg ".. ") + (begin + (set! path resolved-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd")))) + ))))) + (set! path '()))) + ((pwd) + (if (null? path) + (print "/") + (print "/" (string-join path "/")))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (sauth-common:shell-ls-cmd path "" top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) ) + ((< plen 2) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))) + (else + (if (equal? (car thepath) "|") + (sauth-common:shell-ls-cmd path "" top-areas base-path thepath) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))) + ((mkdir) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "mkdir takes one argument")) + ((< plen 2) + (let*((mk-path (cadr parts)) + (resolved-path (sauth-common:resolve-path mk-path path top-areas)) + (target-path (sauth-common:get-target-path path mk-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " mk-path ".. ") + (begin + (print "here") + (spublish:shell-mkdir target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir"))))))) + ))))) + ((rm) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "rm takes one argument")) + ((< plen 2) + (let*((rm-path (cadr parts)) + (resolved-path (sauth-common:resolve-path rm-path path top-areas)) + (target-path (sauth-common:get-target-path path rm-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " rm-path ".. ") + (begin + (spublish:shell-rm target-path iport) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm"))))))) + ))))) + + ((cp publish) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((or (null? thepath) (< plen 2)) + (print "cp takes two argument")) + ((< plen 3) + (let*((src-path (car thepath)) + (dest-path (cadr thepath)) + (resolved-path (sauth-common:resolve-path dest-path path top-areas)) + (target-path (sauth-common:get-target-path path dest-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-cp src-path target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp"))))))) + ))))) + ((ln) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((or (null? thepath) (< plen 2)) + (print "ln takes two argument")) + ((< plen 3) + (let*((src-path (car thepath)) + (dest-path (cadr thepath)) + (resolved-path (sauth-common:resolve-path dest-path path top-areas)) + (target-path (sauth-common:get-target-path path dest-path top-areas base-path)) + (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/"))))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-ln src-path target-path sub-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln"))))))) + ))))) + ((exit) + (print "got exit")) + ((help) + (print (spublish:shell-help))) + (else + (print "Got command: " inl)))) + (loop (read-line iport))))))) + ;;====================================================================== ;; MAIN ;;====================================================================== -(define (spublish:load-config exe-dir exe-name) - (let* ((fname (conc exe-dir "/." exe-name ".config"))) +;(define (spublish:load-config exe-dir exe-name) +; (let* ((fname (conc exe-dir "/." exe-name ".config"))) ;; (ini:property-separator-patt " * *") ;; (ini:property-separator #\space) - (if (file-exists? fname) - ;; (ini:read-ini fname) - (read-config fname #f #t) - (make-hash-table)))) - -(define (spublish:process-action configdat action . args) - (let* ((target-dir (configf:lookup configdat "settings" "target-dir")) - (user (current-user-name)) - (allowed-users (string-split - (or (configf:lookup configdat "settings" "allowed-users") - "")))) - (if (not target-dir) - (begin - (print "[settings]\ntarget-dir /some/path\n\n Is MISSING from the config file!") - (exit))) - (if (null? allowed-users) - (begin - (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") - (exit))) - (if (not (member user allowed-users)) - (begin - (print "User \"" (current-user-name) "\" does not have access. Exiting") - (exit 1))) +; (if (file-exists? fname) +; ;; (ini:read-ini fname) +; (read-config fname #f #t) +; (make-hash-table)))) + +(define (spublish:process-action action . args) + ;(print args) + (let* ((usr (current-user-name)) + (user-obj (get-user usr)) + (area (car args)) + (area-obj (get-obj-by-code area)) + (top-areas (spublish:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (remargs (cdr args))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) (case (string->symbol action) ((cp publish) - (if (< (length args) 2) + (if (< (length remargs) 2) (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (print "ERROR: Missing arguments; spublish " ) (exit 1))) - (let* ((remargs (args:get-args args '("-m") '() args:arg-hash 0)) - (dest-dir (cadr args)) - (src-path-in (car args)) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (src-path-in (car filter-args)) + (dest-path (cadr filter-args)) (src-path (with-input-from-pipe (conc "readlink -f " src-path-in) (lambda () (read-line)))) (msg (or (args:get-arg "-m") "")) - (targ-file (pathname-strip-directory src-path))) - (if (not (file-read-access? src-path)) - (begin - (print "ERROR: source file not readable: " src-path) - (exit 1))) - (if (directory? src-path) - (begin - (print "ERROR: source file is a directory, this is not supported yet.") - (exit 1))) - (print "publishing " src-path-in " to " target-dir) - (spublish:validate target-dir dest-dir) - (spublish:cp configdat user src-path target-dir targ-file dest-dir msg))) - ((tar) - (if (< (length args) 1) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((dst-dir (car args)) - (msg (or (args:get-arg "-m") ""))) - (spublish:validate target-dir dst-dir) - (spublish:tar configdat user target-dir dst-dir msg))) - - ((mkdir) - (if (< (length args) 1) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((targ-mk (car args)) - (msg (or (args:get-arg "-m") ""))) - (print "attempting to create directory " targ-mk " in " target-dir) - (spublish:validate target-dir targ-mk) - (spublish:mkdir configdat user target-dir targ-mk msg))) - - ((ln) - (if (< (length args) 2) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((targ-link (car args)) - (link-name (cadr args)) - (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/"))) - (msg (or (args:get-arg "-m") ""))) - (if (> (string-length(string-trim sub-path)) 0) - (begin - (print "attempting to create directory " sub-path " in " target-dir) - (spublish:validate target-dir sub-path) - (print (conc target-dir "/" sub-path ) ) - (print (directory-exists?(conc target-dir "/" sub-path ))) - (if (directory-exists?(conc target-dir "/" sub-path )) - (print "Target Directory " (conc target-dir sub-path ) " exist!!") - (spublish:mkdir configdat user target-dir sub-path msg)))) - - (print "attempting to create link " link-name " in " target-dir) - (spublish:ln configdat user target-dir targ-link link-name msg))) - + (resolved-path (sauth-common:resolve-path (conc area "/" dest-path) `() top-areas)) + (target-path (sauth-common:get-target-path `() (conc area "/" dest-path) top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-cp src-path target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp"))))))))) + ((mkdir) + (if (< (length remargs) 1) + (begin + (print "ERROR: Missing arguments; ") + (exit 1))) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (mk-path (car filter-args)) + (msg (or (args:get-arg "-m") "")) + (resolved-path (sauth-common:resolve-path mk-path (list area) top-areas)) + (target-path (sauth-common:get-target-path (list area) mk-path top-areas base-path))) + (print "attempting to create directory " mk-path ) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " mk-path ".. ") + (begin + (spublish:shell-mkdir target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir"))))))))) + ((ln) + (if (< (length remargs) 2) + (begin + (print "ERROR: Missing arguments; " ) + (exit 1))) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (src-path (car filter-args)) + (dest-path (cadr filter-args)) + (resolved-path (sauth-common:resolve-path dest-path (list area) top-areas)) + (target-path (sauth-common:get-target-path (list area) dest-path top-areas base-path)) + (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/"))))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-ln src-path target-path sub-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln"))))))))) ((rm) - (if (< (length args) 1) + (if (< (length remargs) 1) (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (print "ERROR: Missing arguments; ") (exit 1))) - (let* ((targ-file (car args)) - (msg (or (args:get-arg "-m") ""))) - (print "attempting to remove " targ-file " from " target-dir) - (spublish:validate target-dir targ-file) - - (spublish:rm configdat user target-dir targ-file msg))) - ((publish) - (if (< (length args) 3) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (rm-path (car filter-args)) + (resolved-path (sauth-common:resolve-path rm-path (list area) top-areas)) + (prompt ">") + (iport (make-readline-port prompt)) + (target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " rm-path ".. ") + (begin + (spublish:shell-rm target-path iport) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm"))))))))) + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments area!!" ) (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 (spublish: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 (spublish:open-db configdat)) - (versions (spublish: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))) + (spublish:shell area))) (else (print "Unrecognised command " action))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc"))) ;; (if (file-exists? debugcontrolf) @@ -506,37 +790,21 @@ (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) - (exe-name (pathname-file (car (argv)))) - (exe-dir (or (pathname-directory prog) - (spublish:find exe-name (string-split (get-environment-variable "PATH") ":")))) - (configdat (spublish:load-config exe-dir exe-name))) + (exe-name (pathname-file (car (argv))))) (cond ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print spublish:help)) - ((list-vars) ;; print out the ini file - (map print (spublish:get-areas configdat))) - ((ls) - (let ((target-dir (configf:lookup configdat "settings" "target-dir"))) - (print "Files in " target-dir) - (system (conc "ls " target-dir)))) - ((log) - (spublish:db-do configdat (lambda (db) - (print "Listing actions") - (query (for-each-row - (lambda (row) - (apply print (intersperse row " | ")))) - (sql db "SELECT * FROM actions"))))) (else (print "ERROR: Unrecognised command. Try \"spublish help\"")))) ;; multi-word commands ((null? rema)(print spublish:help)) ((>= (length rema) 2) - (apply spublish:process-action configdat (car rema)(cdr rema))) + (apply spublish:process-action (car rema)(cdr rema))) (else (print "ERROR: Unrecognised command2. Try \"spublish help\""))))) (main) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -7,43 +7,29 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use defstruct) - -;; (use ssax) -;; (use sxml-serializer) -;; (use sxml-modifications) -;; (use regex) -;; (use srfi-69) -;; (use regex-case) -;; (use posix) -;; (use json) -;; (use csv) -;; (use directory-utils) +(use scsh-process) (use srfi-18) -(use format) - -;; (require-library ini-file) -;; (import (prefix ini-file ini:)) - +(use srfi-19) +(use refdb) (use sql-de-lite srfi-1 posix regex regex-case srfi-69) -;; (import (prefix sqlite3 sqlite3:)) -;; +(declare (uses common)) (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") +;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. +(include "sauth-paths.scm") +(include "sauth-common.scm") + +(define (toplevel-command . args) #f) +(use readline) + ;; ;; GLOBALS ;; (define *verbosity* 1) @@ -51,16 +37,14 @@ (define *exe-name* (pathname-file (car (argv)))) (define *sretrieve:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] - ls : list contents of target area - get : retrieve data for release - -m \"message\" : why retrieved? - cp : copy file to current directory - log : get listing of recent downloads - shell : start a shell-like interface + ls : list contents of target area + get : retrieve path to the data within + -m \"message\" : why retrieved? + shell : start a shell-like interface Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -72,320 +56,214 @@ ;;====================================================================== ;; DB ;;====================================================================== ;; replace (strftime('%s','now')), with datetime('now')) -(define (sretrieve:initialize-db db) - (for-each - (lambda (qry) - (exec (sql db qry))) - (list - "CREATE TABLE IF NOT EXISTS actions - (id INTEGER PRIMARY KEY, - action TEXT NOT NULL, - retriever TEXT NOT NULL, - datetime TIMESTAMP DEFAULT (datetime('now','localtime')), - srcpath TEXT NOT NULL, - comment TEXT DEFAULT '' NOT NULL, - state TEXT DEFAULT 'new');" - "CREATE TABLE IF NOT EXISTS bundles - (id INTEGER PRIMARY KEY, - bundle TEXT NOT NULL, - release TEXT NOT NULL, - status TEXT NOT NULL, - event_date TEXT NOT NULL);" - ))) - -(define (sretrieve:register-action db action submitter source-path comment) - (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment) - (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment) - VALUES(?,?,?,?)") - action - submitter - source-path - (or comment ""))) +;(define (sretrieve:initialize-db db) +; (for-each +; (lambda (qry) +; (exec (sql db qry))) +; (list +; "CREATE TABLE IF NOT EXISTS actions +; (id INTEGER PRIMARY KEY, +; action TEXT NOT NULL, +; retriever TEXT NOT NULL, +; datetime TIMESTAMP DEFAULT (datetime('now','localtime')), +; srcpath TEXT NOT NULL, +; comment TEXT DEFAULT '' NOT NULL, +; state TEXT DEFAULT 'new');" +; "CREATE TABLE IF NOT EXISTS bundles +; (id INTEGER PRIMARY KEY, +; bundle TEXT NOT NULL, +; release TEXT NOT NULL, +; status TEXT NOT NULL, +; event_date TEXT NOT NULL);" +; ))) +; +;(define (sretrieve:register-action db action submitter source-path comment) +; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment) +; (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment) +; VALUES(?,?,?,?)") +; action +; submitter +; source-path +; (or comment ""))) ;; (call-with-database ;; (lambda (db) ;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout ;; ...)) ;; Create the sqlite db -(define (sretrieve:db-do configdat proc) - - (let ((path (configf:lookup configdat "database" "location"))) - (if (not path) - (begin - (debug:print 0 *default-log-port* "[database]\nlocation /some/path\n\n Is missing from the config file!") - (exit 1))) - (if (and path - (directory? path) - (file-read-access? path)) - (let* ((dbpath (conc path "/" *exe-name* ".db")) - (writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath))) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath - ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath ) - (call-with-database - dbpath - (lambda (db) - ;;(debug:print 0 *default-log-port* "calling proc " proc " on db " db) - (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout - (if (not dbexists)(sretrieve:initialize-db db)) - (proc db))))) - (debug:print-error 0 *default-log-port* "invalid path for storing database: " path)))) +;(define (sretrieve:db-do configdat proc) +; (let ((path (configf:lookup configdat "database" "location"))) +; (if (not path) +; (begin +; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") +; (exit 1))) +; (if (and path +; (directory? path) +; (file-read-access? path)) +; (let* ((dbpath (conc path "/" *exe-name* ".db")) +; (writeable (file-write-access? dbpath)) +; (dbexists (file-exists? dbpath))) +; (handle-exceptions +; exn +; (begin +; (debug:print 2 "ERROR: problem accessing db " dbpath +; ((condition-property-accessor 'exn 'message) exn)) +; (exit 1)) +; ;;(debug:print 0 "calling proc " proc "db path " dbpath ) +; (call-with-database +; dbpath +; (lambda (db) +; ;;(debug:print 0 "calling proc " proc " on db " db) +; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout +; (if (not dbexists)(sretrieve:initialize-db db)) +; (proc db))))) +; (debug:print 0 "ERROR: invalid path for storing database: " path)))) ;; copy in directory to dest, validation is done BEFORE calling this ;; -(define (sretrieve:get configdat retriever version comment) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) - (datadir (conc base-dir "/" version))) - (if (or (not base-dir) - (not (file-exists? base-dir))) - (begin - (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") - (exit 1))) - (print datadir) - (if (not (file-exists? datadir)) - (begin - (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." ) - (exit 1))) - - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "get" retriever datadir comment))) - (sretrieve:do-as-calling-user - (lambda () - (if (directory? datadir) - (begin - (change-directory datadir) - (let ((files (filter (lambda (x) - (not (member x '("." "..")))) - (glob "*" ".*")))) - (print "files: " files) - (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read"))))) - (begin - (let* ((parent-dir (pathname-directory datadir) ) - (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) - (change-directory parent-dir) - (process-execute "/bin/tar" (list "chfv" "-" filename)) - ))) -)) -)) - - -;; copy in file to dest, validation is done BEFORE calling this -;; -(define (sretrieve:cp configdat retriever file comment) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) - (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) - (datadir (conc base-dir "/" file)) - (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) - (if (or (not base-dir) - (not (file-exists? base-dir))) - (begin - (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") - (exit 1))) - (print datadir) - (if (not (file-exists? datadir)) - (begin - (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) - (exit 1))) - (if (directory? datadir) - (begin - (debug:print-error 0 *default-log-port* "(" file ") is a dirctory!! cp cmd works only on files ." ) - (exit 1))) - (if(not (string-match (regexp allowed-sub-paths) file)) - (begin - (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " ) - (exit 1))) - - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "cp" retriever datadir comment))) - (sretrieve:do-as-calling-user - ;; (debug:print 0 *default-log-port* "ph: "(pathname-directory datadir) "!! " ) - (change-directory (pathname-directory datadir)) - ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) ) - (process-execute "/bin/tar" (list "chfv" "-" filename))) - )) - -;; ls in file to dest, validation is done BEFORE calling this -;; -(define (sretrieve:ls configdat retriever file comment) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) - (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) - (datadir (conc base-dir "/" file)) - (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) - (if (or (not base-dir) - (not (file-exists? base-dir))) - (begin - (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") - (exit 1))) - (print datadir) - (if (not (file-exists? datadir)) - (begin - (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) - (exit 1))) - (if(not (string-match (regexp allowed-sub-paths) file)) - (begin - (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " ) - (exit 1))) - - (sretrieve:do-as-calling-user - (lambda () - ;;(change-directory datadir) - ;; (debug:print 0 *default-log-port* "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) - ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line)))) - ;; (debug:print 0 *default-log-port* status) - (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) - )))) - - - -;;(filter (lambda (x) -;; (not (member x '("." "..")))) -;; (glob "*" ".*")))))))) +;(define (sretrieve:get configdat retriever version comment) +; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) +; (datadir (conc base-dir "/" version))) +; (if (or (not base-dir) +; (not (file-exists? base-dir))) +; (begin +; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") +; (exit 1))) +; (print datadir) +; (if (not (file-exists? datadir)) +; (begin +; (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) +; (exit 1))) +; +; (sretrieve:db-do +; configdat +; (lambda (db) +; (sretrieve:register-action db "get" retriever datadir comment))) +; (sretrieve:do-as-calling-user +; (lambda () +; (if (directory? datadir) +; (begin +; (change-directory datadir) +; (let ((files (filter (lambda (x) +; (not (member x '("." "..")))) +; (glob "*" ".*")))) +; (print "files: " files) +; (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read"))))) +; (begin +; (let* ((parent-dir (pathname-directory datadir) ) +; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) +; (change-directory parent-dir) +; (process-execute "/bin/tar" (list "chfv" "-" filename)) +; ))) +;)))) +; +; +;;; copy in file to dest, validation is done BEFORE calling this +;;; +;(define (sretrieve:cp configdat retriever file comment) +; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) +; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) +; (datadir (conc base-dir "/" file)) +; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) +; (if (or (not base-dir) +; (not (file-exists? base-dir))) +; (begin +; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") +; (exit 1))) +; (print datadir) +; (if (not (file-exists? datadir)) +; (begin +; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) +; (exit 1))) +; (if (directory? datadir) +; (begin +; (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) +; (exit 1))) +; (if(not (string-match (regexp allowed-sub-paths) file)) +; (begin +; (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) +; (exit 1))) +; +; (sretrieve:db-do +; configdat +; (lambda (db) +; (sretrieve:register-action db "cp" retriever datadir comment))) +; (sretrieve:do-as-calling-user +; ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " ) +; (change-directory (pathname-directory datadir)) +; ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) +; (process-execute "/bin/tar" (list "chfv" "-" filename))) +; )) +; +;;; ls in file to dest, validation is done BEFORE calling this +;;; +;(define (sretrieve:ls configdat retriever file comment) +; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) +; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) +; (datadir (conc base-dir "/" file)) +; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) +; (if (or (not base-dir) +; (not (file-exists? base-dir))) +; (begin +; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") +; (exit 1))) +; (print datadir) +; (if (not (file-exists? datadir)) +; (begin +; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) +; (exit 1))) +; (if(not (string-match (regexp allowed-sub-paths) file)) +; (begin +; (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) +; (exit 1))) +; +; (sretrieve:do-as-calling-user +; (lambda () +; (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) +; )))) + + (define (sretrieve:validate target-dir targ-mk) (let* ((normal-path (normalize-pathname targ-mk)) (targ-path (conc target-dir "/" normal-path))) (if (string-contains normal-path "..") (begin - (debug:print-error 0 *default-log-port* "Path " targ-mk " resolved outside target area " target-dir ) + (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print-error 0 *default-log-port* "You cannot update data outside " target-dir ".") + (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") (exit 1))) - (debug:print 0 *default-log-port* "Path " targ-mk " is valid.") + (debug:print 0 "Path " targ-mk " is valid.") )) -;; make directory in dest -;; - -(define (sretrieve:mkdir configdat submitter target-dir targ-mk comment) - (let ((targ-path (conc target-dir "/" targ-mk))) - - (if (file-exists? targ-path) - (begin - (debug:print-error 0 *default-log-port* "target Directory " targ-path " already exist!!") - (exit 1))) - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "mkdir" submitter targ-mk comment))) - (let* ((th1 (make-thread - (lambda () - (create-directory targ-path #t) - (debug:print 0 *default-log-port* " ... dir " targ-path " created")) - "mkdir thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) - -;; create a symlink in dest -;; -(define (sretrieve:ln configdat submitter target-dir targ-link link-name comment) - (let ((targ-path (conc target-dir "/" link-name))) - (if (file-exists? targ-path) - (begin - (debug:print-error 0 *default-log-port* "target file " targ-path " already exist!!") - (exit 1))) - (if (not (file-exists? targ-link )) - (begin - (debug:print-error 0 *default-log-port* "target file " targ-link " does not exist!!") - (exit 1))) - - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "ln" submitter link-name comment))) - (let* ((th1 (make-thread - (lambda () - (create-symbolic-link targ-link targ-path ) - (debug:print 0 *default-log-port* " ... link " targ-path " created")) - "symlink thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) - - -;; remove copy of file in dest -;; -(define (sretrieve:rm configdat submitter target-dir targ-file comment) - (let ((targ-path (conc target-dir "/" targ-file))) - (if (not (file-exists? targ-path)) - (begin - (debug:print-error 0 *default-log-port* "target file " targ-path " not found, nothing to remove.") - (exit 1))) - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "rm" submitter targ-file comment))) - (let* ((th1 (make-thread - (lambda () - (delete-file targ-path) - (debug:print 0 *default-log-port* " ... file " targ-path " removed")) - "rm thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) - -(define (sretrieve: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)))) - - -(define (sretrieve:lst->path pathlst) - (conc "/" (string-intersperse (map conc pathlst) "/"))) - -(define (sretrieve:path->lst path) - (string-split path "/")) - -(define (sretrieve:pathdat-apply-heuristics configdat path) - (cond - ((file-exists? path) "found") - (else (conc path " not installed")))) + + +;(define (sretrieve: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)))) +; +; +;(define (sretrieve:lst->path pathlst) +; (conc "/" (string-intersperse (map conc pathlst) "/"))) +; +;(define (sretrieve:path->lst path) +; (string-split path "/")) +; +;(define (sretrieve:pathdat-apply-heuristics configdat path) +; (cond +; ((file-exists? path) "found") +; (else (conc path " not installed")))) ;;====================================================================== ;; MISC ;;====================================================================== @@ -392,11 +270,11 @@ (define (sretrieve: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)) - ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id)) + ;; (debug:print 0 "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (sretrieve:find name paths) @@ -417,203 +295,770 @@ ;;====================================================================== ;; SHELL ;;====================================================================== -(define (toplevel-command . args) #f) -(define (sretrieve:shell) +;; Create the sqlite db for shell +;(define (sretrieve:shell-db-do path proc) +; (if (not path) +; (begin +; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") +; (exit 1))) +; (if (and path +; (directory? path) +; (file-read-access? path)) +; (let* ((dbpath (conc path "/" *exe-name* ".db")) +; (writeable (file-write-access? dbpath)) +; (dbexists (file-exists? dbpath))) +; (handle-exceptions +; exn +; (begin +; (debug:print 2 "ERROR: problem accessing db " dbpath +; ((condition-property-accessor 'exn 'message) exn)) +; (exit 1)) +; ;;(debug:print 0 "calling proc " proc "db path " dbpath ) +; (call-with-database +; dbpath +; (lambda (db) +; ;;(debug:print 0 "calling proc " proc " on db " db) +; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout +; (if (not dbexists)(sretrieve:initialize-db db)) +; (proc db))))) +; (debug:print 0 "ERROR: invalid path for storing database: " path))) + + + +;; function to find sheets to which use has access +(define (sretrieve:has-permission area) + (let ((username (current-user-name))) + (cond + ((is-admin username) + #t) + ((is-user "retrieve" username area) + #t) + ((is-user "publish" username area) + #t) + ((is-user "writer-admin" username area) + #t) + ((is-user "read-admin" username area) + #t) + ((is-user "area-admin" username area) + #t) + (else + #f)))) + + +(define (sretrieve:get-accessable-projects area) + (let* ((projects `())) + + (if (sretrieve:has-permission area) + (set! projects (cons area projects)) + (begin + (print "User cannot access area " area "!!") + (exit 1))) + ; (print projects) + projects)) + +(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 "Resolved path: " target-path) + (if (not (equal? target-path #f)) + (begin + (if (symbolic-link? target-path) + (set! target-path (conc 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 (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) + (data "") ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (not (file-exists? target-path)) (directory? target-path)) + (print "Target path does not exist or is a directory!") + (begin + (cond + ((null? tail-cmd-list) + (run (pipe + (cat ,target-path)))) + ((not (equal? (car tail-cmd-list) "|")) + (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!")) + (else + (run (pipe + (cat ,target-path) + (begin (system (string-join (cdr tail-cmd-list)))))))))) +))) + (print "Path could not be resolved!!")))) + +(define (get-options cmd-list split-str) + (if (null? cmd-list) + (list '() '()) + (let loop ((hed (car cmd-list)) + (tal (cdr cmd-list)) + (res '())) + (cond + ((equal? hed split-str) + (list res tal)) + ((null? tal) + (list (cons hed res) tal)) + (else + (loop (car tal)(cdr tal)(cons hed res))))))) + + +(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) + (pattern (car tail-cmd-list)) + (pipe-cmd-list (get-options (cdr tail-cmd-list) "|")) + (options (string-join (car pipe-cmd-list))) + (pipe-cmd (cadr pipe-cmd-list)) + (redirect-split (string-split (string-join tail-cmd-list) ">")) ) + (if(and ( > (length redirect-split) 2 )) + (print "sgrep cmd cannot accept > " (string-join redirect-split) " as an argument!!" ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path))) + (rest-str (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") )))) + (if (not (file-exists? target-path)) + (print "Target path does not exist!") + (begin + (cond + ((and (null? pipe-cmd) (string-null? options)) + (run (pipe + (grep ,pattern ,target-path )))) + ((and (null? pipe-cmd) (not (string-null? options))) + (run (pipe + (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))))) + ((and (not (null? pipe-cmd)) (string-null? options)) + (run (pipe + (grep ,exclude-dir ,pattern ,target-path) + (begin (system (string-join pipe-cmd)))))) + (else + (run (pipe + ;(grep ,options ,exclude-dir ,pattern ,target-path) + (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))) + + (begin (system (string-join pipe-cmd))))))) +)))) + (print "Path could not be resolved!!"))))) + + +(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (not (file-exists? target-path)) (directory? target-path)) + (print "Target path does not exist or is a directory!") + (begin + ;(sretrieve:shell-db-do + ; db-location + ; (lambda (db) + ; (sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less " target-path)))) + + (setenv "LESSSECURE" "1") + (run (pipe + (less ,target-path)))))))) + (print "Path could not be resolved!!")))) + + + +(define (sretrieve:shell-lookup base-path) + (let* ((usr (current-user-name)) + (value (get-restrictions base-path usr))) + value)) + + +(define (sretrieve:load-shell-config fname) + (if (file-exists? fname) + (read-config fname #f #f) + )) + + +(define (is_directory target-path) + (let* ((retval #f)) + (sretrieve:do-as-calling-user + (lambda () + ;(print (current-effective-user-id) ) + (if (directory? target-path) + (set! retval #t)))) + ;(print (current-effective-user-id)) + retval)) + +(define (make-exclude-pattern restriction-list ) + (if (null? restriction-list) + "" + (let loop ((hed (car restriction-list)) + (tal (cdr restriction-list)) + (ret-str "")) + (cond + ((null? tal) + (conc ret-str ".+" hed ".*")) + (else + (loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|")))))) ) + +(define (sretrieve:get-shell-cmd target-path base-path restrictions iport) + (if (not (file-exists? target-path)) + (sauth:print-error "Target path does not exist!") + (begin + (if (not (equal? target-path #f)) + (begin + (if (is_directory target-path) + (begin + (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe")) + (parent-dir target-path) + (last-dir-name (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (curr-dir (current-directory)) + (start-dir (conc (current-directory) "/" last-dir-name)) + (execlude (make-exclude-pattern (string-split restrictions ",")))) + ; (print tmpfile) + (if (file-exists? start-dir) + (begin + (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (begin + (change-directory parent-dir) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (run (pipe + (tar "chfv" "-" "-T" ,tmpfile ) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory curr-dir) + (system (conc "rm " tmpfile)) ) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (sretrieve:do-as-calling-user + (lambda () + (create-directory start-dir #t))) + (change-directory parent-dir) + ; (print execlude) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (run (pipe + (tar "chfv" "-" "-T" ,tmpfile) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory curr-dir) + (system (conc "rm " tmpfile)))))) + (begin + (let*((parent-dir (pathname-directory target-path)) + (start-dir (current-directory)) + (filename (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (work-dir-file (conc (current-directory) "/" filename))) + (if (file-exists? work-dir-file) + (begin + (print filename " already exist in your work dir. Do you want to over write it? [y|n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (begin + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" ,filename) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory start-dir)) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" ,filename) + (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir))))))))))) + +(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport) + (handle-exceptions + exn + (begin + (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: " + ((condition-property-accessor 'exn 'message) exn))) + (exit 1)) + + (if (not (file-exists? target-path)) + (sauth:print-error "Error:Target path does not exist!") + (begin + (if (not (equal? target-path #f)) + (begin + (if (is_directory target-path) + (begin + (let* ((parent-dir target-path) + (last-dir-name (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (curr-dir (current-directory)) + (start-dir (conc (current-directory) "/" last-dir-name)) + (execlude (make-exclude-pattern (string-split restrictions ","))) + (tmpfile (conc "/tmp/" (current-user-name) "/my-pipe-" (current-process-id)))) + (if (file-exists? start-dir) + (begin + (sauth:print-error (conclast-dir-name " already exist in your work dir.")) + (sauth:print-error "Nothing has been retrieved!! ")) + (begin + ; (sretrieve:do-as-calling-user + ; (lambda () + + (if (not (file-exists? (conc "/tmp/" (current-user-name)))) + (create-directory (conc "/tmp/" (current-user-name)) #t)) + (change-directory parent-dir) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (process-execute "/bin/tar" (append (list "chfv" "-" "-T" tmpfile) (list "--ignore-failed-read"))) + ;(run (pipe + ;(tar "chfv" "-" "." ) + ;(begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) + (system (conc "rm " tmpfile)) + (change-directory curr-dir))))) + (begin + (let*((parent-dir (pathname-directory target-path)) + (start-dir (current-directory)) + (filename (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (work-dir-file (conc (current-directory) "/" filename))) + (if (file-exists? work-dir-file) + (begin + (print filename " already exist in your work dir.") + (print "Nothing has been retrieved!! ")) + (begin + (change-directory parent-dir) + (process-execute "/bin/tar" (append (append (list "chfv" "-") (list filename)) (list "--ignore-failed-read"))) + ;(run (pipe + ; (tar "chfv" "-" ,filename) + ; (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir)))))))))))) + +(define (sretrieve:make_file path exclude base_path) + (find-files + path + action: (lambda (p res) + (cond + ((symbolic-link? p) + (if (directory?(read-symbolic-link p)) + (sretrieve:make_file p exclude base_path) + (print (string-substitute (conc base_path "/") "" p "-")))) + ((directory? p) + ;;do nothing for dirs) + ) + (else + + (if (not (string-match (regexp exclude) p )) + (print (string-substitute (conc base_path "/") "" p "-")))))))) + +(define (sretrieve:shell-help) +(conc "Usage: " *exe-name* " [action [params ...]] + + ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls | grep txt + cd : To change the current directory within the sretrive shell. + pwd : Prints the full pathname of the current directory within the sretrive shell. + get : download directory/files into the directory where sretrieve shell cmd was invoked + less : Read input file to allows backward movement in the file as well as forward movement + cat : show the contents of a file. The output of the cmd can be piped into other system cmd. + + sgrep [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash) +) +;(define (toplevel-command . args) #f) +(define (sretrieve:shell area) + ; (print area) (use readline) (let* ((path '()) - (prompt "> ") - (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18")) + (prompt "sretrieve> ") + (args (argv)) + (usr (current-user-name) ) + (top-areas (sretrieve:get-accessable-projects area)) + (close-port #f) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) (iport (make-readline-port prompt))) - (install-history-file) ;; [homedir] [filename] [nlines]) - (with-input-from-port iport - (lambda () - (let loop ((inl (read-line))) - (if (not (or (eof-object? inl) - (equal? inl "exit"))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (let loop ((inl (read-line iport))) + ;(print 1) + (if (not (or (or (eof-object? inl) + (equal? inl "exit")) (port-closed? iport))) (let* ((parts (string-split inl)) (cmd (if (null? parts) #f (car parts)))) - (if (not cmd) + ; (print "2") + (if (and (not cmd) (not (port-closed? iport))) (loop (read-line)) (case (string->symbol cmd) ((cd) (if (> (length parts) 1) ;; have a parameter - (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths - (set! path '()))) + (begin + (let*((arg (cadr parts)) + (resolved-path (sauth-common:resolve-path arg path top-areas)) + (target-path (sauth-common:get-target-path path arg top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (equal? resolved-path #f) (not (file-exists? target-path))) + (print "Invalid argument " arg ".. ") + (begin + (set! path resolved-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd")))) + ))))) + (set! path '()))) + ((pwd) + (if (null? path) + (print "/") + (print "/" (string-join path "/")))) ((ls) (let* ((thepath (if (> (length parts) 1) ;; have a parameter (cdr parts) - path)) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (sauth-common:shell-ls-cmd path "" top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) ) + ((< plen 2) + + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))) + (else + (if (equal? (car thepath) "|") + (sauth-common:shell-ls-cmd path "" top-areas base-path thepath) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))) + ((cat) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to cat")) + ((< plen 2) + (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat"))))) + + (else + (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path (cdr thepath)) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat")))) +)))) + ((sgrep) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing arguments to grep!! Useage: grep [options] ")) + ((< plen 2) + (print "Error: Missing arguments to grep!! Useage: grep [options] ")) + (else + (sretrieve:shell-grep-cmd path (car thepath) top-areas base-path (cdr thepath)) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "grep")))))))) + + ((less) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to less")) + ((< plen 2) + (sretrieve:shell-less-cmd path (car thepath) top-areas base-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "less"))))) + (else + (print "less cmd takes only one () argument!!"))))) + ((get) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) (plen (length thepath))) (cond ((null? thepath) - (print (string-intersperse top-areas " "))) - ((and (< plen 2) - (member (car thepath) top-areas)) - (system (conc "ls /p/fdk/gwa/" (car thepath)))) - (else ;; have a long path - ;; check for access rights here - (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/"))))))) + (print "Error: Missing argument to get")) + ((< plen 2) + (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + (if (not (equal? target-path #f)) + (begin + (sretrieve:get-shell-cmd target-path base-path restrictions iport) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))))))) + (else + (print "Error: get cmd takes only one argument "))))) + ((exit) + (print "got exit")) + ((help) + (print (sretrieve:shell-help))) (else (print "Got command: " inl)))) - (loop (read-line))))))))) + (loop (read-line iport))))))) +;;)) ;;====================================================================== ;; MAIN ;;====================================================================== - -(define (sretrieve:load-config exe-dir exe-name) - (let* ((fname (conc exe-dir "/." exe-name ".config"))) - ;; (ini:property-separator-patt " * *") - ;; (ini:property-separator #\space) - (if (file-exists? fname) - ;; (ini:read-ini fname) - (read-config fname #f #t) - (make-hash-table)))) +;;(define *default-log-port* (current-error-port)) + +;(define (sretrieve:load-config exe-dir exe-name) +; (let* ((fname (conc exe-dir "/." exe-name ".config"))) +; ;; (ini:property-separator-patt " * *") +; ;; (ini:property-separator #\space) +; (if (file-exists? fname) +; ;; (ini:read-ini fname) +; (read-config fname #f #f) +; (make-hash-table)))) ;; package-type is "megatest", "builds", "kits" etc. ;; -(define (sretrieve:load-packages configdat exe-dir package-type) - (push-directory exe-dir) - (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir")) - (conversion-script (configf:lookup configdat "settings" "conversion-script")) - (upstream-file (configf:lookup configdat "settings" "upstream-file")) - (package-config (conc packages-metadir "/" package-type ".config"))) - ;; this section here does a timestamp based rebuild of the - ;; /.config file using - ;; as an input - (if (file-exists? upstream-file) - (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer - (> (file-modification-time upstream-file)(file-modification-time package-config))) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "failed to run script " conversion-script " with params " upstream-file " " package-config) - (let ((pid (process-run conversion-script (list upstream-file package-config)))) - (process-wait pid))) - (debug:print 0 *default-log-port* "Skipping update of " package-config " from " upstream-file)) - (debug:print 0 *default-log-port* "Skipping update of " package-config " as " upstream-file " not found")) - ;; (ini:property-separator-patt " * *") - ;; (ini:property-separator #\space) - (let ((res (if (file-exists? package-config) - (begin - (debug:print 0 *default-log-port* "Reading package config " package-config) - (read-config package-config #f #t)) - (make-hash-table)))) - (pop-directory) - res))) - -(define (sretrieve:process-action configdat action . args) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) - (user (current-user-name)) - (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) - (allowed-users (string-split - (or (configf:lookup configdat "settings" "allowed-users") - ""))) - (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package - - (if (not base-dir) - (begin - (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") - (exit))) - (if (null? allowed-users) - (begin - (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") - (exit))) - (if (not (member user allowed-users)) - (begin - (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting") - (exit 1))) + +;(define (sretrieve:load-packages configdat exe-dir package-type) +; (push-directory exe-dir) +; (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir")) +; (conversion-script (configf:lookup configdat "settings" "conversion-script")) +; (upstream-file (configf:lookup configdat "settings" "upstream-file")) +; (package-config (conc packages-metadir "/" package-type ".config"))) +; (if (file-exists? upstream-file) +; (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer +; (> (file-modification-time upstream-file)(file-modification-time package-config))) +; (handle-exceptions +; exn +; (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) +; (let ((pid (process-run conversion-script (list upstream-file package-config)))) +; (process-wait pid))) +; (debug:print 0 "Skipping update of " package-config " from " upstream-file)) +; (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found")) +; (let ((res (if (file-exists? package-config) +; (begin +; (debug:print 0 "Reading package config " package-config) +; (read-config package-config #f #t)) +; (make-hash-table)))) +; (pop-directory) +; res))) + +(define (toplevel-command . args) #f) +(define (sretrieve:process-action action . args) + ; (print action) + ; (use readline) (case (string->symbol action) ((get) - (if (< (length args) 1) - (begin - (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) - (version (car args)) - (msg (or (args:get-arg "-m") "")) - (package-type (or (args:get-arg "-package") - default-area)) - (exe-dir (configf:lookup configdat "exe-info" "exe-dir"))) -;; (relconfig (sretrieve:load-packages configdat exe-dir package-type))) - - (debug:print 0 *default-log-port* "retrieving " version " of " package-type " as tar data on stdout") - (sretrieve:get configdat user version msg))) - ((cp) - (if (< (length args) 1) - (begin - (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) - (file (car args)) - (msg (or (args:get-arg "-m") "")) ) - - (debug:print 0 *default-log-port* "copinging " file " to current directory " ) - (sretrieve:cp configdat user file msg))) - ((ls) - (if (< (length args) 1) - (begin - (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) - (dir (car args)) - (msg (or (args:get-arg "-m") "")) ) - - (debug:print 0 *default-log-port* "Listing files in " ) - (sretrieve:ls configdat user dir msg))) - - (else (debug:print 0 *default-log-port* "Unrecognised command " action))))) - -;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! -;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc"))) -;; (if (file-exists? debugcontrolf) -;; (load debugcontrolf))) + (if (< (length args) 2) + (begin + (sauth:print-error "Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (iport (make-readline-port ">")) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + + (if (null? area-obj) + (begin + (sauth:print-error (conc "Area " area " does not exist")) + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((cp) + (if (< (length args) 2) + (begin + (sauth:print-error "Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (iport (make-readline-port ">")) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + ; (print args) + (if (null? area-obj) + (begin + (sauth:print-error (conc "Area " area " does not exist")) + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + ;(print target-path) + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((ls) + (cond + ((< (length args) 1) + (begin + (print "ERROR: Missing arguments; ") + (exit 1))) + ((equal? (length args) 1) + (let* ((area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj))))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (sauth-common:shell-ls-cmd '() area top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))) + ((> (length args) 1) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (usr (current-user-name)) + (user-obj (get-user usr)) + (area (car args))) + (let* ((area-obj (get-obj-by-code area)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + + (sub-path (if (null? remargs) + area + (conc area "/" (car remargs))))) + ;(print "sub path " sub-path) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (sauth-common:shell-ls-cmd `() sub-path top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))) + + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments !!" ) + (exit 1)) + (sretrieve:shell (car args)))) + (else (print 0 "Unrecognised command " action)))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) (exe-name (pathname-file (car (argv)))) (exe-dir (or (pathname-directory prog) (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":")))) - (configdat (sretrieve:load-config exe-dir exe-name))) + ;(configdat (sretrieve:load-config exe-dir exe-name)) +) ;; preserve the exe data in the config file - (hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name) - (list "exe-dir" exe-dir))) + ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name) + ; (list "exe-dir" exe-dir))) (cond ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print sretrieve:help)) - ((list-vars) ;; print out the ini file - (map print (sretrieve:get-areas configdat))) - ((ls) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))) - (if base-dir - (begin - (print "Files in " base-dir) - (sretrieve:do-as-calling-user - (lambda () - (process-execute "/bin/ls" (list "-lrt" base-dir))))) - (print "ERROR: No base dir specified!")))) - ((log) - (sretrieve:db-do configdat (lambda (db) - (print "Logs : ") - (query (for-each-row - (lambda (row) - (apply print (intersperse row " | ")))) - (sql db "SELECT * FROM actions"))))) - ((shell) - (sretrieve:shell)) (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2) - (apply sretrieve:process-action configdat (car rema)(cdr rema))) - (else (debug:print-error 0 *default-log-port* "Unrecognised command. Try \"sretrieve help\""))))) + + (apply sretrieve:process-action (car rema) (cdr rema))) + (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main) + + + Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -618,63 +618,261 @@ (case modifier ((none)(loop (conc (current-user-name) "_" area-name) 'user)) ((user)(loop (conc (substring (common:get-area-path-signature) 0 4) area-name) 'areasig)) (else #f)))))) ;; give up + +(define (task:print-runtime run-times saperator) +(for-each + (lambda (run-time-info) + (let* ((run-name (vector-ref run-time-info 0)) + (run-time (vector-ref run-time-info 1)) + (target (vector-ref run-time-info 2))) + (print target saperator run-name saperator run-time ))) + run-times)) + +(define (task:print-runtime-as-json run-times) + (let loop ((run-time-info (car run-times)) + (rema (cdr run-times)) + (str "")) + (let* ((run-name (vector-ref run-time-info 0)) + (run-time (vector-ref run-time-info 1)) + (target (vector-ref run-time-info 2))) + ;(print (not (equal? str ""))) + (if (not (equal? str "")) + (set! str (conc str ","))) + (if (null? rema) + (print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]") + (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}")))))) + +(define (task:get-run-times) + (let* ( + (run-patt (if (args:get-arg "-run-patt") + (args:get-arg "-run-patt") + "%")) + (target-patt (if (args:get-arg "-target-patt") + (args:get-arg "-target-patt") + "%")) + + (run-times (rmt:get-run-times run-patt target-patt ))) + (if (eq? (length run-times) 0) + (begin + (print "Data not found!!") + (exit))) + (if (equal? (args:get-arg "-dumpmode") "json") + (task:print-runtime-as-json run-times) + (if (equal? (args:get-arg "-dumpmode") "csv") + (task:print-runtime run-times ",") + (task:print-runtime run-times " "))))) + + +(define (task:print-testtime test-times saperator) +(for-each + (lambda (test-time-info) + (let* ((test-name (vector-ref test-time-info 0)) + (test-time (vector-ref test-time-info 2)) + (test-item (if (eq? (string-length (vector-ref test-time-info 1)) 0) + "N/A" + (vector-ref test-time-info 1)))) + (print test-name saperator test-item saperator test-time ))) + test-times)) + +(define (task:print-testtime-as-json test-times) + (let loop ((test-time-info (car test-times)) + (rema (cdr test-times)) + (str "")) + (let* ((test-name (vector-ref test-time-info 0)) + (test-time (vector-ref test-time-info 2)) + (item (vector-ref test-time-info 1))) + ;(print (not (equal? str ""))) + (if (not (equal? str "")) + (set! str (conc str ","))) + (if (null? rema) + (print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]") + (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}")))))) + + + (define (task:get-test-times) + (let* ((runname (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f)) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + + (test-times (rmt:get-test-times runname target ))) + (if (not runname) + (begin + (print "Error: Missing argument -runname") + (exit))) + (if (string-contains runname "%") + (begin + (print "Error: Invalid runname, '%' not allowed (" runname ") ") + (exit))) + (if (not target) + (begin + (print "Error: Missing argument -target") + (exit))) + (if (string-contains target "%") + (begin + (print "Error: Invalid target, '%' not allowed (" target ") ") + (exit))) + + (if (eq? (length test-times) 0) + (begin + (print "Data not found!!") + (exit))) + (if (equal? (args:get-arg "-dumpmode") "json") + (task:print-testtime-as-json test-times) + (if (equal? (args:get-arg "-dumpmode") "csv") + (task:print-testtime test-times ",") + (task:print-testtime test-times " "))))) + + ;; gets mtpg-run-id and syncs the record if different ;; -(define (tasks:run-id->mtpg-run-id dbh cached-info run-id) +(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) (let* ((runs-ht (hash-table-ref cached-info 'runs)) - (runinf (hash-table-ref/default runs-ht run-id #f))) - (if runinf + (runinf (hash-table-ref/default runs-ht run-id #f)) + (area-id (vector-ref area-info 0))) + (if runinf runinf ;; already cached (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > (run-name (rmt:get-run-name-from-id run-id)) (row (db:get-rows run-dat)) ;; yes, this returns a single row (header (db:get-header run-dat)) - (state (db:get-value-by-header row header "state ")) + (state (db:get-value-by-header row header "state")) (status (db:get-value-by-header row header "status")) (owner (db:get-value-by-header row header "owner")) (event-time (db:get-value-by-header row header "event_time")) (comment (db:get-value-by-header row header "comment")) (fail-count (db:get-value-by-header row header "fail_count")) (pass-count (db:get-value-by-header row header "pass_count")) - (contour (if (args:get-arg "-prepend-contour") (db:get-value-by-header row header "contour"))) + (db-contour (db:get-value-by-header row header "contour")) + (contour (if (args:get-arg "-prepend-contour") + (if (and db-contour (not (equal? db-contour ""))) + (begin + (print "db-contour") + db-contour) + (args:get-arg "-contour")))) (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu (spec-id (pgdb:get-ttype dbh keytarg)) - (new-run-id (pgdb:get-run-id dbh spec-id target run-name)) - - - + (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id)) ;; (area-id (db:get-value-by-header row header "area_id)")) ) - (if new-run-id + (if new-run-id (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) (hash-table-set! runs-ht run-id new-run-id) ;; ensure key fields are up to date (pgdb:refresh-run-info dbh new-run-id - state status owner event-time comment fail-count pass-count) + state status owner event-time comment fail-count pass-count area-id) new-run-id) - (if (handle-exceptions + (if (equal? state "deleted") + (begin + (print "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) + (if (handle-exceptions exn - (begin (print-call-chain) #f) - (pgdb:insert-run + (begin (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + + (pgdb:insert-run dbh - spec-id target run-name state status owner event-time comment fail-count pass-count)) ;; area-id)) - (tasks:run-id->mtpg-run-id dbh cached-info run-id) - #f)))))) + spec-id target run-name state status owner event-time comment fail-count pass-count area-id)) + (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) + #f))))))) + + +(define (tasks:sync-test-steps dbh cached-info test-step-ids) + (print "Sync Steps " test-step-ids ) + (let ((test-ht (hash-table-ref cached-info 'tests)) + (step-ht (hash-table-ref cached-info 'steps))) + (for-each + (lambda (test-step-id) + (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id)) + (step-id (tdb:step-get-id test-step-info)) + (test-id (tdb:step-get-test_id test-step-info)) + (stepname (tdb:step-get-stepname test-step-info)) + (state (tdb:step-get-state test-step-info)) + (status (tdb:step-get-status test-step-info)) + (event_time (tdb:step-get-event_time test-step-info)) + (comment (tdb:step-get-comment test-step-info)) + (logfile (tdb:step-get-logfile test-step-info)) + (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) + (pgdb-step-id (if pgdb-test-id + (pgdb:get-test-step-id dbh pgdb-test-id stepname state) + #f))) + (if step-id + (begin + (if pgdb-test-id + (begin + (if pgdb-step-id + (begin + (print "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id ) + (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile)) + (begin + (print "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id) + (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile ) + (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state)))) + (hash-table-set! step-ht step-id pgdb-step-id )) + (print "Error: Test not cashed"))) + (print "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug + test-step-ids))) + +(define (tasks:sync-test-gen-data dbh cached-info test-data-ids) + (let ((test-ht (hash-table-ref cached-info 'tests)) + (data-ht (hash-table-ref cached-info 'data))) + (for-each + (lambda (test-data-id) + (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) + (data-id (db:test-data-get-id test-data-info)) + (test-id (db:test-data-get-test_id test-data-info)) + (category (db:test-data-get-category test-data-info)) + (variable (db:test-data-get-variable test-data-info)) + (value (db:test-data-get-value test-data-info)) + (expected (db:test-data-get-expected test-data-info)) + (tol (db:test-data-get-tol test-data-info)) + (units (db:test-data-get-units test-data-info)) + (comment (db:test-data-get-comment test-data-info)) + (status (db:test-data-get-status test-data-info)) + (type (db:test-data-get-type test-data-info)) + (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) + (pgdb-data-id (if pgdb-test-id + (pgdb:get-test-data-id dbh pgdb-test-id category variable) + #f))) + (if data-id + (begin + (if pgdb-test-id + (begin + (if pgdb-data-id + (begin + (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) + (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type)) + (begin + (print "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) + (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) + (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))) + (hash-table-set! data-ht data-id pgdb-data-id )) + (begin + (print "Error: Test not in pgdb")))) + + (print "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug + test-data-ids))) + + -(define (tasks:sync-tests-data dbh cached-info test-ids) +(define (tasks:sync-tests-data dbh cached-info test-ids area-info) (let ((test-ht (hash-table-ref cached-info 'tests))) (for-each (lambda (test-id) + ;(print test-id) (let* ((test-info (rmt:get-test-info-by-id #f test-id)) (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm (test-id (db:test-get-id test-info)) (test-name (db:test-get-testname test-info)) (item-path (db:test-get-item-path test-info)) @@ -688,24 +886,55 @@ (log-file (db:test-get-final_logf test-info)) (run-duration (db:test-get-run_duration test-info)) (comment (db:test-get-comment test-info)) (event-time (db:test-get-event_time test-info)) (archived (db:test-get-archived test-info)) - (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id)) - (pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))) + (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)) + + (pgdb-test-id (if pgdb-run-id + (begin + ;(print pgdb-run-id) + (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) + #f))) ;; "id" "run_id" "testname" "state" "status" "event_time" ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" - (if pgdb-test-id ;; have a record + (if pgdb-run-id + (begin + (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) - (hash-table-set! test-ht test-id pgdb-test-id) - (print "Updating existing test with run-id: " run-id " and test-id: " test-id) + (print "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)) - (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)) - )) + (begin + (print "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) + (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) + (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) + (hash-table-set! test-ht test-id pgdb-test-id)) + (print "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) test-ids))) +(define (task:add-area-tag dbh area-info tag) + (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) + (if (not tag-info) + (begin + (if (handle-exceptions + exn + (begin + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + (pgdb:insert-tag dbh tag)) + (set! tag-info (pgdb:get-tag-info-by-name dbh tag)) + #f))) + ;;add to area_tags + (handle-exceptions + exn + (begin + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))) + (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))))) + ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) @@ -713,27 +942,39 @@ (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds))) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) - '(runs targets tests)) + '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info (let* ((last-sync-time (vector-ref area-info 3)) (changed (rmt:get-changed-record-ids last-sync-time)) (run-ids (alist-ref 'runs changed)) (test-ids (alist-ref 'tests changed)) (test-step-ids (alist-ref 'test_steps changed)) (test-data-ids (alist-ref 'test_data changed)) - (run-stat-ids (alist-ref 'run_stats changed))) - (print "area-info: " area-info) + (run-stat-ids (alist-ref 'run_stats changed)) + (area-tag (if (args:get-arg "-area-tag") + (args:get-arg "-area-tag") + ""))) + ; (print "area-info: " area-info) + (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) + (set! area-tag *default-area-tag*)) + (if (not (equal? area-tag "")) + (task:add-area-tag dbh area-info area-tag)) (if (not (null? test-ids)) (begin - (print "Syncing " (length test-ids) " changed tests") - (tasks:sync-tests-data dbh cached-info test-ids))) + (print "Syncing " (length test-step-ids) " changed tests") + ;;Assumption here is that if test-step or test data is changed then the test last update time is changed + ;; not syncing run stats at this time as they can be derived from tests table. + (tasks:sync-tests-data dbh cached-info test-ids area-info) + ;(exit) + (tasks:sync-test-steps dbh cached-info test-step-ids) + (tasks:sync-test-gen-data dbh cached-info test-data-ids))) (pgdb:write-sync-time dbh area-info start)) (if (tasks:set-area dbh configdat) (tasks:sync-to-postgres configdat dest) (begin (debug:print 0 *default-log-port* "ERROR: unable to create an area record") #f))))) Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -13,11 +13,14 @@ ;; ;; 1. Run the megatest process and pass it all the needed parameters ;; 2. Every five seconds check for state/status changes and print the info ;; -(use srfi-1 posix srfi-69 srfi-18 regex) +(use srfi-1 posix srfi-69 srfi-18 regex defstruct) + +(use trace) +;; (trace-call-sites #t) (declare (uses margs)) (declare (uses rmt)) (declare (uses common)) (declare (uses megatest-version)) @@ -29,92 +32,248 @@ (define remargs (args:get-args (argv) `( "-target" "-reqtarg" "-runname" + "-delay" ;; how long to wait for unexpected changes to ) `("-tc-repl" ) args:arg-hash 0)) -;; ##teamcity[testStarted name='suite.testName'] +(defstruct testdat + (tc-type #f) + (state #f) + (status #f) + (overall #f) + (flowid #f) + tctname + tname + (event-time #f) + details + comment + duration + (start-printed #f) + (end-printed #f)) + +;;====================================================================== +;; GLOBALS +;;====================================================================== + +;; Gotta have a global? Stash it in the *global* hash table. +;; +(define *global* (make-hash-table)) + +(define (tcmt:print tdat flush-mode) + (let* ((comment (if (testdat-comment tdat) + (conc " message='" (testdat-comment tdat) "'") + "")) + (details (if (testdat-details tdat) + (conc " details='" (testdat-details tdat) "'") + "")) + (flowid (conc " flowId='" (testdat-flowid tdat) "'")) + (duration (conc " duration='" (* 1e3 (testdat-duration tdat)) "'")) + (tcname (conc " name='" (testdat-tctname tdat) "'")) + (state (string->symbol (testdat-state tdat))) + (status (string->symbol (testdat-status tdat))) + (startp (testdat-start-printed tdat)) + (endp (testdat-end-printed tdat)) + (etime (testdat-event-time tdat)) + (overall (case state + ((RUNNING) state) + ((COMPLETED) state) + (else 'UNK))) + (tstmp (conc " timestamp='" (time->string (seconds->local-time etime) "%FT%T.000") "'"))) + (case overall + ((RUNNING) + (if (not startp) + (begin + (print "##teamcity[testStarted " tcname flowid tstmp "]") + (testdat-start-printed-set! tdat #t)))) + ((COMPLETED) + (if (not startp) ;; start stanza never printed + (begin + (print "##teamcity[testStarted " tcname flowid tstmp "]") + (testdat-start-printed-set! tdat #t))) + (if (not endp) + (begin + (if (not (member status '(PASS WARN SKIP WAIVED))) + (print "##teamcity[testFailed " tcname flowid comment details "]")) + (print "##teamcity[testFinished" tcname flowid comment details duration "]") + (testdat-end-printed-set! tdat #t)))) + (else + (if flush-mode + (begin + (if (not startp) + (begin + (print "##teamcity[testStarted " tcname flowid tstmp "]") + (testdat-start-printed-set! tdat #t))) + (if (not endp) + (begin + (print "##teamcity[testFailed " tcname flowid comment details "]") + (print "##teamcity[testFinished" tcname flowid comment details duration "]") + (testdat-end-printed-set! tdat #t))))))) + ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname))) + (flush-output))) + +;; ;; returns values: flag newlst +;; (define (remove-duplicate-completed tdats) +;; (let* ((flag #f) +;; (state (testdat-state tdat)) +;; (status (testdat-status tdat)) +;; (event-time (testdat-event-time tdat)) +;; (tname (testdat-tname tdat))) +;; (let loop ((hed (car tdats)) +;; (tal (cdr tdats)) +;; (new '())) +;; (if (and (equal? state "COMPLETED") +;; (equal? tname (testdat-tname hed)) +;; (equal? state (testdat-state hed))) ;; we have a duplicate COMPLETED call +;; (begin +;; (set! flag #t) ;; A changed completed + +;; process the queue of tests gathered so far. List includes one entry for every test so far seen +;; the last record for a test is preserved. Items are only removed from the list if over 15 seconds +;; have passed since it happened. This allows for compression of COMPLETED/FAIL followed by some other +;; state/status +;; +(define (process-queue data age flush-mode) + ;; here we process tqueue and gather those over 15 seconds (configurable?) old + (let* ((print-time (- (current-seconds) age)) ;; print stuff over 15 seconds old + (tqueue-raw (hash-table-ref/default data 'tqueue '())) + (tqueue (reverse (delete-duplicates tqueue-raw ;; REMOVE duplicates by testname and state + (lambda (a b) + (and (equal? (testdat-tname a)(testdat-tname b)) ;; need oldest to newest + (equal? (testdat-state a) (testdat-state b)))))))) ;; "COMPLETED") + ;; (equal? (testdat-state b) "COMPLETED"))))))) + (if (not (null? tqueue)) + (hash-table-set! + data + 'tqueue + (let loop ((hed (car tqueue)) ;; by this point all duplicates by state COMPLETED are removed + (tal (cdr tqueue)) + (rem '())) + (if (> print-time (testdat-event-time hed)) ;; event happened over 15 seconds ago + (begin + (tcmt:print hed flush-mode) + (if (null? tal) + rem ;; return rem to be processed in the future + (loop (car tal)(cdr tal) rem))) + (if (null? tal) + (cons hed rem) ;; return rem + hed for future processing + (loop (car tal)(cdr tal)(cons hed rem))))))))) + + ;; ##teamcity[testStarted name='suite.testName'] ;; ##teamcity[testStdOut name='suite.testName' out='text'] ;; ##teamcity[testStdErr name='suite.testName' out='error text'] ;; ##teamcity[testFailed name='suite.testName' message='failure message' details='message and stack trace'] ;; ##teamcity[testFinished name='suite.testName' duration='50'] ;; +;; flush; #f, normal call. #t, last call, print out something for NOT_STARTED, etc. +;; + +;;;;;;; (begin +;;;;;;; (case (string->symbol newstat) +;;;;;;; ((UNK) ) ;; do nothing +;;;;;;; ((RUNNING) (print "##teamcity[testStarted name='" tctname "' flowId='" flowid "']")) +;;;;;;; ((PASS SKIP WARN WAIVED) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " flowId='" flowid "']")) +;;;;;;; (else +;;;;;;; (print "##teamcity[testFailed name='" tctname "' " cmtstr details " flowId='" flowid "']"))) +;;;;;;; (flush-output) + +;; (trace rmt:get-tests-for-run) -(define (print-changes-since data run-ids last-update tsname target runname) +(define (update-queue-since data run-ids last-update tsname target runname flowid flush) ;; (let ((now (current-seconds))) - (handle-exceptions - exn - (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) - (for-each - (lambda (run-id) - (let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f last-update #f))) - ;; (print "DEBUG: got tests=" tests) - (for-each - (lambda (testdat) - (let* ((testn (db:test-get-fullname testdat)) - (testname (db:test-get-testname testdat)) - (itempath (db:test-get-item-path testdat)) - (tctname (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" ".")))) - (state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (duration (or (any->number (db:test-get-run_duration testdat)) 0)) - (comment (db:test-get-comment testdat)) - (logfile (db:test-get-final_logf testdat)) - (prevstat (hash-table-ref/default data testn #f)) - (newstat (if (equal? state "RUNNING") - "RUNNING" - (if (equal? state "COMPLETED") - status - "UNK"))) - (cmtstr (if comment - (conc " message='" comment "' ") - " ")) - (details (if (string-match ".*html$" logfile) - (conc " details='" *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile "' ") - ""))) - - ;; (print "DEBUG: testn=" testn " state=" state " status=" status " prevstat=" prevstat " newstat=" newstat) - (if (or (not prevstat) - (not (equal? prevstat newstat))) - (begin - (case (string->symbol newstat) - ((UNK) ) ;; do nothing - ((RUNNING) (print "##teamcity[testStarted name='" tctname "']")) - ((PASS SKIP) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " ]")) - (else - (print "##teamcity[testFailed name='" tctname "' " cmtstr details " ]"))) - (flush-output) - (hash-table-set! data testn newstat))))) - tests))) - run-ids)) - now)) - +;; (handle-exceptions +;; exn +;; (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + (for-each + (lambda (run-id) + (let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f last-update #f))) + ;; (print "DEBUG: got tests=" tests) + (for-each + (lambda (test-rec) + (let* ((tqueue (hash-table-ref/default data 'tqueue '())) ;; NOTE: the key is a symbol! This allows keeping disparate info in the one hash, lazy but a quick solution for right now. + (is-top (db:test-get-is-toplevel test-rec)) + (tname (db:test-get-fullname test-rec)) + (testname (db:test-get-testname test-rec)) + (itempath (db:test-get-item-path test-rec)) + (tctname (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" ".")))) + (state (db:test-get-state test-rec)) + (status (db:test-get-status test-rec)) + (etime (db:test-get-event_time test-rec)) + (duration (or (any->number (db:test-get-run_duration test-rec)) 0)) + (comment (db:test-get-comment test-rec)) + (logfile (db:test-get-final_logf test-rec)) + (hostn (db:test-get-host test-rec)) + (pid (db:test-get-process_id test-rec)) + (newstat (cond + ((equal? state "RUNNING") "RUNNING") + ((equal? state "COMPLETED") status) + (flush (conc state "/" status)) + (else "UNK"))) + (cmtstr (if (and (not flush) comment) + comment + (if flush + (conc "Test ended in state/status=" state "/" status (if (string-match "^\\s*$" comment) + ", no Megatest comment found." + (conc ", Megatest comment=\"" comment "\""))) ;; special case, we are handling stragglers + #f))) + (details (if (string-match ".*html$" logfile) + (conc *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile) + #f)) + (prev-tdat (hash-table-ref/default data tname #f)) + (tdat (if is-top + #f + (let ((new (or prev-tdat (make-testdat)))) ;; recycle the record so we keep track of already printed items + (testdat-flowid-set! new (or (testdat-flowid new) + (if (eq? pid 0) + tctname + (conc hostn "-" pid)))) + (testdat-tctname-set! new tctname) + (testdat-tname-set! new tname) + (testdat-state-set! new state) + (testdat-status-set! new status) + (testdat-comment-set! new cmtstr) + (testdat-details-set! new details) + (testdat-duration-set! new duration) + (testdat-event-time-set! new etime) ;; (current-seconds)) + (testdat-overall-set! new newstat) + (hash-table-set! data tname new) + new)))) + (if (not is-top) + (hash-table-set! data 'tqueue (cons tdat tqueue))) + (hash-table-set! data tname tdat) + )) + tests))) + run-ids) + now)) + (define (monitor pid) - (let ((run-ids #f) - (testdat (make-hash-table)) - (keys #f) - (last-update 0) - (target (or (args:get-arg "-target") - (args:get-arg "-reqtarg"))) - (runname (args:get-arg "-runname")) - (tsname #f)) + (let* ((run-ids '()) + (testdats (make-hash-table)) ;; each entry is a list of testdat structs + (keys #f) + (last-update 0) + (target (or (args:get-arg "-target") + (args:get-arg "-reqtarg"))) + (runname (args:get-arg "-runname")) + (tsname #f) + (flowid (conc target "/" runname)) + (tdelay (string->number (or (args:get-arg "-delay") "15")))) (if (and target runname) (begin (launch:setup) (set! keys (rmt:get-keys)))) (set! tsname (common:get-testsuite-name)) - (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup.") + (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.") (let loop () - (handle-exceptions - exn - ;; (print "Process done.") - (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + ;;;;;; (handle-exceptions + ;;;;;; exn + ;;;;;; ;; (print "Process done.") + ;;;;;; (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) (let-values (((pidres exittype exitstatus) (process-wait pid #t))) (if (and keys (or (not run-ids) (null? run-ids))) @@ -131,20 +290,28 @@ (run-ids-in (map (lambda (row) (db:get-value-by-header row header "id")) rows))) (set! run-ids run-ids-in))) ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) - (if keys - (set! last-update (print-changes-since testdat run-ids last-update tsname target runname))) (if (eq? pidres 0) (begin - (thread-sleep! 3) + (if keys + (begin + (set! last-update (- (update-queue-since testdats run-ids last-update tsname target runname flowid #f) 5)) + (process-queue testdats tdelay #f))) + (thread-sleep! 3) (loop)) (begin ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) + (print "TCMT: processing any tests that did not formally complete.") + (update-queue-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode + (process-queue testdats 0 #t) (print "TCMT: All done.") - ))))))) + )))))) +;;;;; ) + +;; (trace print-changes-since) ;; (if (not (eq? pidres 0)) ;; (not exitstatus)) ;; (begin ;; (thread-sleep! 3) ;; (loop)) Index: testnanomsg/req-rep.scm ================================================================== --- testnanomsg/req-rep.scm +++ testnanomsg/req-rep.scm @@ -1,30 +1,33 @@ ;; watch nanomsg's pipeline load-balancer in action. (use nanomsg) +;; client (define req (nn-socket 'req)) -(define rep (nn-socket 'rep)) - -(nn-bind rep "inproc://test") -(nn-connect req "inproc://test") +(nn-connect req "inproc://test") (define (client-send-receive soc msg) (nn-send soc msg) (nn-recv soc)) +;; server +(define rep (nn-socket 'rep)) +(nn-bind rep "inproc://test") + (define ((server soc)) (let loop ((msg-in (nn-recv soc))) (if (not (equal? msg-in "quit")) (begin (nn-send soc (conc "hello " msg-in)) (loop (nn-recv soc)))))) (thread-start! (server rep)) +;; client (print (client-send-receive req "Matt")) (print (client-send-receive req "Tom")) ;; (client-send-receive req "quit") -(nn-close req) -(nn-close rep) +(nn-close req) ;; client +(nn-close rep) ;; server (exit) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -31,10 +31,12 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") +(include "js-path.scm") + ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; @@ -146,11 +148,11 @@ ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry) - (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) + (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t) (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) @@ -217,15 +219,26 @@ ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt))))) ;; (print "in map, x=" x ", newpatt=" newpatt) newpatt)) (filter (lambda (x) (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test - patts)))) - (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton) - (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this - patts-waiton))) - ","))) + patts))) + (extended-test-patt (append patts (if (null? patts-waiton) + (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this + patts-waiton))) + (extended-test-patt-with-toplevels + (fold (lambda (testpatt-item accum ) + (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item))) + (cons testpatt-item + (if my-match + (cons + (conc (cadr my-match) "/") + accum) + accum)))) + '() + extended-test-patt))) + (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ","))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) @@ -583,13 +596,11 @@ .HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */ th {background-color: #8c8c8c;} td.test {background-color: #d9dbdd;} td.PASS {background-color: #347533;} td.FAIL {background-color: #cc2812;} - - - + EOF ) +(define tests:css-jscript-block-dynamic +#< +EOF +) + +(define (test:js-block javascript-lib) + (conc "" )) + + +(define tests:css-jscript-block-static (test:js-block *java-script-lib*)) + +(define (tests:css-jscript-block-cond dynamic) + (if (equal? dynamic #t) + tests:css-jscript-block-dynamic + tests:css-jscript-block-static)) + + (define (tests:run-record->test-path run numkeys) (append (take (vector->list run) numkeys) (list (vector-ref run (+ 1 numkeys))))) @@ -711,55 +740,31 @@ (hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path)))) test-data))) runs) resh)) -;; (tests:create-html-tree "test-index.html") +;; tests:genrate dashboard body ;; -(define (tests:create-html-tree outf) - (let* ((lockfile (conc outf ".lock")) - (runs-to-process '()) - (linktree (common:get-linktree)) - (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) - (numkeys (length keys)) - (total-runs (rmt:get-num-runs "%")) - (pg-size 10) ) - (if (common:simple-file-lock lockfile) - (begin - (print total-runs) - (let loop ((page 0)) - (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) - (start (* page pg-size)) + +(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag) + (let* ((start (* page pg-size)) (runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) (header (vector-ref runsdat 0)) (runs (vector-ref runsdat 1)) (ctr 0) (test-runs-hash (tests:get-rest-data runs header numkeys)) (test-list (hash-table-keys test-runs-hash)) - (get-prev-links (lambda (page linktree ) - (let* ((link (if (not (eq? page 0)) - (s:a "<<prev" 'href (conc linktree "/page" (- page 1) ".html")) - (s:a "" 'href (conc linktree "/page" page ".html"))))) - link))) - (get-next-links (lambda (page linktree total-runs) - (let* ((link (if (> total-runs (+ 1 (* page pg-size))) - (s:a "next>>" 'href (conc linktree "/page" (+ page 1) ".html")) - (s:a "" 'href (conc linktree "/page" page ".html"))))) - link)))) - (s:output-new - oup - (s:html tests:css-jscript-block + ) + (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) (s:title "Summary for " area-name) (s:body 'onload "addEvents();" (get-prev-links page linktree) (get-next-links page linktree total-runs) (s:h1 "Summary for " area-name) (s:h3 "Filter" ) (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") - ;; top list (s:table 'id "LinkedList1" 'border "1" (map (lambda (key) (let* ((res (s:tr 'class "something" (s:th key ) @@ -784,31 +789,134 @@ (map (lambda (run) (let* ((run-test (hash-table-ref/default item-hash item-name #f)) (run-id (db:get-value-by-header run header "id")) (result (hash-table-ref/default run-test run-id "n/a")) (status (if (string? result) - (begin - ; (print "string" result) - result) - (begin - ; (print "not string" result ) - (car result))))) - (s:td status 'class status))) + result + (car result))) + (link (if (string? result) + result + (if (equal? flag #t) + (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) + (s:a (car result) 'href (cadr result)))))) + (s:td link 'class status))) runs)))) res)) item-keys))) - test-list))))) + test-list)))))) + +;; (tests:create-html-tree "test-index.html") +;; +(define (tests:create-html-tree outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '()) + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (total-runs (rmt:get-num-runs "%")) + (pg-size 10)) + (if (common:simple-file-lock lockfile) + (begin + ;(print total-runs) + (let loop ((page 0)) + (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) + (get-prev-links (lambda (page linktree ) + (let* ((link (if (not (eq? page 0)) + (s:a "<<prev" 'href (conc linktree "/page" (- page 1) ".html")) + (s:a "" 'href (conc linktree "/page" page ".html"))))) + link))) + (get-next-links (lambda (page linktree total-runs) + (let* ((link (if (> total-runs (+ 10 (* page pg-size))) + (s:a "next>>" 'href (conc linktree "/page" (+ page 1) ".html")) + (s:a "" 'href (conc linktree "/page" page ".html"))))) + link))) ) + ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name)) + (s:output-new + oup + (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f)) (close-output-port oup) ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) #f))) +(define (tests:readlines filename) + (call-with-input-file filename + (lambda (p) + (let loop ((line (read-line p)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line p) (cons line result))))))) + +(define (tests:get-test-log run-id test-name item-name) + (let* ((test-data (rmt:get-tests-for-run + (string->number run-id) + test-name ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (path "") + (found 0)) + (debug:print-info 0 *default-log-port* "found: " found ) + + (let loop ((hed (car test-data)) + (tal (cdr test-data))) + (debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13)) + + (if (equal? (vector-ref hed 11) item-name) + (begin + (set! found 1) + (set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13))))) + (if (and (not (null? tal)) (equal? found 0)) + (loop (car tal)(cdr tal)))) + (if (equal? path "") + "

Data not found

" + (string-join (tests:readlines path) "\n")))) + +(define (tests:dynamic-dboard page) +;(define (tests:create-html-tree o) + (let* ( +;(page "1") + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (total-runs (rmt:get-num-runs "%")) + (pg-size 10) + (pg (if (equal? page #f) + 0 + (- (string->number page) 1))) + (get-prev-links (lambda (pg linktree) + (debug:print-info 0 *default-log-port* "val: " (- 1 pg)) + (let* ((link (if (not (eq? pg 0)) + (s:a "<<prev " 'href (conc "dashboard?page=" pg )) + (s:a "" 'href (conc "dashboard?page=" pg))))) + link))) + (get-next-links (lambda (pg linktree total-runs) + (debug:print-info 0 *default-log-port* "val: " pg) + (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size) + + (let* ((link (if (> total-runs (+ 10 (* pg pg-size))) + (s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) )) + (s:a "" 'href (conc "dashboard?page=" pg ))))) + link))) + (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t))) + ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name)) +html-body)) (define (tests:create-html-tree-old outf) (let* ((lockfile (conc outf ".lock")) @@ -1160,11 +1268,11 @@ ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; -(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)) (let* ((use-cache (common:use-cache?)) (cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read @@ -1201,11 +1309,12 @@ #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file - (file-write-access? cache-path)) + (file-write-access? cache-path) + allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (not (common:in-running-test?)) (configf:write-alist tcfg tpath)))) tcfg)))))) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -254,10 +254,12 @@ # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log # launcher #{ shell if which bsub > /dev/null;then echo bsub -q priority -o openlava.log;else echo sleeprunner;fi} # launcher nbfake +maxload 1.1 +maxhomehostload 1.1 [configf:settings trim-trailing-spaces yes] # Override the rollup for specific tests [testrollup] ADDED tests/fullrun/test-teamcity-run.sh Index: tests/fullrun/test-teamcity-run.sh ================================================================== --- /dev/null +++ tests/fullrun/test-teamcity-run.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +(cd ../..;make install) && RN=tcmt_m;megatest -remove-runs -target ubuntu/nfs/none -runname tcmt_m -testpatt %;\ + tcmt -run -target ubuntu/nfs/none -runname tcmt_m -testpatt % -rerun-clean 2>&1 | tee all.log | grep teamcity | tee teamcity.log + ADDED trackback.scm Index: trackback.scm ================================================================== --- /dev/null +++ trackback.scm @@ -0,0 +1,36 @@ +(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 ")) + +(exit 0) + Index: utils/Makefile.git.installall ================================================================== --- utils/Makefile.git.installall +++ utils/Makefile.git.installall @@ -47,11 +47,11 @@ PROXY= # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.10.1 +CHICKEN_VERSION=4.12.0rc2 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -174,10 +174,13 @@ cd chicken-core; pwd cd chicken-core; fossil open ../chicken-scheme.fossil cd chicken-core; fossil up 337f5be # wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz +chicken-4.12.0rc2.tar.gz : + wget https://code.call-cc.org/dev-snapshots/2017/02/06/chicken-4.12.0rc2.tar.gz + # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(PRODCHICKEN)/bin/chicken : wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -45,11 +45,11 @@ # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc # CHICKEN_VERSION=4.10.0 -CHICKEN_VERSION=4.11.0rc2 +CHICKEN_VERSION=4.11.0 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -56,11 +56,11 @@ IUPCONFIG=ubuntu-15.04.inc # iup-3.15 # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ - dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + dot-locking posix-utils posix-extras hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars pathname-expand \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ crypt parley @@ -97,11 +97,11 @@ else ARCHSIZE=64_ endif CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') -CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C -fPIC" # CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) nogui : base mutils #all : nogui libiup $(PREFIX)/lib/sqlite3.so @@ -137,11 +137,12 @@ mkdir -p eggflags touch $(EGGFLAGS) # some setup stuff # -$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) +#$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) +$(PREFIX)/setup-chicken4x.sh : mkdir -p $(PREFIX) (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) $(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) @@ -149,35 +150,26 @@ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) # NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz - tar xf chicken-$(CHICKEN_VERSION).tar.gz + tar xzf chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi -chicken-4.9.0rc1.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz - -chicken-4.9.0.1.tar.gz : - wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz - -chicken-4.10.0rc1.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz - -chicken-4.10.0.tar.gz : - wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz - -chicken-4.11.0rc2.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz +chicken-4.11.0.tar.gz : + wget http://code.call-cc.org/releases/4.11.0/chicken-4.11.0.tar.gz # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh - cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) - cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + pwd; env; which make + cd chicken-core; make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core; make PLATFORM=linux PREFIX=$(PREFIX) install + #cd chicken-core;env -i PATH=${PATH} LD_LIBRARY_PATH=${LD_LIBRARY_PATH} make PLATFORM=linux PREFIX=$(PREFIX) + #cd chicken-core;env -i PATH=${PATH} LD_LIBRARY_PATH=${LD_LIBRARY_PATH} make PLATFORM=linux PREFIX=$(PREFIX) install #====================================================================== # S Q L I T E 3 #====================================================================== # https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz @@ -235,11 +227,12 @@ $(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm cd opensrc/margs;chicken-install opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so - cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + env | grep CSC + cd opensrc/histstore; $(PREFIX)/bin/csc histstore.scm -o hs $(PREFIX)/bin/hs : opensrc/histstore/hs cp -f opensrc/histstore/hs $(PREFIX)/bin/hs # stml @@ -254,11 +247,11 @@ stml/requirements.scm : stml/requirements.scm.template cp stml/install.cfg.template stml/install.cfg cp stml/requirements.scm.template stml/requirements.scm $(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm - cd stml;make + cd stml; make #====================================================================== # F F C A L L (Used by IUP) #====================================================================== @@ -280,34 +273,47 @@ iuplib.fossil : fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil cd-5.9_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download mv download cd-5.9_Linux26g4_64_lib.tar.gz +cd-5.10_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/cd-5.10_Linux26g4_64_lib.tar.gz cd-5.10_Linux26g4_64_lib.tar.gz + iup-3.17_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download - mv download iup-3.17_Linux26g4_64_lib.tar.gz + cp /p/fdk/gwa/jmoon18/iup-3.17_Linux26g4_64_lib.tar.gz iup-3.17_Linux26g4_64_lib.tar.gz +# wget --no-check-certificate -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download +# mv download iup-3.17_Linux26g4_64_lib.tar.gz + +iup-3.19.1_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/iup-3.19.1_Linux26g4_64_lib.tar.gz iup-3.19.1_Linux26g4_64_lib.tar.gz im-3.10_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download mv download im-3.10_Linux26g4_64_lib.tar.gz +im-3.11_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/im-3.11_Linux26g4_64_lib.tar.gz im-3.11_Linux26g4_64_lib.tar.gz + lua-5.3.2_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download mv download lua-5.3.2_Linux26g4_64_lib.tar.gz +lua-5.3.3_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/lua-5.3.3_Linux26g4_64_lib.tar.gz lua-5.3.3_Linux26g4_64_lib.tar.gz + iup/installall.sh : $(PREFIX)/lib/libiup.so \ - cd-5.9_Linux26g4_64_lib.tar.gz \ + cd-5.10_Linux26g4_64_lib.tar.gz \ iup-3.17_Linux26g4_64_lib.tar.gz \ - im-3.10_Linux26g4_64_lib.tar.gz \ - lua-5.3.2_Linux26g4_64_lib.tar.gz # iuplib.fossil + im-3.11_Linux26g4_64_lib.tar.gz \ + lua-5.3.3_Linux26g4_64_lib.tar.gz # iuplib.fossil mkdir -p iup pwd - tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ - tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf cd-5.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.11_Linux26g4_64_lib.tar.gz -C iup/ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ cp iup/include/* $(PREFIX)/include/ cp iup/*.so $(PREFIX)/lib/ cp iup/*.a $(PREFIX)/lib/ @@ -331,6 +337,6 @@ $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw clean : - rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) + rm -rf chicken-4.11.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) ADDED utils/checkPreReqs Index: utils/checkPreReqs ================================================================== --- /dev/null +++ utils/checkPreReqs @@ -0,0 +1,30 @@ +#!/bin/bash +SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i) +file=`/bin/mktemp` +case $SYSTEM_TYPE in +Ubuntu-17.04-x86_64-std) + apt list --installed | cut -d/ -f 1 > $file + ;; +Ubuntu-16.04-x86_64) + apt list --installed | cut -d/ -f 1 > $file + ;; +Ubuntu-16.04-i686) + apt list --installed | cut -d/ -f 1 > $file + ;; +SUSE_LINUX_11-x86_64) + rpm -qa > $file + ;; +CentOS_5.11-x86_64-std) + rpm -qa > $file + ;; +esac + + + +for package in libmysqlclient-dev libsqlite3-dev sqlite3 postgresql libreadline-dev libwebkitgtk-dev libpangox-1.0-0 zlib1g-dev libfreetype6 cmake libssl-dev uuid-dev libmotif3 mysql-client; do + grep --silent $package $file + if [ "$?" != "0" ]; then + echo "sudo apt install $package" + fi +done +rm $file Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -17,15 +17,16 @@ if [[ $OPTION=="" ]]; then export OPTION=std fi echo You may need to do the following first: -echo sudo apt-get install libreadline-dev -echo sudo apt-get install libwebkitgtk-dev -echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake -echo sudo apt-get install libssl-dev uuid-dev -echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 +echo sudo apt install libreadline-dev +echo sudo apt install libwebkitgtk-dev +echo sudo apt install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake +echo sudo apt install libssl-dev uuid-dev +echo sudo apt install libmotif3 -OR- set KTYPE=26g4 +echo sudo apt install cmake echo echo Set OPTION to std, currently OPTION=$OPTION echo echo Additionally, if you want mysql-client, you will need to make sure echo mysql_config is in your path @@ -35,110 +36,47 @@ echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION -CHICKEN_VERSION=4.11.0 -CHICKEN_BASEVER=4.11.0 + +CHICKEN_VERSION=4.10.0 +CHICKEN_BASEVER=4.10.0 # Set up variables # case $SYSTEM_TYPE in +Ubuntu-17.04-x86_64-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 + CHICKEN_VERSION=4.12.0 + CHICKEN_BASEVER=4.12.0 + ;; Ubuntu-16.04-x86_64-std) KTYPE=32 - CDVER=5.10 - IUPVER=3.17 - IMVER=3.11 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 CHICKEN_VERSION=4.12.0 CHICKEN_BASEVER=4.12.0 ;; Ubuntu-16.04-i686-std) KTYPE=32 - CDVER=5.10 - IUPVER=3.17 - IMVER=3.11 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 + CHICKEN_VERSION=4.12.0 + CHICKEN_BASEVER=4.12.0 ;; SUSE_LINUX_11-x86_64-std) - KTYPE=26g4 - CDVER=5.10 - IUPVER=3.17 - IMVER=3.11 - ;; -CentOS_5.11-x86_64-std) - KTYPE=24g3 - CDVER=5.4.1 - IUPVER=3.5 - IMVER=3.6.3 - ;; -esac - -echo KTYPE=$KTYPE -echo CDVER=$CDVER -echo IUPVER=$IUPVER -echo IMVER=$IMVER -# NOTES: -# -# Centos with security setup may need to do commands such as following as root: -# -# NB// fix the paths first -# -# for a in /localdisk/chicken/4.8.0/lib/*.so;do chcon -t textrel_shlib_t $a; done - -echo ADDITIONAL_LIBPATH=$ADDITIONAL_LIBPATH -echo -echo To use previous IUP libraries set USEOLDIUP to yes -echo USEOLDIUP=$USEOLDIUP -echo -echo Hit ^C now to do that - -# A nice way to run this script: -# -# script -c 'PREFIX=/tmp/delme ./installall.sh ' installall.log -# logpro installall.logpro installall.html < installall.log -# firefox installall.html - -sleep 5 - -if [[ $proxy == "" ]]; then - echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' - echo PROX="" -else - export http_proxy=http://$proxy - export PROX="-proxy $proxy" -fi - -if [[ $KTYPE == "" ]]; then - echo 'Using KTYPE=26' - export KTYPE=26g4 -else - echo Using KTYPE=$KTYPE -fi - -# Put all the downloaded tar files in tgz -mkdir -p tgz - -# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz -chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz -if ! [[ -e tgz/$chicken_targz ]]; then - wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz} - mv $chicken_targz tgz -fi - -BUILDHOME=$PWD -DEPLOYTARG=$BUILDHOME/deploy - -if [[ $PREFIX == "" ]]; then - PREFIX=$PWD/inst -fi - -export PATH=$PREFIX/bin:$PATH -export LIBPATH=$PREFIX/lib:$PREFIX/lib64:$ADDITIONAL_LIBPATH -export LD_LIBRARY_PATH=$LIBPATH -export CHICKEN_INSTALL=$PREFIX/bin/chicken-install -mkdir -p $PREFIX -echo "export PATH=$PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.sh -echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.sh + KTYPE=26g4 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 + >> $PREFIX/setup-chicken4x.sh echo "export CHICKEN_DOC_PAGER=cat" >> $PREFIX/setup-chicken4x.sh echo "setenv PATH $PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.csh echo "setenv LD_LIBRARY_PATH $LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.csh echo "setenv CHICKEN_DOC_PAGER cat" >> $PREFIX/setup-chicken4x.csh @@ -153,22 +91,25 @@ make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi cd $BUILDHOME -#wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz -#mv 1.0.0 1.0.0.tar.gz -# if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then -# wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz -# mv 1.0.0 1.0.0.tar.gz -# tar xf 1.0.0.tar.gz -# cd nanomsg-1.0.0 -# ./configure --prefix=$PREFIX -# make -# make install -# fi -# cd $BUILDHOME +#if [[ ! -e 1.0.0.tar.gz ]];then +# wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz +# mv 1.0.0 1.0.0.tar.gz +#fi +if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then + wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz + mv 1.0.0 1.0.0.tar.gz + tar xf 1.0.0.tar.gz + cd nanomsg-1.0.0 + ./configure --prefix=$PREFIX + make + make install + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX nanomsg +fi +cd $BUILDHOME export SQLITE3_VERSION=3090200 if ! [[ -e $PREFIX/bin/sqlite3 ]]; then echo Install sqlite3 sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz @@ -182,15 +123,28 @@ tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) fi fi fi - +if ! [[ -e $PREFIX/bin/pg_config ]]; then + echo Install Postgresql + pgsql_tgz=postgresql-9.6.4.tar.gz + if ! [[ -e tgz/$pgsql_tgz ]]; then + wget -c https://ftp.postgresql.org/pub/source/v9.6.4/$pgsql_tgz + mv $pgsql_tgz tgz + fi + if ! [[ -e $PREFIX/bin/pg_config ]]; then + if [[ -e tgz/$pgsql_tgz ]]; then + tar xfz tgz/$pgsql_tgz + (cd postgresql-9.6.4; ./configure --prefix=$PREFIX --with-openssl; make; make install) + fi + fi +fi cd $BUILDHOME -for egg in "sqlite3" sql-de-lite # nanomsg +for egg in "sqlite3" sql-de-lite nanomsg do echo "Installing $egg" CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg if [ $? -ne 0 ]; then @@ -202,11 +156,11 @@ # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do # $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \ coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \ - tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client \ + tcp rpc csv-xml fmt json md5 awful http-client:0.7.1 spiffy uri-common intarweb http-client \ spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \ sxml-modifications logpro z3 call-with-environment-variables \ pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42 \ alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \ cock condition-utils debug define-record-and-printer easyffi easyffi-base \ @@ -213,11 +167,11 @@ expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \ locale locale-builtin locale-categories locale-components locale-current locale-posix \ locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \ sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \ srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \ - udp uuid uuid-lib zlib + udp uuid uuid-lib zlib postgresql do echo "Installing $egg" $CHICKEN_INSTALL $PROX -keep-installed $egg #$CHICKEN_INSTALL $PROX $egg @@ -224,39 +178,21 @@ if [ $? -ne 0 ]; then echo "$egg failed to install" exit 1 fi done - if [[ -e `which mysql_config` ]]; then - $CHICKEN_INSTALL $PROX -keep-installed mysql-client + $CHICKEN_INSTALL $PROX mysql-client fi cd $BUILDHOME cd `$PREFIX/bin/csi -p '(chicken-home)'` curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx cd $BUILDHOME - - # $CHICKEN_INSTALL $PROX sqlite3 cd $BUILDHOME -# # IUP versions -# if [[ x$USEOLDIUP == "x" ]];then -# CDVER=5.10 -# IUPVER=3.17 -# IMVER=3.11 -# else -# CDVER=5.10 -# IUPVER=3.17 -# IMVER=3.11 -# fi -# if [[ x$KTYPE == "x24g3" ]];then -# CDVER=5.4.1 -# IUPVER=3.5 -# IMVER=3.6.3 -# fi if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ @@ -319,10 +255,12 @@ $PREFIX/bin/chicken-install cd ../dbi $PREFIX/bin/chicken-install cd ../margs $PREFIX/bin/chicken-install + cd ../pkts + $PREFIX/bin/chicken-install fi cd $BUILDHOME if ! [[ -e $PREFIX/bin/stmlrun ]] ; then #fossil clone http://www.kiatoa.com/fossils/stml stml.fossil @@ -346,22 +284,26 @@ if [[ $IUPVER == "3.5" ]]; then IUPEGGVER='iup:1.2.1' fi #CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup -CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web $IUPEGGVER +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot $IUPEGGVER # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup # iup:1.0.2 CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw cd $BUILDHOME # install ducttape -cd ../ducttape -$CHICKEN_INSTALL +if [[ -e ../ducttape ]];then + cd ../ducttape + $CHICKEN_INSTALL +else + echo "ducttape egg not found at ../ducttape. You will need to cd into the ducttape directory in the megatest distribution and run \"chicken-install\"" +fi cd $BUILDHOME echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh echo file can be found in the current directory which should work for setting up to run chicken4x ADDED utils/mtrept.sh Index: utils/mtrept.sh ================================================================== --- /dev/null +++ utils/mtrept.sh @@ -0,0 +1,58 @@ +#!/bin/bash +# +# Rollup counts of calls to Megatest from a logging dat file +# +# Usage: mtrept.sh file [host] + +if [[ "$2"x != "x" ]];then + host_name_grep="grep $2 | " +else + host_name_grep="" +fi +if [[ "$1"x == "x" ]];then + datfile=/p/fdk/gwa/$USER/.logger/all.dat +else + datfile=$1 +fi +datcopy=/tmp/$USER/all.$PID.dat + +if [[ -e $datfile ]];then + cp $datfile $datcopy + list_runs=$(grep list-runs $datcopy |$host_name_grep wc -l) + show_config=$(grep show-config $datcopy |$host_name_grep wc -l) + list_targets=$(grep list-targets $datcopy |$host_name_grep wc -l) + mt_run=$(grep ' -run ' $datcopy |$host_name_grep wc -l) + execute=$(grep ' -execute' $datcopy|$host_name_grep wc -l) + server=$(grep ' -server' $datcopy|$host_name_grep wc -l) + sync_to=$(grep ' -sync-to' $datcopy|$host_name_grep wc -l) + step=$(grep ' -step' $datcopy|$host_name_grep wc -l) + state_status=$(grep ' -set-state-status' $datcopy|$host_name_grep wc -l) + test_status=$(grep ' -test-status' $datcopy|$host_name_grep wc -l) + other=$(egrep -v ' -(list-runs|show-config|list-targets|run|execute|server|sync-to|step|set-state-status|test-status)' $datcopy |$host_name_grep wc -l) + start_time=$(head -1 $datcopy|awk '{print $1}') + end_time=$(tail -1 $datcopy | awk '{print $1}') + minutes=$(echo "($end_time-$start_time)/60.0" | bc) + hours=$(echo "($minutes/60)"|bc) + total_calls=$(cat $datcopy |$host_name_grep wc -l) + + if [[ $hours -gt 2 ]];then + echo "Over $hours hour period we have;" + else + echo "Over $minutes minutes we have;" + fi + echo " list-runs: $list_runs" + echo " show-config: $show_config" + echo " list-targets: $list_targets" + echo " execute: $execute" + echo " run: $mt_run" + echo " server: $server" + echo " step: $step" + echo " test-status: $test_status" + echo " sync-to: $sync_to" + echo " state-status: $state_status" + echo " other: $other" + echo " total: $total_calls" +else + echo "Could not find input file $datfile" +fi + ADDED utils/run2mock.scm Index: utils/run2mock.scm ================================================================== --- /dev/null +++ utils/run2mock.scm @@ -0,0 +1,169 @@ +#!/p/foundry/env/pkgs/chicken/4.10.1_v1.63/bin/csi -s +; -*- Mode: Scheme; -*- + + +(use ducttape-lib) +(use posix-extras pathname-expand regex matchable) +(use ini-file) +;; plugs a hole in posix-extras in latter chicken versions +(define ##sys#expand-home-path pathname-expand) +(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + +;; resolve fullpath to this script +(define (get-this-script-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) + +(define *this-script-fullpath* (get-this-script-fullpath)) +(define *this-script-dir* (pathname-directory *this-script-fullpath*)) +(define *this-script-name* (pathname-strip-directory *this-script-fullpath*)) + +(define (false-on-exception thunk) + (handle-exceptions exn #f (thunk) )) + +(define (safe-file-exists? path-string) + (false-on-exception (lambda () (file-exists? path-string)))) + + +(define (crude-config-transformer infile outfile keep-sections-list append-text #!key (filter-patt #f)) + (let* ((inlines (with-input-from-file infile read-lines)) + (keep-lines (let loop ((lines-left inlines) (lines-out '()) (current-section #f) (section-lines-accumulator '())) + (let* ((this-line (if (not (null? lines-left)) + (car lines-left) + "")) + (section-match (string-match "^\\s*\\[([^\\]]+)\\].*" this-line))) + (cond + ((null? lines-left) + (if (member current-section keep-sections-list) + (append lines-out (reverse section-lines-accumulator)) + lines-out)) + (section-match + (let* ((next-lines-left (cdr lines-left)) + (next-lines-out (if (member current-section keep-sections-list) + (append lines-out (reverse section-lines-accumulator)) + lines-out)) + (next-current-section (cadr section-match)) + (next-section-lines-accumulator (list this-line))) + (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator))) + (else + (let* ((next-lines-left (cdr lines-left)) + (next-lines-out lines-out) + (next-current-section current-section) + (next-section-lines-accumulator + (cond + ((and filter-patt (string-match (conc "^.*"filter-patt".*$") this-line)) + section-lines-accumulator) + (else (cons this-line section-lines-accumulator))))) + (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator)))))))) + (with-output-to-file outfile (lambda () + (print (string-join keep-lines "\n")) + (print) + (print append-text) + (print))))) + + +(define (testconfig-transformer infile outfile) + (crude-config-transformer + infile + outfile + '("meta" "items" "requirements" "test_meta") + + (conc " + +[ezsteps] +alwayspass /bin/true + +"))) + + + + + +(let* ((mtexe "/p/foundry/env/pkgs/megatest/1.64/31/bin/megatest") + (faux-mtra "/p/fdk/gwa/bjbarcla/issues/mtdev/ch/cap/faux") + (src-mtra "/nfs/pdx/disks/icf_fdk_asic_gwa002/asicfdkqa/fossil/megatestqa/afdkqa") + (target "p1275/5/ADF_r0.7_s/9p27t_tp0") + (run "ww38.4") + (src-mtdb (conc src-mtra "/megatest.db")) + (extra-src-testdirs '("/p/fdk/gwa/asicfdkqa/fossil/ext/afdkqa_ext/trunk/tests")) + (mtconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-config -target "target) read)) + (runconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-runconfig -dumpmode sexp -target "target) read)) + (testdir-alist (alist-ref "tests-paths" mtconf equal?)) + (testdirs (filter safe-file-exists? + (append extra-src-testdirs + (list (conc src-mtra "/tests")) + (if (and testdir-alist (not (null? testdir-alist))) + (map cadr testdir-alist) + '())))) + (tconfigfiles + (apply append (map (lambda (src-testdir) + (with-input-from-pipe (conc "ls -1 "src-testdir"/*/testconfig") read-lines)) + testdirs))) + (tconf-alist (filter identity + (map (lambda (tcfile) + (let* ((m (string-match "^.*/([^/]+)/testconfig$" tcfile))) + (if (not (null? m)) + (cons (cadr m) tcfile) + #f))) + tconfigfiles)))) + +; (pp mtconf) +; (pp (list 'FOO testdir-alist)) (exit 1) + ;; make megatest area + (when (not (file-exists? src-mtdb)) + (ierr "Source does not exist. Aborting. [src-mtdb]") + (exit 1)) + + (when (file-exists? faux-mtra) + (system (conc "cd "faux-mtra" && rm -rf $(/p/foundry/env/bin/mttmpdir)")) + (system (conc "rm -rf "faux-mtra))) + + (system (conc "mkdir -p "faux-mtra)) + (system (conc "mkdir -p "faux-mtra"/links")) + (system (conc "mkdir -p "faux-mtra"/disk0")) + + (system (conc "cd "src-mtra" && "mtexe" -show-config -target "target" -dumpmode ini > "faux-mtra"/megatest.config.in")) + (crude-config-transformer + (conc faux-mtra"/megatest.config.in") + (conc faux-mtra"/megatest.config") + '("fields" "server" "env-override" "dashboard" "validvalues") + (conc "[setup] +linktree "faux-mtra"/links +max_concurrent_jobs 1000 +launch-delay 5 +use-wal 1 + +" ;; emacs has trouble if a string has [ at the beginning of line, so breaking it up. +"[disks] +disk0 "faux-mtra"/disk0") + filter-patt: "MT_LINKTREE" + ) + + + (system (conc "cd "src-mtra" && "mtexe" -show-runconfig -target "target" -dumpmode ini > "faux-mtra"/runconfigs.config")) + + + (system (conc "mkdir -p "faux-mtra"/tests")) + + (for-each (lambda (tpair) + (pp tpair) + (let* ((testname (car tpair)) + (src-tconfigfile (cdr tpair)) + (destdir (conc faux-mtra"/tests/"testname))) + (do-or-die (conc "mkdir -p "destdir)) + (do-or-die (conc "cp "src-tconfigfile" "destdir"/testconfig.in")) + (testconfig-transformer + (conc destdir"/testconfig.in") + (conc destdir"/testconfig")) + (print "processed test "testname))) + tconf-alist) + + + ) ADDED utils/watch-close-wait.sh Index: utils/watch-close-wait.sh ================================================================== --- /dev/null +++ utils/watch-close-wait.sh @@ -0,0 +1,8 @@ +psline=$(ps -F -u $USER | grep "mtest" |grep " -run " | egrep " -(target|reqtarg) "| head -1) +id=$(echo $psline|awk '{print $2}') +echo "Watching process for command line: $psline" +echo " with PID=$id" +while true;do + echo "CLOSE_WAIT: $(lsof -n | grep CLOSE_WAIT | grep $id | wc -l) ALL OPEN: $(lsof -n |grep $id|wc -l) ALL CLOSE_WAIT: $(netstat -ap 2> /dev/null| grep -i close_wait| wc -l)" + sleep 1 +done ADDED utils/whodunit.scm Index: utils/whodunit.scm ================================================================== --- /dev/null +++ utils/whodunit.scm @@ -0,0 +1,48 @@ +(use posix srfi-69) + +(define *numsamples* (or (and (> (length (argv)) 1) + (string->number (cadr (argv)))) + 3)) + +(define (topdata) + (with-input-from-pipe + (conc "top -b -n " *numsamples* " -d 0.1") + read-lines)) + +(define (cleanup-data topdat)list + (let loop ((hed (car topdat)) + (tal (cdr topdat)) + (res '())) + (let* ((line-list (string-split hed)) + (nums (map (lambda (indat)(or (string->number indat) indat)) line-list)) + (not-data (or (null? nums) + (not (number? (car nums))))) + (new-res (if not-data res (cons nums res)))) + (if (null? tal) + new-res + (loop (car tal)(cdr tal) new-res))))) + +(print "Getting " *numsamples* " samples of cpu usage data.") +(define data (cleanup-data (topdata))) +(define pidhash (make-hash-table)) +(define userhash (make-hash-table)) + +;; sum up and normalize the +(for-each + (lambda (indat) + (let ((pid (car indat)) + (usr (cadr indat)) + (cpu (list-ref indat 8))) + (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0))))) + data) + +(for-each + (lambda (usr) + (print usr + (if (< (string-length usr) 8) "\t\t" "\t") + (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*))))) + (sort (hash-table-keys userhash) + (lambda (a b) + (> (hash-table-ref userhash a) + (hash-table-ref userhash b))))) +