;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit commonmod))
(declare (uses mtargs))
;; (declare (uses stml2))
(declare (uses mtconfigf))
(module commonmod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
srfi-1 files format srfi-13 matchable
srfi-69 ports
regex-case regex hostinfo srfi-4
pkts (prefix dbi dbi:)
stack
md5
message-digest
(prefix mtconfigf configf:)
;; stml2
;; (prefix margs args:)
z3 (prefix base64 base64:)
(prefix mtargs args:))
(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")
;; no need to export this
(define *verbosity-cache* (make-hash-table))
(define *verbosity* 0)
;; 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 <host port>
;; (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
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
(or (hash-table-ref/default *verbosity-cache* vstr #f)
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
(verbose 2) ;; ((args:get-arg "-v") 2)
(quiet 0) ;; ((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug:debug-mode n)
(cond
((and (number? *verbosity*) ;; number number
(number? n))
(<= n *verbosity*))
((and (list? *verbosity*) ;; list number
(number? n))
(member n *verbosity*))
((and (list? *verbosity*) ;; list list
(list? n))
(not (null? (lset-intersection! eq? *verbosity* n))))
((and (number? *verbosity*)
(list? n))
(member *verbosity* n))))
(define (debug:setup dmode verbose quiet)
(let ((debugstr (or dmode ;; (args:get-arg "-debug")
(get-environment-variable "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (or dmode ;; (args:get-arg "-debug")
(not (get-environment-variable "MT_DEBUG_MODE")))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
;; (if *logging*
;; (exec-fn 'db:log-event (apply conc params))
(apply print params)
)))) ;; )
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
;; (if *logging*
;; (exec-fn 'db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))) ;; )
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
;; (if *logging*
;; (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)
)))) ;; )
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config var)
(let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (configf:lookup config targ var)
(configf:lookup config "default" var))
(configf:lookup config "default" var))))
(define (common:args-get-state)
(or (args:get-arg "-state")(args:get-arg ":state")))
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt rconf)
(let* (;; (tagexpr (args:get-arg "-tagexpr"))
;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
(let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
(debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
patts-from-mode-patt)
(begin
(debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
#f))) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
;; tags-testpatt)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
(else
(debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
args-testpatt))))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
(if *toppath*
(conc *toppath* "/lt")
#f))))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
(null? (filter string-null? tlist))))
#f)))
(if valid
(if split
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
(if exit-if-bad (exit 1))
#f)
#f))))
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
(if (and (getenv "MT_ITEMPATH")
(not (equal? (getenv "MT_ITEMPATH") "")))
(getenv "MT_TEST_NAME")
(conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
#f))
;;======================================================================
;; 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))
(define *host-loads* (make-hash-table))
;; cache environment vars for each run here
(define *env-vars-by-run-id* (make-hash-table))
;; Testconfig and runconfig caches.
(define *testconfigs* (make-hash-table)) ;; test-name => testconfig
(define *runconfigs* (make-hash-table)) ;; target => runconfig
;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than
;; five seconds ago
(define *pre-reqs-met-cache* (make-hash-table))
;; cache of verbosity given string
;;
(define *verbosity-cache* (make-hash-table))
;; 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"))
;; put any changed environment variables back to how they were - TODO - turn this into some sort of with-
(define (common:set-vars-back all-vars)
(for-each
(lambda (vardat)
(let ((var (car vardat))
(val (cdr vardat)))
(if (not (equal? (get-environment-variable var) val))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "Failed to set " var " to " val)
(setenv var val)))))
all-vars))
;; 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/*")))))
)
)
(define *common:logpro-exit-code->status-sym-alist*
'( ( 0 . pass )
( 1 . fail )
( 2 . warn )
( 3 . check )
( 4 . waived )
( 5 . abort )
( 6 . skip )))
(define (common:logpro-exit-code->status-sym exit-code)
(or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
(define (common:worse-status-sym ss1 ss2)
(let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
(cond
((null? status-syms-remaining)
'fail)
((eq? (car status-syms-remaining) ss1)
ss1)
((eq? (car status-syms-remaining) ss2)
ss2)
(else
(loop (cdr status-syms-remaining))))))
(define (common:steps-can-proceed-given-status-sym status-sym)
(if (member status-sym '(warn waived pass))
#t
#f))
(define (status-sym->string status-sym)
(case status-sym
((pass) "PASS")
((fail) "FAIL")
((warn) "WARN")
((check) "CHECK")
((waived) "WAIVED")
((abort) "ABORT")
((skip) "SKIP")
(else "FAIL")))
(define (common:logpro-exit-code->test-status exit-code)
(status-sym->string (common:logpro-exit-code->status-sym exit-code)))
(define (common:clear-caches)
(set! *target* (make-hash-table))
(set! *keys* (make-hash-table))
(set! *keyvals* (make-hash-table))
(set! *toptest-paths* (make-hash-table))
(set! *test-paths* (make-hash-table))
(set! *test-ids* (make-hash-table))
(set! *test-info* (make-hash-table))
(set! *run-info-cache* (make-hash-table))
(set! *env-vars-by-run-id* (make-hash-table))
(set! *test-id-cache* (make-hash-table)))
;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
;; Generic path database
(define *fdb* #f)
(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
;;======================================================================
;; V E R S I O N
;;======================================================================
(define (common:get-full-version)
(conc megatest-version "-" megatest-fossil-hash))
(define (common:version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
(define (common:get-sync-lock-filepath)
(let* ((tmp-area (common:get-db-tmp-area))
(lockfile (conc tmp-area "/megatest.db.sync-lock")))
lockfile))
;;======================================================================
;; U S E F U L S T U F F
;;======================================================================
;; convert things to an alist or assoc list, #f gets converted to ""
;;
(define (common:to-alist dat)
(cond
((list? dat) (map common:to-alist dat))
((vector? dat)
(map common:to-alist (vector->list dat)))
((pair? dat)
(cons (common:to-alist (car dat))
(common:to-alist (cdr dat))))
((hash-table? dat)
(map common:to-alist (hash-table->alist dat)))
(else
(if dat
dat
""))))
(define (common:alist-ref/default key alist default)
(or (alist-ref key alist) default))
(define (common:low-noise-print waitval . keys)
(let* ((key (string-intersperse (map conc keys) "-" ))
(lasttime (hash-table-ref/default *common:denoise* key 0))
(currtime (current-seconds)))
(if (> (- currtime lasttime) waitval)
(begin
(hash-table-set! *common:denoise* key currtime)
#t)
#f)))
(define (common:get-megatest-exe)
(or (getenv "MT_MEGATEST") "megatest"))
(define (common:read-encoded-string instr)
(handle-exceptions
exn
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
#f)
(read (open-input-string (base64:base64-decode instr))))
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
;;======================================================================
;; Configf extentions
;;======================================================================
(define (get-with-default val default)
(let ((val (args:get-arg val)))
(if val val default)))
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
(getenv "MT_TESTSUITE_NAME")
(if (string? *toppath* )
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
*db-cache-path*
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")))))) ;; #t))))
(set! *db-cache-path* dbpath)
dbpath))
#f)))
;; pulled from common_records.scm
;; globals - modules that include this need these here
(define *logging* #f)
(define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!!
;; (define *toppath* #f)
(define *transport-type* 'http)
#;(define (exec-fn fn . params)
(if (hash-table-exists? *functions* fn)
(apply (hash-table-ref *functions* fn) params)
(begin
(debug:print-error 0 "exec-fn " fn " not found")
#f)))
#;(define (set-fn fn-name fn)
(hash-table-set! *functions* fn-name fn))
(include "altdb.scm")
;; Pulled from http-transport.scm
(define (make-http-transport:server-dat)(make-vector 6))
(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4))
(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5))
(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6))
(define (http-transport:server-dat-make-url vec)
(if (and (http-transport:server-dat-get-iface vec)
(http-transport:server-dat-get-port vec))
(conc "http://"
(http-transport:server-dat-get-iface vec)
":"
(http-transport:server-dat-get-port vec))
#f))
(define (http-transport:server-dat-update-last-access vec)
(if (vector? vec)
(vector-set! vec 5 (current-seconds))
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 (current-error-port) "call to http-transport:server-dat-update-last-access with non-vector!!"))))
;;======================================================================
;;
;;======================================================================
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
get-keys
get-key-vals
test-toplevel-num-items
get-test-info-by-id
get-steps-info-by-id
get-data-info-by-id
test-get-rundir-from-test-id
get-count-tests-running-for-testname
get-count-tests-running
get-count-tests-running-in-jobgroup
get-previous-test-run-record
get-matching-previous-test-run-records
test-get-logfile-info
test-get-records-for-index-file
get-testinfo-state-status
test-get-top-process-pid
test-get-paths-matching-keynames-target-new
get-prereqs-not-met
get-count-tests-running-for-run-id
get-run-info
get-run-status
get-run-state
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-runs-cnt-by-patt
get-all-run-ids
get-prev-run-ids
get-run-ids-matching-target
get-runs-by-patt
get-steps-data
get-steps-for-test
read-test-data
read-test-data*
login
tasks-get-last
testmeta-get-record
have-incompletes?
synchash-get
get-changed-record-ids
get-run-record-ids
get-not-completed-cnt))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
;; SERVERS
start-server
kill-server
;; TESTS
test-set-state-status-by-id
delete-test-records
delete-old-deleted-test-records
test-set-state-status
test-set-top-process-pid
set-state-status-and-roll-up-items
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
;; RUNS
register-run
set-tests-state-status
delete-run
lock/unlock-run
update-run-event_time
mark-incomplete
set-state-status-and-roll-up-run
;; STEPS
teststep-set-status!
delete-steps-for-test
;; TEST DATA
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
;; TESTMETA
testmeta-add-record
testmeta-update-field
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
;;======================================================================
;; ALLDATA
;;======================================================================
;;
;; attempt to consolidate a bunch of global information into one struct to toss around
(defstruct alldat
;; misc
(denoise (make-hash-table))
(areapath #f) ;; i.e. toppath
(mtconfig #f)
(log-port #f)
(areadat #f) ;; i.e. runremote
(rmt-mutex (make-mutex))
(db-sync-mutex (make-mutex))
(db-with-db-mutex (make-mutex))
(read-only-queries api:read-only-queries)
(write-queries api:write-queries)
(max-api-process-requests 0)
(api-process-request-count 0)
(db-keys #f)
(megatest-version "1.6536")
(megatest-fossil-hash #f)
;; database related
(tmppath #f) ;; tmp path for dbs
;; runremote fields
(hh-dat #f) ;; (exec-fn 'common:get-homehost)) ;; homehost record ( addr . hhflag )
(server-url #f) ;; (if *toppath* (exec-fn '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 #f) ;; (exec-fn 'server:expiration-timeout))
(force-server #f)
(ro-mode #f)
(ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode
(ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector
;; dbstruct
(tmpdb #f)
(dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
)
(define *alldat* (make-alldat))
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
;; Syntax for defining macros in a simple style similar to function definiton,
;; when there is a single pattern for the argument list and there are no keywords.
;;
;; (define-simple-syntax (name arg ...) body ...)
;;
(define-syntax define-simple-syntax
(syntax-rules ()
((_ (name arg ...) body ...)
(define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
;; (define-syntax common:handle-exceptions
;; (syntax-rules ()
;; ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))
(define-syntax common:debug-handle-exceptions
(syntax-rules ()
((_ debug exn errstmt body ...)
(if debug
(begin body ...)
(handle-exceptions exn errstmt body ...)))))
(define-syntax common:handle-exceptions
(syntax-rules ()
((_ exn errstmt body ...)
(begin body ...))))
;; (define handle-exceptions common:handle-exceptions)
;; iup callbacks are not dumping the stack, this is a work-around
;;
(define-simple-syntax (debug:catch-and-dump proc procname)
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(with-output-to-port (current-error-port)
(lambda ()
(print ((condition-property-accessor 'exn 'message) exn))
(print "Callback error in " procname)
(print "Full condition info:\n" (condition->list exn)))))
(proc)))
;; Need a mutex protected way to get and set values
;; or use (define-simple-syntax ??
;;
(define-inline (with-mutex mtx accessor record . val)
(mutex-lock! mtx)
(let ((res (apply accessor record val)))
(mutex-unlock! mtx)
res))
;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
#;(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location "??"))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
(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* ((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))
;; register hash tables with BBpp.
#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
(cons hash-table? hash-table->alist))
;; test name converter
#;(define (BBpp_custom_converter arg)
(let ((res #f))
(for-each
(lambda (custom-type-name)
(let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
(custom-type-test (car custom-type-info))
(custom-type-converter (cdr custom-type-info)))
(when (and (not res) (custom-type-test arg))
(set! res (custom-type-converter arg)))))
(hash-table-keys *BBpp_custom_expanders_list*))
(if res (BBpp_ res) arg)))
#;(define (BBpp_ arg)
(cond
;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
((hash-table? arg)
(let ((al (hash-table->alist arg)))
(BBpp_ (cons HASH_TABLE: al))))
((null? arg) '())
;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
#;(define (BBpp arg)
(pp (BBpp_ arg)))
;(use define-macro)
#;(define-syntax inspect
(syntax-rules ()
[(_ x)
;; (with-output-to-port (current-error-port)
(printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; )
]
[(_ x y ...) (begin (inspect x) (inspect y ...))]))
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
)