Index: common-inc.scm ================================================================== --- common-inc.scm +++ common-inc.scm @@ -25,161 +25,28 @@ ;; (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 (or (substring-index "!" key) (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 \":\" or starting with \"!\"") - (if (and (string? val) - (string? key)) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) - (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 - (taskdb #f) - (cmutex (make-mutex))) -;; (define *contexts* (make-hash-table)) -;; (define *context-mutex* (make-mutex)) - -;; ;; safe method for accessing a context given a toppath -;; ;; -;; (define (common:with-cxt toppath proc) -;; (mutex-lock! *context-mutex*) -;; (let ((cxt (hash-table-ref/default *contexts* toppath #f))) -;; (if (not cxt) -;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) -;; (let ((cxt-mutex (cxt-mutex cxt))) -;; (mutex-unlock! *context-mutex*) -;; (mutex-lock! cxt-mutex) -;; (let ((res (proc cxt))) -;; (mutex-unlock! cxt-mutex) -;; res)))) - -;; A hash table that can be accessed by #{scheme ...} calls in -;; config files. Allows communicating between confgs -;; -(define *user-hash-data* (make-hash-table)) - -(define *db-keys* #f) - -(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here -(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config -(define *runconfigdat* #f) ;; run configs data -(define *configdat* #f) ;; megatest.config data -(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done -(define *toppath* #f) -(define *already-seen-runconfig-info* #f) - -(define *test-meta-updated* (make-hash-table)) -(define *globalexitstatus* 0) ;; attempt to work around possible thread issues -(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 *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 > -(define *db-stats-mutex* (make-mutex)) -;; db access -(define *db-last-access* (current-seconds)) ;; last db access, used in server -(define *db-write-access* #t) -;; db sync -(define *db-last-sync* 0) ;; last time the sync to megatest.db happened -(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another -(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* -;; task db -(define *task-db* #f) ;; (vector db path-to-db) -(define *db-access-allowed* #t) ;; flag to allow access -(define *db-access-mutex* (make-mutex)) -(define *db-transaction-mutex* (make-mutex)) -(define *db-cache-path* #f) -(define *db-with-db-mutex* (make-mutex)) -(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) -;; no sync db -(define *no-sync-db* #f) - -;; SERVER -(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-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)) -(define *home-host* #f) -;; (define *total-non-write-delay* 0) -(define *heartbeat-mutex* (make-mutex)) -(define *api-process-request-count* 0) -(define *max-api-process-requests* 0) -(define *server-overloaded* #f) - -;; client -(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex - -;; RPC transport -(define *rpc:listener* #f) - -;; KEY info -(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN -(define *keys* (make-hash-table)) ;; cache the keys here -(define *keyvals* (make-hash-table)) -(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here -(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here -(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id -(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db - -(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget -(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set -(define *homehost-mutex* (make-mutex)) - -;; Miscellaneous -(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers + + + + + + + + + + + + + + + + + + (use posix-extras pathname-expand files) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) (let-values (( (chicken-release-number chicken-major-version) @@ -708,146 +575,16 @@ (handle-exceptions exn #f ;; I don't really care why this failed (at least for now) (delete-file* fname))) -;;====================================================================== -;; 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") - (1 "STUCK") - (2 "KILLREQ") - (3 "KILLED") - (4 "NOT_STARTED") - (5 "COMPLETED") - (6 "LAUNCHED") - (7 "REMOTEHOSTSTART") - (8 "RUNNING") - )) - -(define *common:dont-roll-up-states* - '("DELETED" - "REMOVING" - "CLEANING" - "ARCHIVE_REMOVING" - )) - -;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls -;; note these statuses are sorted from better to worse. -;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items -(define *common:std-statuses* - '(;; (0 "DELETED") - (1 "n/a") - (2 "PASS") - (3 "SKIP") - (4 "WARN") - (5 "WAIVED") - (6 "CHECK") - (7 "STUCK/DEAD") - (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" )) - -(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")) - -(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run - '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) - -(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead - '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) - -;; group tests into buckets corresponding to rollup -;;; Running, completed-pass, completed-non-pass + worst status, not started. -;; filter out -;(define (common:categorize-items-for-rollup in-tests) -; ( - -(define (common:special-sort items order comp) - (let ((items-order (map reverse order)) - (acomp (or comp >))) - (sort items - (lambda (a b) - (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) - (b-num (cadr (or (assoc b items-order) '(0 0))))) - (acomp a-num b-num)))))) - -;; ;; given a toplevel with currstate, currstatus apply state and status -;; ;; => (newstate . newstatus) -;; (define (common:apply-state-status currstate currstatus state status) -;; (let* ((cstate (string->symbol (string-downcase currstate))) -;; (cstatus (string->symbol (string-downcase currstatus))) -;; (sstate (string->symbol (string-downcase state))) -;; (sstatus (string->symbol (string-downcase status))) -;; (nstate #f) -;; (nstatus #f)) -;; (set! nstate -;; (case cstate -;; ((completed not_started killed killreq stuck archived) -;; (case sstate ;; completed -> sstate -;; ((completed killed killreq stuck archived) completed) -;; ((running remotehoststart launched) running) -;; (else unknown-error-1))) -;; ((running remotehoststart launched) -;; (case sstate -;; ((completed killed killreq stuck archived) #f) ;; need to look at all items -;; ((running remotehoststart launched) running) -;; (else unknown-error-2))) -;; (else unknown-error-3))) -;; (set! nstatus -;; (case sstatus -;; ((pass) -;; (case nstate -;; ((pass n/a deleted) pass) -;; ((warn) warn) -;; ((fail) fail) -;; ((check) check) -;; ((waived) waived) -;; ((skip) skip) -;; ((stuck/dead) stuck) -;; ((abort) abort) -;; (else unknown-error-4))) -;; ((warn) -;; (case nstate -;; ((pass warn n/a skip deleted) warn) -;; ((fail) fail) -;; ((check) check) -;; ((waived) waived) -;; ((stuck/dead) stuck) -;; (else unknown-error-5))) -;; ((fail) -;; (case nstate -;; ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) -;; ((abort) abort) -;; (else unknown-error-6))) -;; (else unknown-error-7))) -;; (cons -;; (if nstate (symbol->string nstate) nstate) -;; (if nstatus (symbol->string nstatus) nstatus)))) - ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== -(define *verbosity* 1) -(define *logging* #f) +;; (define *verbosity* 1) +;; (define *logging* #f) (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) @@ -900,21 +637,10 @@ ;; (let ((ohh (common:on-homehost?)) ;; (srv (args:get-arg "-server"))) ;; (and ohh srv))) ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) - - -(define *wdnum* 0) -(define *wdnum*mutex (make-mutex)) - - -(define (common:human-time) - (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) - - -(define *time-zero* (current-seconds)) ;; for the watchdog (define *watchdog* (make-thread (lambda () (handle-exceptions exn (begin @@ -1051,125 +777,16 @@ (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! -;;====================================================================== -;; M I S C U T I L S -;;====================================================================== - -;; convert stuff to a number if possible -(define (any->number val) - (cond - ((number? val) val) - ((string? val) (string->number val)) - ((symbol? val) (any->number (symbol->string val))) - (else #f))) - -(define (any->number-if-possible val) - (let ((num (any->number val))) - (if num num val))) - -(define (patt-list-match item patts) - (debug:print-info 8 *default-log-port* "patt-list-match item=" item " patts=" patts) - (if (and item patts) ;; here we are filtering for matches with item patterns - (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % - (for-each - (lambda (patt) - (let ((modpatt (string-substitute "%" ".*" patt #t))) - (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt) - (if (string-match (regexp modpatt) item) - (set! res #t)))) - (string-split patts ",")) - res) - #t)) - ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) -;; return first command that exists, else #f -;; -(define (common:which cmds) - (if (null? cmds) - #f - (let loop ((hed (car cmds)) - (tal (cdr cmds))) - (let ((res (with-input-from-pipe (conc "which " hed) read-line))) - (if (and (string? res) - (common:file-exists? res)) - res - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - -(define (common:get-install-area) - (let ((exe-path (car (argv)))) - (if (common:file-exists? exe-path) - (handle-exceptions - exn - #f - (pathname-directory - (pathname-directory - (pathname-directory exe-path)))) - #f))) - -;; return first path that can be created or already exists and is writable -;; -(define (common:get-create-writeable-dir dirs) - (if (null? dirs) - #f - (let loop ((hed (car dirs)) - (tal (cdr dirs))) - (let ((res (or (and (directory? hed) - (file-write-access? hed) - hed) - (handle-exceptions - 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) - #f - (loop (car tal)(cdr tal)))))))) - -;; return the youngest timestamp . filename -;; -(define (common:get-youngest glob-list) - (let ((all-files (apply append - (map (lambda (patt) - (handle-exceptions - exn - '() - (glob patt))) - glob-list)))) - (fold (lambda (fname res) - (let ((last-mod (car res)) - (curmod (handle-exceptions - exn - 0 - (file-modification-time fname)))) - (if (> curmod last-mod) - (list curmod fname) - res))) - '(0 "n/a") - all-files))) - -;; use bash to expand a glob. Does NOT handle paths with spaces! -;; -(define (common:bash-glob instr) - (string-split - (with-input-from-pipe - (conc "/bin/bash -c \"echo " instr "\"") - read-line))) - ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== @@ -1229,46 +846,10 @@ (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) args-testpatt)))) -(define (common:false-on-exception thunk #!key (message #f)) - (handle-exceptions exn - (begin - (if message - (debug:print-info 0 *default-log-port* message)) - #f) (thunk) )) - -(define (common:file-exists? path-string #!key (silent #f)) - ;; this avoids stack dumps in the case where - - ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... - (common:false-on-exception (lambda () (file-exists? path-string)) - message: (if (not silent) - (conc "Unable to access path: " path-string) - #f) - )) - -(define (common:directory-exists? path-string) - ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... - (common:false-on-exception (lambda () (directory-exists? path-string)) - message: (conc "Unable to access path: " path-string) - )) - -;; does the directory exist and do we have write access? -;; -;; returns the directory or #f -;; -(define (common:directory-writable? path-string) - (handle-exceptions - exn - #f - (if (and (directory-exists? path-string) - (file-write-access? path-string)) - path-string - #f))) - (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") (if *toppath* @@ -1417,89 +998,10 @@ (begin (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") #t) #f))) -;;====================================================================== -;; M I S C L I S T S -;;====================================================================== - -;; items in lista are matched value and position in listb -;; return the remaining items in listb or #f -;; -(define (common:list-is-sublist lista listb) - (if (null? lista) - listb ;; all items in listb are "remaining" - (if (> (length lista)(length listb)) - #f - (let loop ((heda (car lista)) - (tala (cdr lista)) - (hedb (car listb)) - (talb (cdr listb))) - (if (equal? heda hedb) - (if (null? tala) ;; we are done - talb - (loop (car tala) - (cdr tala) - (car talb) - - (cdr talb))) - #f))))) - -;; Needed for long lists to be sorted where (apply max ... ) dies -;; -(define (common:max inlst) - (let loop ((max-val (car inlst)) - (hed (car inlst)) - (tal (cdr inlst))) - (if (not (null? tal)) - (loop (max hed max-val) - (car tal) - (cdr tal)) - (max hed max-val)))) - -;; get min or max, use > for max and < for min, this works around the limits on apply -;; -(define (common:min-max comp lst) - (if (null? lst) - #f ;; better than an exception for my needs - (fold (lambda (a b) - (if (comp a b) a b)) - (car lst) - lst))) - -;; get min or max, use > for max and < for min, this works around the limits on apply -;; -(define (common:sum lst) - (if (null? lst) - 0 - (fold (lambda (a b) - (+ a b)) - (car lst) - lst))) - -;; path list to hash-table tree -;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) -;; -(define (common:list->htree lst) - (let ((resh (make-hash-table))) - (for-each - (lambda (inlst) - (let loop ((ht resh) - (hed (car inlst)) - (tal (cdr inlst))) - (if (hash-table-ref/default ht hed #f) - (if (not (null? tal)) - (loop (hash-table-ref ht hed) - (car tal) - (cdr tal))) - (begin - (hash-table-set! ht hed (make-hash-table)) - (loop ht hed tal))))) - lst) - resh)) - ;; hash-table tree to html list tree ;; ;; tipfunc takes two parameters: y the tip value and path the path to that point ;; (define (common:htree->html ht path tipfunc) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -135,10 +135,561 @@ ;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) ;; (exec-fn 'db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) )))) ;; ) + + +;;====================================================================== +;; 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") + (1 "STUCK") + (2 "KILLREQ") + (3 "KILLED") + (4 "NOT_STARTED") + (5 "COMPLETED") + (6 "LAUNCHED") + (7 "REMOTEHOSTSTART") + (8 "RUNNING") + )) + +(define *common:dont-roll-up-states* + '("DELETED" + "REMOVING" + "CLEANING" + "ARCHIVE_REMOVING" + )) + +;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls +;; note these statuses are sorted from better to worse. +;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items +(define *common:std-statuses* + '(;; (0 "DELETED") + (1 "n/a") + (2 "PASS") + (3 "SKIP") + (4 "WARN") + (5 "WAIVED") + (6 "CHECK") + (7 "STUCK/DEAD") + (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" )) + +(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")) + +(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run + '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) + +(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead + '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) + +;; group tests into buckets corresponding to rollup +;;; Running, completed-pass, completed-non-pass + worst status, not started. +;; filter out +;(define (common:categorize-items-for-rollup in-tests) +; ( + +(define (common:special-sort items order comp) + (let ((items-order (map reverse order)) + (acomp (or comp >))) + (sort items + (lambda (a b) + (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) + (b-num (cadr (or (assoc b items-order) '(0 0))))) + (acomp a-num b-num)))))) + +;; ;; given a toplevel with currstate, currstatus apply state and status +;; ;; => (newstate . newstatus) +;; (define (common:apply-state-status currstate currstatus state status) +;; (let* ((cstate (string->symbol (string-downcase currstate))) +;; (cstatus (string->symbol (string-downcase currstatus))) +;; (sstate (string->symbol (string-downcase state))) +;; (sstatus (string->symbol (string-downcase status))) +;; (nstate #f) +;; (nstatus #f)) +;; (set! nstate +;; (case cstate +;; ((completed not_started killed killreq stuck archived) +;; (case sstate ;; completed -> sstate +;; ((completed killed killreq stuck archived) completed) +;; ((running remotehoststart launched) running) +;; (else unknown-error-1))) +;; ((running remotehoststart launched) +;; (case sstate +;; ((completed killed killreq stuck archived) #f) ;; need to look at all items +;; ((running remotehoststart launched) running) +;; (else unknown-error-2))) +;; (else unknown-error-3))) +;; (set! nstatus +;; (case sstatus +;; ((pass) +;; (case nstate +;; ((pass n/a deleted) pass) +;; ((warn) warn) +;; ((fail) fail) +;; ((check) check) +;; ((waived) waived) +;; ((skip) skip) +;; ((stuck/dead) stuck) +;; ((abort) abort) +;; (else unknown-error-4))) +;; ((warn) +;; (case nstate +;; ((pass warn n/a skip deleted) warn) +;; ((fail) fail) +;; ((check) check) +;; ((waived) waived) +;; ((stuck/dead) stuck) +;; (else unknown-error-5))) +;; ((fail) +;; (case nstate +;; ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) +;; ((abort) abort) +;; (else unknown-error-6))) +;; (else unknown-error-7))) +;; (cons +;; (if nstate (symbol->string nstate) nstate) +;; (if nstatus (symbol->string nstatus) nstatus)))) + + + + +;; (define *wdnum* 0) +;; (define *wdnum*mutex (make-mutex)) + + +(define (common:human-time) + (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) + + +(define *time-zero* (current-seconds)) ;; for the watchdog + + +;;====================================================================== +;; M I S C U T I L S +;;====================================================================== + +;; convert stuff to a number if possible +(define (any->number val) + (cond + ((number? val) val) + ((string? val) (string->number val)) + ((symbol? val) (any->number (symbol->string val))) + (else #f))) + +(define (any->number-if-possible val) + (let ((num (any->number val))) + (if num num val))) + +(define (patt-list-match item patts) + (debug:print-info 8 *default-log-port* "patt-list-match item=" item " patts=" patts) + (if (and item patts) ;; here we are filtering for matches with item patterns + (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % + (for-each + (lambda (patt) + (let ((modpatt (string-substitute "%" ".*" patt #t))) + (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt) + (if (string-match (regexp modpatt) item) + (set! res #t)))) + (string-split patts ",")) + res) + #t)) + +;; return first command that exists, else #f +;; +(define (common:which cmds) + (if (null? cmds) + #f + (let loop ((hed (car cmds)) + (tal (cdr cmds))) + (let ((res (with-input-from-pipe (conc "which " hed) read-line))) + (if (and (string? res) + (common:file-exists? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + +(define (common:get-install-area) + (let ((exe-path (car (argv)))) + (if (common:file-exists? exe-path) + (handle-exceptions + exn + #f + (pathname-directory + (pathname-directory + (pathname-directory exe-path)))) + #f))) + +;; return first path that can be created or already exists and is writable +;; +(define (common:get-create-writeable-dir dirs) + (if (null? dirs) + #f + (let loop ((hed (car dirs)) + (tal (cdr dirs))) + (let ((res (or (and (directory? hed) + (file-write-access? hed) + hed) + (handle-exceptions + 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) + #f + (loop (car tal)(cdr tal)))))))) + +;; return the youngest timestamp . filename +;; +(define (common:get-youngest glob-list) + (let ((all-files (apply append + (map (lambda (patt) + (handle-exceptions + exn + '() + (glob patt))) + glob-list)))) + (fold (lambda (fname res) + (let ((last-mod (car res)) + (curmod (handle-exceptions + exn + 0 + (file-modification-time fname)))) + (if (> curmod last-mod) + (list curmod fname) + res))) + '(0 "n/a") + all-files))) + +;; use bash to expand a glob. Does NOT handle paths with spaces! +;; +(define (common:bash-glob instr) + (string-split + (with-input-from-pipe + (conc "/bin/bash -c \"echo " instr "\"") + read-line))) + +(define (common:file-exists? path-string #!key (silent #f)) + ;; this avoids stack dumps in the case where + + ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... + (common:false-on-exception (lambda () (file-exists? path-string)) + message: (if (not silent) + (conc "Unable to access path: " path-string) + #f) + )) + + + +(define (common:false-on-exception thunk #!key (message #f)) + (handle-exceptions exn + (begin + (if message + (debug:print-info 0 *default-log-port* message)) + #f) (thunk) )) + +(define (common:directory-exists? path-string) + ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... + (common:false-on-exception (lambda () (directory-exists? path-string)) + message: (conc "Unable to access path: " path-string) + )) + +;; does the directory exist and do we have write access? +;; +;; returns the directory or #f +;; +(define (common:directory-writable? path-string) + (handle-exceptions + exn + #f + (if (and (directory-exists? path-string) + (file-write-access? path-string)) + path-string + #f))) + +;;====================================================================== +;; M I S C L I S T S +;;====================================================================== + +;; items in lista are matched value and position in listb +;; return the remaining items in listb or #f +;; +(define (common:list-is-sublist lista listb) + (if (null? lista) + listb ;; all items in listb are "remaining" + (if (> (length lista)(length listb)) + #f + (let loop ((heda (car lista)) + (tala (cdr lista)) + (hedb (car listb)) + (talb (cdr listb))) + (if (equal? heda hedb) + (if (null? tala) ;; we are done + talb + (loop (car tala) + (cdr tala) + (car talb) + + (cdr talb))) + #f))))) + +;; Needed for long lists to be sorted where (apply max ... ) dies +;; +(define (common:max inlst) + (let loop ((max-val (car inlst)) + (hed (car inlst)) + (tal (cdr inlst))) + (if (not (null? tal)) + (loop (max hed max-val) + (car tal) + (cdr tal)) + (max hed max-val)))) + +;; get min or max, use > for max and < for min, this works around the limits on apply +;; +(define (common:min-max comp lst) + (if (null? lst) + #f ;; better than an exception for my needs + (fold (lambda (a b) + (if (comp a b) a b)) + (car lst) + lst))) + +;; get min or max, use > for max and < for min, this works around the limits on apply +;; +(define (common:sum lst) + (if (null? lst) + 0 + (fold (lambda (a b) + (+ a b)) + (car lst) + lst))) + +;; path list to hash-table tree +;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) +;; +(define (common:list->htree lst) + (let ((resh (make-hash-table))) + (for-each + (lambda (inlst) + (let loop ((ht resh) + (hed (car inlst)) + (tal (cdr inlst))) + (if (hash-table-ref/default ht hed #f) + (if (not (null? tal)) + (loop (hash-table-ref ht hed) + (car tal) + (cdr tal))) + (begin + (hash-table-set! ht hed (make-hash-table)) + (loop ht hed tal))))) + lst) + resh)) + + + + + + + + + + + + + + + + + + +;; 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 (or (substring-index "!" key) (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 \":\" or starting with \"!\"") + (if (and (string? val) + (string? key)) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) + (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 + (taskdb #f) + (cmutex (make-mutex))) +;; (define *contexts* (make-hash-table)) +;; (define *context-mutex* (make-mutex)) + +;; ;; safe method for accessing a context given a toppath +;; ;; +;; (define (common:with-cxt toppath proc) +;; (mutex-lock! *context-mutex*) +;; (let ((cxt (hash-table-ref/default *contexts* toppath #f))) +;; (if (not cxt) +;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) +;; (let ((cxt-mutex (cxt-mutex cxt))) +;; (mutex-unlock! *context-mutex*) +;; (mutex-lock! cxt-mutex) +;; (let ((res (proc cxt))) +;; (mutex-unlock! cxt-mutex) +;; res)))) + +;; A hash table that can be accessed by #{scheme ...} calls in +;; config files. Allows communicating between confgs +;; +(define *user-hash-data* (make-hash-table)) + +(define *db-keys* #f) + +(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here +(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config +(define *runconfigdat* #f) ;; run configs data +(define *configdat* #f) ;; megatest.config data +(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done +(define *toppath* #f) +(define *already-seen-runconfig-info* #f) + +(define *test-meta-updated* (make-hash-table)) +(define *globalexitstatus* 0) ;; attempt to work around possible thread issues +(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 *default-area-tag* "local") + +;; DATABASE +(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. +;; db access +(define *db-last-access* (current-seconds)) ;; last db access, used in server +(define *db-write-access* #t) +;; db sync +(define *db-last-sync* 0) ;; last time the sync to megatest.db happened +(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another +(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* +;; task db +(define *task-db* #f) ;; (vector db path-to-db) +(define *db-access-allowed* #t) ;; flag to allow access +(define *db-access-mutex* (make-mutex)) +(define *db-transaction-mutex* (make-mutex)) +(define *db-cache-path* #f) +(define *db-with-db-mutex* (make-mutex)) +(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) +;; no sync db +(define *no-sync-db* #f) + +;; SERVER +(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-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)) +(define *home-host* #f) +;; (define *total-non-write-delay* 0) +(define *heartbeat-mutex* (make-mutex)) +(define *api-process-request-count* 0) +(define *max-api-process-requests* 0) +(define *server-overloaded* #f) + +;; client +(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex + +;; RPC transport +(define *rpc:listener* #f) + +;; KEY info +(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN +(define *keys* (make-hash-table)) ;; cache the keys here +(define *keyvals* (make-hash-table)) +(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here +(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here +(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id +(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db + +(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget +(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set +(define *homehost-mutex* (make-mutex)) + +;; Miscellaneous +(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers + + + + + + + + + + + + + + ;; (define (common:low-noise-print alldat waitval . keys) ;; (let* ((key (string-intersperse (map conc keys) "-" )) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -25,11 +25,11 @@ (use canvas-draw) (import canvas-draw-iup) (use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records - sparse-vectors + sparse-vectors srfi-18 (prefix mtconfigf configf:)) (import (prefix sqlite3 sqlite3:)) ;; (declare (uses common)) ;; (declare (uses margs)) @@ -74,11 +74,11 @@ (declare (uses commonmod.import)) (declare (uses megamod.import)) (declare (uses dcommonmod.import)) (configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*) -(configf:add-eval-string "(import megamod)") +(configf:add-eval-string "(import megamod)(import commonmod)") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -80,11 +80,11 @@ (include "db_records.scm") (include "run_records.scm") ;; (include "megatest-fossil-hash.scm") ;; included in megamod (define getenv get-environment-variable) -(configf:add-eval-string "(import megamod)") +(configf:add-eval-string "(import megamod)(import commonmod)") (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 Index: rmt-inc.scm ================================================================== --- rmt-inc.scm +++ rmt-inc.scm @@ -24,10 +24,16 @@ ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u +;; Globally used variables + +;; db stats +(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > +(define *db-stats-mutex* (make-mutex)) + ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup