Megatest

# for the modularized stuff

mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/dbmod.o     : mofiles/commonmod.o mofiles/keysmod.o mofiles/tasksmod.o mofiles/odsmod.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/rmtmod.o    : mofiles/dbmod.o mofiles/commonmod.o mofiles/apimod.o
mofiles/apimod.o    : mofiles/dbmod.o


# Removed from megamod.o dep:   mofiles/ftail.o
mofiles/megamod.o   : \
   mofiles/rmtmod.o \
   mofiles/commonmod.o \
   mofiles/apimod.o \
   mofiles/archivemod.o \
   mofiles/clientmod.o \

;; 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!

                                   payload: `((params . ,params)
                                              (ok-res . #t)))
	     (vector #f res))
           (begin
             #;(common:telemetry-log (conc "api-out:"(->string cmd))
                                   payload: `((params . ,params)
                                              (ok-res . #f)))
             (vector #t res))))))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;

           (else (car argv))))
         (fullpath (realpath this-script)))
    fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir*      (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name*     (pathname-strip-directory *common:this-exe-fullpath*))

(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)))

;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
  (rmt:get-var "MEGATEST_VERSION"))

(define (common:get-last-run-version-number)
  (string->number 
   (substring (common:get-last-run-version) 0 6)))

(define (common:set-last-run-version)
  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))

;; postive number if megatest version > db version
;; negative number if megatest version < db version
(define (common:version-db-delta)
         (- megatest-version (common:get-last-run-version-number)))

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
               (common:version-signature))))

(define (common:api-changed?)
  (not (equal? (substring (->string megatest-version) 0 4)
               (substring (conc (common:get-last-run-version)) 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))
    
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (apply db:multi-db-sync 
   dbstruct
   'schema

	       (mutex-unlock! *db-access-mutex*))))
    val))

;;======================================================================
;; 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))))))

;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
    (if (common:file-exists? fname)
	(if (> (- (current-seconds)(file-modification-time fname)) expire-time)

;;======================================================================
;; D E B U G G I N G   S T U F F 
;;======================================================================

;; (define *verbosity*         1)
;; (define *logging*           #f)

(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)))

;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (common:run-sync?)
    (and (common:on-homehost?)

	(target-patt (args:get-arg "-target")))
    (if target-patt
	(filter (lambda (x)
		  (patt-list-match x target-patt))
		targs)
	targs)))

;; 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))

;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
(define (common:get-homehost #!key (trynum 5))
  ;; called often especially at start up. use mutex to eliminate collisions
  (mutex-lock! *homehost-mutex*)

(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)

;; (import processmod)
(import stml2)



(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)














































































































;; 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

	(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)
	  )))) ;; )

































































































;;======================================================================
;; 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 (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 <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

















;; (define (common:low-noise-print alldat waitval . keys)
;;   (let* ((key      (string-intersperse (map conc keys) "-" ))
;; 	 (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
;; 	 (currtime (current-seconds)))
;;     (if (> (- currtime lasttime) waitval)
;; 	(begin
;; 	  (hash-table-set! (alldat-denoise alldat) key currtime)
;; 	  #t)
;; 	#f)))
;; 
;; (define (common:version-signature alldat)
;;   (conc (alldat-megatest-version alldat)
;; 	"-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
;; 
;; (define (common:get-fields cfgdat)
;;   (let ((fields (hash-table-ref/default cfgdat "fields" '())))
;;     (map car fields)))
;; 
;; ;;======================================================================
;; ;; 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-fields "\\w+" tstr))
;; 	(time-secs 0)
;; 	;; 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)))
;; 			(if val 
;; 			    (set! time-secs (+ time-secs (* val
;; 							    (case (string->symbol unt)
;; 							      ((s) 1)
;; 							      ((m) 60) ;; minutes
;; 							      ((h) 3600)
;; 							      ((d) 86400)
;; 							      ((w) 604800)
;; 							      ((M) 2628000) ;; aproximately one month
;; 							      ((y) 31536000)
;; 							      (else #f))))))))))

;; 	      parts)
;;     time-secs))
;; 		       
;; (define (seconds->hr-min-sec secs)
;;   (let* ((hrs (quotient secs 3600))
;; 	 (min (quotient (- secs (* hrs 3600)) 60))
;; 	 (sec (- secs (* hrs 3600)(* min 60))))
;;     (conc (if (> hrs 0)(conc hrs "hr ") "")
;; 	  (if (> min 0)(conc min "m ")  "")
;; 	  sec "s")))
;; 
;; (define (seconds->time-string sec)
;;   (time->string 
;;    (seconds->local-time sec) "%H:%M:%S"))
;; 
;; (define (seconds->work-week/day-time sec)
;;   (time->string
;;    (seconds->local-time sec) "ww%V.%u %H:%M"))
;; 
;; (define (seconds->work-week/day sec)
;;   (time->string
;;    (seconds->local-time sec) "ww%V.%u"))
;; 
;; (define (seconds->year-work-week/day sec)
;;   (time->string
;;    (seconds->local-time sec) "%yww%V.%w"))
;; 
;; (define (seconds->year-work-week/day-time sec)
;;   (time->string
;;    (seconds->local-time sec) "%Yww%V.%w %H:%M"))
;; 
;; (define (seconds->year-week/day-time sec)
;;   (time->string
;;    (seconds->local-time sec) "%Yw%V.%w %H:%M"))
;; 
;; (define (seconds->quarter sec)
;;   (case (string->number
;; 	 (time->string 
;; 	  (seconds->local-time sec)
;; 	  "%m"))

;;     ((1 2 3) 1)
;;     ((4 5 6) 2)
;;     ((7 8 9) 3)
;;     ((10 11 12) 4)
;;     (else #f)))
;; 
;; ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
;; ;;
;; (define (common:date-time->seconds datetime)

;;   (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
;; 
;; ;; given span of seconds tstart to tend
;; ;; find start time to mark and mark delta
;; ;;
;; (define (common:find-start-mark-and-mark-delta tstart tend)
;;   (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
;; 	 (result   #f)
;; 	 (min      60)
;; 	 (hr       (* 60 60))
;; 	 (day      (* 24 hr))
;; 	 (yr       (* 365 day)) ;; year
;; 	 (mo       (/ yr 12))
;; 	 (wk       (* day 7)))
;;     (for-each
;;      (lambda (max-blks)
;;        (for-each
;; 	(lambda (span) ;; 5 2 1
;; 	  (if (not result)
;; 	      (for-each 
;; 	       (lambda (timeunit timesym) ;; year month day hr min sec
;; 		 (if (not result)
;; 		     (let* ((time-blk (* span timeunit))
;; 			    (num-blks (quotient deltat time-blk)))
;; 		       (if (and (> num-blks 4)(< num-blks max-blks))
;; 			   (let ((first (* (quotient tstart time-blk) time-blk)))

;; 			     (set! result (list span timeunit time-blk first timesym))
;; 			     )))))
;; 	       (list yr mo wk day hr min 1)
;; 	       '(     y  mo w  d   h  m   s))))
;; 	(list 8 6 5 2 1)))
;;      '(5 10 15 20 30 40 50 500))
;;     (if values
;; 	(apply values result)
;; 	(values 0 day 1 0 'd))))
;; 
;; ;; given x y lim return the cron expansion
;; ;;
;; (define (common:expand-cron-slash x y lim)
;;   (let loop ((curr x)
;; 	     (res  `()))
;;     (if (< curr lim)

;; 	(loop (+ curr y) (cons curr res))
;; 	(reverse res))))
;; 
;; ;; expand a complex cron string to a list of cron strings

;; ;;
;; ;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;; ;;  a,b,c => a, b ,c
;; ;;
;; ;;   NOTE: with flatten a lot of the crud below can be factored down.
;; ;;
;; (define (common:cron-expand cron-str)
;;   (if (list? cron-str)
;;       (flatten
;;        (fold (lambda (x res)
;; 	       (if (list? x)
;; 		   (let ((newres (map common:cron-expand x)))
;; 		     (append x newres))
;; 		   (cons x res)))
;; 	     '()

;; 	     cron-str)) ;; (map common:cron-expand cron-str))
;;       (let ((cron-items (string-split cron-str))
;; 	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
;; 	    (comma-rx   (regexp ".*,.*"))
;; 	    (max-vals   '((min        . 60)
;; 			  (hour       . 24)
;; 			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
;; 			  (month      . 12)
;; 			  (dayofweek  . 7))))
;; 	(if (< (length cron-items) 5) ;; bad spec
;; 	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
;; 	    (let loop ((hed  (car cron-items))
;; 		       (tal  (cdr cron-items))
;; 		       (type 'min)
;; 		       (type-tal '(hour dayofmonth month dayofweek))
;; 		       (res  '()))
;; 	      (regex-case
;; 		  hed
;; 		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
;; 						 (incrn          (string->number incr))
;; 						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
;; 						 (new-list-crons (fold (lambda (x myres)
;; 									 (cons (conc (if (null? res)
;; 											 ""
;; 											 (conc (string-intersperse res " ") " "))
;; 										     x " " (string-intersperse tal " "))
;; 									       myres))
;; 								       '() expanded-vals)))
;; 					    ;; (print "new-list-crons: " new-list-crons)
;; 					    ;; (fold (lambda (x res)
;; 					    ;; 	    (if (list? x)

;; 					    ;; 		(let ((newres (map common:cron-expand x)))
;; 					    ;; 		  (append x newres))

;; 					    ;; 		(cons x res)))
;; 					    ;; 	  '()


;; 					    (flatten (map common:cron-expand new-list-crons))))
;; 		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
;; 		(else (if (null? tal)
;; 			  cron-str
;; 			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
;; 		      
;; 	    
;; ;; given a cron string and the last time event was processed return #t to run or #f to not run
;; ;;


;; ;;  min    hour   dayofmonth month  dayofweek
;; ;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
;; ;;
;; ;;  #t => yes, run the job
;; ;;  #f => no, do not run the job
;; ;;
;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
;;   (let* ((cron-items     (map string->number (string-split cron-str)))
;; 	 (now-seconds    (or now-seconds-in (current-seconds)))
;; 	 (now-time       (seconds->local-time now-seconds))
;; 	 (last-done-time (seconds->local-time last-done))
;; 	 (all-times      (make-hash-table)))
;;     ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
;;     (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
;; 	#f
;; 	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
;; 		     cron-items)
;; 		    ;; 0     1    2        3         4    5      6
;; 		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
;; 		     (vector->list now-time))
;; 		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
;; 		     (vector->list last-done-time)))
;; 	  ;; create all possible time slots
;; 	  ;; remove invalid slots due to (for example) day of week
;; 	  ;; get the start and end entries for the ref-seconds (current) time
;; 	  ;; if last-done > ref-seconds => this is an ERROR!
;; 	  ;; does the last-done time fall in the legit region?
;; 	  ;;    yes => #f  do not run again this command
;; 	  ;;    no  => #t  ok to run the command
;; 	  (for-each ;; month
;; 	   (lambda (month)
;; 	     (for-each ;; dayofmonth
;; 	      (lambda (dom)
;; 		(for-each
;; 		 (lambda (hr) ;; hour
;; 		   (for-each
;; 		    (lambda (minute) ;; minute
;; 		      (let ((copy-now (apply vector (vector->list now-time))))

;; 			(vector-set! copy-now 0 0) ;; force seconds to zero
;; 			(vector-set! copy-now 1 minute)
;; 			(vector-set! copy-now 2 hr)
;; 			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
;; 			(vector-set! copy-now 4 month)
;; 			(let* ((copy-now-secs (local-time->seconds copy-now))
;; 			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
;; 			  (if (or (not cdayofweek)
;; 				  (equal? (vector-ref new-copy 6)
;; 					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
;; 			      (if (or (not cdayofmonth)
;; 				      (equal? (vector-ref new-copy 3)
;; 					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified

;; 				  (hash-table-set! all-times copy-now-secs new-copy))))))
;; 		    (if cmin
;; 			`(,cmin)  ;; if given cmin, have to use it

;; 			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
;; 		 (if chour
;; 		     `(,chour)
;; 		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
;; 	      (if cdayofmonth
;; 		  `(,cdayofmonth)
;; 		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))

;; 	   (if cmonth
;; 	       `(,cmonth)
;; 	       (list (- nmonth 1) nmonth (+ nmonth 1))))
;; 	  (let ((before #f)
;; 		(is-in  #f))
;; 	    (for-each
;; 	     (lambda (moment)
;; 	       (if (and before
;; 			(<= before now-seconds)
;; 			(>= moment now-seconds))

;; 		   (begin

;; 		     ;; (print)
;; 		     ;; (print "Before: " (time->string (seconds->local-time before)))
;; 		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
;; 		     ;; (print "After:  " (time->string (seconds->local-time moment)))
;; 		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
;; 		     (if (<  last-done before)
;; 			 (set! is-in before))
;; 		     ))
;; 	       (set! before moment))
;; 	     (sort (hash-table-keys all-times) <))
;; 	    is-in)))))
;; 
;; (define (common:extended-cron  cron-str now-seconds-in last-done)
;;   (let ((expanded-cron (common:cron-expand cron-str)))
;;     (if (string? expanded-cron)
;; 	(common:cron-event expanded-cron now-seconds-in last-done)
;; 	(let loop ((hed (car expanded-cron))
;; 		   (tal (cdr expanded-cron)))
;; 	  (if (common:cron-event hed now-seconds-in last-done)
;; 	      #t
;; 	      (if (null? tal)
;; 		  #f

;; 		  (loop (car tal)(cdr tal))))))))
;; 
;; ;;======================================================================
;; ;; C O L O R S
;; ;;======================================================================
;;       
;; (define (common:name->iup-color name)
;;   (case (string->symbol (string-downcase name))
;;     ((red)    "223 33 49")
;;     ((grey)   "192 192 192")
;;     ((orange) "255 172 13")
;;     ((purple) "This is unfinished ...")))
;; 
;; ;; (define (common:get-color-for-state-status state status)
;; ;;   (case (string->symbol state)
;; ;;     ((COMPLETED)
;; ;;      (case (string->symbol status)
;; ;;        ((PASS)        "70  249 73")
;; ;;        ((WARN WAIVED) "255 172 13")
;; ;;        ((SKIP)        "230 230 0")
;; ;;        (else "223 33 49")))
;; ;;     ((LAUNCHED)         "101 123 142")
;; ;;     ((CHECK)            "255 100 50")
;; ;;     ((REMOTEHOSTSTART)  "50  130 195")
;; ;;     ((RUNNING)          "9   131 232")
;; ;;     ((KILLREQ)          "39  82  206")
;; ;;     ((KILLED)           "234 101 17")
;; ;;     ((NOT_STARTED)      "240 240 240")
;; ;;     (else               "192 192 192")))
;; 
;; (define (common:iup-color->rgb-hex instr)
;;   (string-intersperse 
;;    (map (lambda (x)
;;           (number->string x 16))
;;         (map string->number
;;              (string-split instr)))
;;    "/"))
;; 
;; ;; dot-locking egg seems not to work, using this for now
;; ;; if lock is older than expire-time then remove it and try again
;; ;; to get the lock

;; ;;
;; (define (common:simple-file-lock fname #!key (expire-time 300))
;;     (if (file-exists? fname)
;; 	(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
;; 	    (begin
;;               (handle-exceptions exn #f (delete-file* fname))	
;; 	      (common:simple-file-lock fname expire-time: expire-time))
;; 	    #f)
;; 	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
;; 	  (with-output-to-file fname
;; 	    (lambda ()
;; 	      (print key-string)))
;; 	  (thread-sleep! 0.25)
;; 	  (if (file-exists? fname)
;; 	      (handle-exceptions exn
;;                 #f 
;;                 (with-input-from-file fname
;; 	  	  (lambda ()
;; 		    (equal? key-string (read-line)))))
;; 	      #f))))
;; 
;; (define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
;;   (let ((end-time (+ expire-time (current-seconds))))
;;     (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
;;       (if got-lock
;; 	  #t
;; 	  (if (> end-time (current-seconds))
;; 	      (begin
;; 		(thread-sleep! 3)
;; 		(loop (common:simple-file-lock fname expire-time: expire-time)))
;; 	      #f)))))
;; 
;; (define (common:simple-file-release-lock fname)
;;   (handle-exceptions
;;       exn
;;       #f ;; I don't really care why this failed (at least for now)
;;     (delete-file* fname)))
;; 
;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;; ;;
;; (define (common:lazy-modification-time fpath)
;;   (handle-exceptions
;;       exn
;;       0
;;       (file-modification-time fpath)))
;; 
;; ;; find timestamp of newest file associated with a sqlite db file
;; (define (common:lazy-sqlite-db-modification-time fpath)
;;   (let* ((glob-list (handle-exceptions
;; 			exn
;; 			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
;; 		      (glob (conc fpath "*"))))
;;          (file-list (if (eq? 0 (length glob-list))
;; 			'("/no/such/file")
;; 			glob-list)))
;;   (apply max
;;    (map
;;     common:lazy-modification-time 
;;     file-list))))
;; 
;; 
;; ;; 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/*")))))
;;   )
;; )
;;

;; 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)

(import commonmod)
(declare (uses rmtmod))
(import rmtmod)
(declare (uses runsmod))
(import runsmod)
(declare (uses dbmod))
(import dbmod)



(declare (uses dcommonmod))
(import dcommonmod)
(declare (uses mtargs))
(import (prefix mtargs args:))
(declare (uses ducttape-lib))
(import ducttape-lib)
(declare (uses mtconfigf))
(import (prefix mtconfigf configf:))


(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
;; (include "megatest-fossil-hash.scm") ;; comes from megamod
(include "vg_records.scm")

;; invoke the imports
(declare (uses commonmod.import))

(declare (uses rmtmod.import))
(declare (uses runsmod.import))
(declare (uses megamod.import))
(declare (uses dcommonmod.import))
(declare (uses mtargs.import))
(declare (uses ducttape-lib.import))
(declare (uses mtconfigf.import))

       (sqlite3:for-each-row
	(lambda (val)
	  (set! res val))
	db
	(conc "SELECT " key " FROM runs WHERE id=?;")
	run-id)
       res))))

;; keys list to key1,key2,key3 ...
(define (runs:get-std-run-fields keys remfields)
  (let* ((header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (list keystr header)))

;; make a query (fieldname like 'patt1' OR fieldname 
(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
  (let ((patts (if (string? pattstr)
		   (string-split pattstr ",")
		   '("%"))))
    (string-intersperse (map (lambda (patt)
			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
				 (conc fieldname " " wildtype " '" patt "'")))
			     (if (null? patts)
				 '("")
				 patts))
			comparator)))


;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user contour-in)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))

;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update  sort-order ) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
    (for-each (lambda (keyval)
		(let* ((key    (car keyval))
		       (patt   (cadr keyval))
		       (fulkey (conc ":" key))
		       (wildtype (if (substring-index "%" patt) "like" "glob")))

		   db
		   "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
		  res))))

;;======================================================================
;; M I S C   M A N A G E M E N T   I T E M S 
;;======================================================================

;; A routine to map itempaths using a itemmap
;; patha and pathb must be strings or this will fail
;;
;; path-b is waiting on path-a
;;
(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
  (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
  (let* ((itemmap    (tests:lookup-itemmap itemmaps test-b-name)))
    (if itemmap
	(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
	  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
	  (equal? path-a path-b-mapped))
	(equal? path-b path-a))))

;; A routine to convert test/itempath using a itemmap
;; NOTE: to process only an itempath (i.e. no prepended testname)
;;       just call db:multi-pattern-apply
;;
(define (db:convert-test-itempath path-in itemmap)
  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
  (let* ((path-parts  (string-split path-in "/"))
	 (test-name   (if (null? path-parts) "" (car path-parts)))
	 (item-path   (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
    (conc test-name "/" 
	  (db:multi-pattern-apply item-path itemmap))))

;; patterns are:
;;    "rx1"  "replacement1"\n
;;    "rx2"  "replacement2"
;; etc.
;;
(define (db:multi-pattern-apply item-path itemmap)
  (let ((all-patts (string-split itemmap "\n")))
    (if (null? all-patts)
	item-path
	(let loop ((hed (car all-patts))
		   (tal (cdr all-patts))
		   (res item-path))
	  (let* ((parts (string-split hed))
		 (patt  (car parts))

		 (repl  (if (> (length parts) 1)(cadr parts) ""))

		 (newr  (if (and patt repl)
			    (begin
                              (handle-exceptions
                               exn
                               (begin
                                  (debug:print 0 *default-log-port*
                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
                                 res)
                              (string-substitute patt repl res))


                              )
			    (begin
                              (debug:print 0 *default-log-port*
                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
			      res))))
	    (if (null? tal)
		newr
		(loop (car tal)(cdr tal) newr)))))))




;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met

;;     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 dcommonmod))
(declare (uses commonmod))

(declare (uses megamod))
(declare (uses mtargs))

(module dcommonmod
	*
	
(import scheme chicken data-structures extras)

	uri-common
	z3
	)

(use (prefix mtconfigf configf:))

(import commonmod)

(import megamod)
(import canvas-draw)
(import canvas-draw-iup)
(use (prefix iup iup:))
(import (prefix mtargs args:))

(define *tim* (iup:timer))

;;     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/>.
;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

(define (args:usage . a) #f)

;;======================================================================
;; key <=> target routines
;;======================================================================

;; This invalidates using "/" in item names. Every key will be
;; available via args:get-arg as :keyfield. Since this only needs to
;; be called once let's use it to set the environment vars
;;
;; The setting of :keyfield in args should be turned off ASAP
;;
(define (keys:target-set-args keys target ht)
  (if target
      (let ((vals (string-split target "/")))
	(if (eq? (length vals)(length keys))
	    (for-each (lambda (key val)
			(setenv key val)
			(if ht (hash-table-set! ht (conc ":" key) val)))
		      keys
		      vals)
	    (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
	vals)
      (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))

;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list
;; keyval list ( (key1 val1) (key2 val2) ...)
(define (keys:target->keyval keys target)
  (let* ((targlist (string-split target "/"))
	 (numkeys  (length keys))
	 (numtarg  (length targlist))
	 (targtweaked (if (> numkeys numtarg)
			  (append targlist (make-list (- numkeys numtarg) ""))
			  targlist)))
    (map (lambda (key targ)
	   (list key targ))
	 keys targtweaked)))

;;======================================================================
;; config file related routines
;;======================================================================

(define keys:config-get-fields common:get-fields)
(define (keys:make-key/field-string confdat)
  (let ((fields (configf:get-section confdat "fields")))
    (string-join
     (map (lambda (field)(conc (car field) " " (cadr field)))
	  fields)
     ",")))

;; (declare (uses odsmod))
;; (declare (uses processmod))
;; (declare (uses runconfigmod))
(declare (uses runsmod))
;; (declare (uses servermod))
;; (declare (uses subrunmod))
;; (declare (uses tasksmod))
;; (declare (uses testsmod))
;; (declare (uses vgmod))
(declare (uses pkts))
(declare (uses mtargs))
(declare (uses mtconfigf))
(declare (uses ducttape-lib))

(module megamod

;; (import processmod)
(import rmtmod)
;; (import runconfigmod)
(import runsmod)
;; (import servermod)
;; (import subrunmod)
;; (import tasksmod)
;; (import testsmod)
;; (import vgmod)
(import pkts)
(import (prefix mtargs args:))
(import ducttape-lib)

(use (prefix ulex ulex:))

(include "archive-inc.scm")  
(include "client-inc.scm")
(include "common-inc.scm")    ;; L5
(include "db-inc.scm")        ;; L4
(include "env-inc.scm")
(include "http-transport-inc.scm")
(include "items-inc.scm")
(include "keys-inc.scm")
(include "launch-inc.scm")     ;; L1
;; (include "margs-inc.scm")
(include "mt-inc.scm")
(include "ods-inc.scm")        ;; L1
(include "pgdb-inc.scm")
(include "portlogger-inc.scm")
(include "process-inc.scm")    ;; L6

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format
     (prefix mtconfigf configf:))


;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(require-library mutils)

(import commonmod)
(declare (uses rmtmod))
(import rmtmod)
(declare (uses dbmod))
(import dbmod)
(declare (uses runsmod))
(import runsmod)


(declare (uses megamod))
(import megamod)
(declare (uses mtargs))
(import (prefix mtargs args:))
(declare (uses mtconfigf))
(import (prefix mtconfigf configf:))
(declare (uses ducttape-lib))
(import ducttape-lib)

;; invoke the imports
(declare (uses commonmod.import))

(declare (uses rmtmod.import))
(declare (uses runsmod.import))
(declare (uses megamod.import))
(declare (uses mtargs.import))
(declare (uses mtconfigf.import))
(declare (uses ducttape-lib.import))

	      (if (server:check-if-running areapath)
		  (client:setup areapath)
		  #f))))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected


  #;(common:telemetry-log (conc "rmt:"(->string cmd))



                        payload: `((rid . ,rid)
                                   (params . ,params)))
                          
  ;; do all the prep locked under the rmt-mutex
  (mutex-lock! *rmt-mutex*)
  
  ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
  ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
  ;; 3. do the query, if on homehost use local access
  ;;
  (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
         (areapath      *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
	 (runremote     (or area-dat
			    *runremote*))
	 (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))

    ;; ensure we have a record for our connection for given area
    (if (not runremote)                   ;; can remove this one. should never get here.         
	(begin
	  (set! *runremote* (make-remote))
	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
    
    ;; ensure we have a homehost record
    (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
	(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
	(remote-hh-dat-set! runremote (common:get-homehost)))
    
    ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
    (cond
     ;; give up if more than 15 attempts
     ((> attemptnum 15)
      (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
      (exit 1))

     ;; readonly mode, read request-  handle it - case 2
     ((and readonly-mode
           (member cmd api:read-only-queries)) 
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
      (rmt:open-qry-close-locally cmd 0 params)
      )


     ;; readonly mode, write request.  Do nothing, return #f
     (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))

     ;; 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)












     ;;
     ;; 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))
     
     ;; on homehost and this is a read
     ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
	   (cdr (remote-hh-dat runremote))       ;; on homehost
           (member cmd api:read-only-queries))   ;; this is a read
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5")
      (rmt:open-qry-close-locally cmd 0 params))

     ;; on homehost and this is a write, we already have a server, but server has died
     ((and (cdr (remote-hh-dat runremote))           ;; on homehost
           (not (member cmd api:read-only-queries))  ;; this is a write
           (remote-server-url runremote)             ;; have a server
           (not (server:ping (remote-server-url runremote))))  ;; server has died. NOTE: this is not a cheap call! Need better approach.
      (set! *runremote* (make-remote))
      (remote-force-server-set! runremote (common:force-server?))
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6")
      (rmt:send-receive cmd rid params attemptnum: attemptnum))

     ;; on homehost and this is a write, we already have a server
     ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
	   (cdr (remote-hh-dat runremote))           ;; on homehost
           (not (member cmd api:read-only-queries))  ;; this is a write
           (remote-server-url runremote))            ;; have a server
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4.1")
      (rmt:open-qry-close-locally cmd 0 params))

     ;;  on homehost, no server contact made and this is a write, passively start a server 
     ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
	   (cdr (remote-hh-dat runremote))           ;; have homehost
           (not (remote-server-url runremote))       ;; no connection yet
	   (not (member cmd api:read-only-queries))) ;; not a read-only query
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8")
      (let ((server-url  (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
	(if server-url
	    (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
	    (if (common:force-server?)
		(server:start-and-wait *toppath*)
		(server:kind-run *toppath*))))
      (remote-force-server-set! runremote (common:force-server?))
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8.1")
      (rmt:open-qry-close-locally cmd 0 params))

     ((or (and (remote-force-server runremote)              ;; we are forcing a server and don't yet have a connection to one
	       (not (remote-conndat runremote)))
	  (and (not (cdr (remote-hh-dat runremote)))        ;; not on a homehost 
	       (not (remote-conndat runremote))))           ;; and no connection
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
      (mutex-unlock! *rmt-mutex*)
      (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
	  (server:start-and-wait *toppath*))
      (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
      (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as

     ;; all set up if get this far, dispatch the query
     ((and (not (remote-force-server runremote))
	   (cdr (remote-hh-dat runremote))) ;; we are on homehost
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
      (rmt:open-qry-close-locally cmd (if rid rid 0) params))

     ;; not on homehost, do server query
     (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))

;; bunch of small functions factored out of send-receive to make debug easier
;;

(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
  ;; (mutex-unlock! *rmt-mutex*)
  (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9")

		  (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)
  (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))

;;======================================================================
;; runs:run-tests is called from megatest.scm and itself
;;======================================================================
;;
;;  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

;;     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 runsmod))
(declare (uses commonmod))


(module runsmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import commonmod)

;; (use (prefix ulex ulex:))

;; (include "common_records.scm")
(defstruct runs:dat
  reglen regfull
  runname max-concurrent-jobs run-id
  test-patts required-tests test-registry

  (let ((lasttime (hash-table-ref/default *runs:denoise* key 0))
	(currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))




)

;;
;;======================================================================

;;======================================================================
;; Tests
;;======================================================================

(define *java-script-lib* #f)

(define (init-java-script-lib)
  (set! *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
  )

;; 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
;;
(define (tests:get-all)
  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))
    (tests:get-valid-tests (make-hash-table) test-search-path)))

(define (tests:get-tests-search-path cfgdat)
  (let ((paths (let ((section (if cfgdat
				  (configf:get-section cfgdat "tests-paths")
				  #f)))
		 (if section
		     (map cadr section)
		     '()))))
    (filter (lambda (d)
	      (if (directory-exists? d)
		  d
		  (begin
		    (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
			(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
		    #f)))
	    (append paths (list (conc *toppath* "/tests"))))))

(define (tests:get-valid-tests test-registry tests-paths)
  (if (null? tests-paths) 
      test-registry
      (let loop ((hed (car tests-paths))
		 (tal (cdr tests-paths)))
	(if (common:file-exists? hed)
	    (for-each (lambda (test-path)
			(let* ((tname   (last (string-split test-path "/")))
			       (tconfig (conc test-path "/testconfig")))
			  (if (and (not (hash-table-ref/default test-registry tname #f))
				   (common:file-exists? tconfig))
			      (hash-table-set! test-registry tname test-path))))
		      (glob (conc hed "/*"))))
	(if (null? tal)
	    test-registry
	    (loop (car tal)(cdr tal))))))

(define (tests:filter-test-names-not-matched test-names test-patts)
  (delete-duplicates
   (filter (lambda (testname)
	     (not (tests:match test-patts testname #f)))
	   test-names)))


(define (tests:filter-test-names test-names test-patts)
  (delete-duplicates
   (filter (lambda (testname)
	     (tests:match test-patts testname #f))
	   test-names)))

;; itemmap is a list of testname patterns to maps
;;     test1 .*/bar/(\d+) foo/\1
;;     %     foo/([^/]+)  \1/bar
;;
;; # NOTE: the line with the single % could be the result of
;; #       itemmap entry in requirements (legacy). The itemmap
;; #       requirements entry is deprecated
;;
(define (tests:get-itemmaps tconfig)
  (let ((base-itemmap  (configf:lookup tconfig "requirements" "itemmap"))
	(itemmap-table (configf:get-section tconfig "itemmap")))
    (append (if base-itemmap
		(list (list "%" base-itemmap))
		'())
	    (if itemmap-table
		itemmap-table
		'()))))

;; given a list of itemmaps (testname . map), return the first match
;;
(define (tests:lookup-itemmap itemmaps testname)
  (let ((best-matches (filter (lambda (itemmap)
				(tests:match (car itemmap) testname #f))
			      itemmaps)))
    (if (null? best-matches)
	#f
	(let ((res (car best-matches)))
	  ;; (debug:print 0 *default-log-port* "res=" res)
	  (cond
	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
	   ((null? res)   #f)
	   ((string? (cdr res)) (cdr res))  ;; it is a pair
	   ((string? (cadr res))(cadr res)) ;; it is a list
	   (else cadr res))))))

;; return items given config
;;
(define (tests:get-items tconfig)
  (let ((items      (hash-table-ref/default tconfig "items" #f)) ;; items 4
	(itemstable (hash-table-ref/default tconfig "itemstable" #f))) 
    ;; if either items or items table is a proc return it so test running
    ;; process can know to call items:get-items-from-config

			#t
			(begin
			  (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
			  #f)))
		  newwaitors)
	  config)))))
					     
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;;  genlib/testconfig               sim/testconfig
;;  genlib/sch                      sim/sch/cell1
;;
;;  [requirements]                  [requirements]
;;                                  mode itemwait
;;                                  # trim off the cell to determine what to run for genlib
;;                                  itemmap /.*
;;
;;                                  waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
;; expected -> "normal-first,normal-second/2,normal-second/"
;; testpatt = normal-second/2
;; waiting-test = normal-second
;; waiton-test = normal-first
;; itemmaps = ()

(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
  (cond
   (itemized-waiton
    (let* ((itemmap          (tests:lookup-itemmap itemmaps waiton-test))
           (patts            (string-split test-patt ","))
           (waiting-test-len (+ (string-length waiting-test) 1))
           (patts-waiton     (map (lambda (x)  ;; for each incoming patt that matches the waiting test
                                    (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
                                           (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
                                      ;; (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)))
           (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) ",")))
   (else ;; not waiting on items, waiting on entire waiton test.
    (let* ((patts (string-split test-patt ","))
           (new-patts (if (member waiton-test patts)
                          patts
                          (cons waiton-test patts))))
      (string-intersperse (delete-duplicates new-patts) ",")))))


  
;; tests:glob-like-match 
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
	   (newpatt  (if notpatt (substring patt 1) patt))
	   (finpatt  (if like
			(string-substitute (regexp "%") ".*" newpatt #f)
			(string-substitute (regexp "\\*") ".*" newpatt #f)))
	   (res      #f))
      ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
      (set! res (string-match (regexp finpatt (if like #t #f)) str))
      (if notpatt (not res) res))))

;; if itempath is #f then look only at the testname part
;;
(define (tests:match patterns testname itempath #!key (required '()))
  (if (string? patterns)
      (let ((patts (append (string-split patterns ",") required)))
	(if (null? patts) ;;; no pattern(s) means no match
	    #f
	    (let loop ((patt (car patts))
		       (tal  (cdr patts)))
	      ;; (print "loop: patt: " patt ", tal " tal)
	      (if (string=? patt "")
		  #f ;; nothing ever matches empty string - policy
		  (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
			 (test-patt  (cadr patt-parts))
			 (item-patt  (cadddr patt-parts)))
		    ;; special case: test vs. test/
		    ;;   test  => "test" "%"
		    ;;   test/ => "test" ""
		    (if (and (not (substring-index "/" patt)) ;; no slash in the original
			     (or (not item-patt)
				 (equal? item-patt "")))      ;; should always be true that item-patt is ""
			(set! item-patt "%"))
		    ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
		    (if (and (tests:glob-like-match test-patt testname)
			     (or (not itempath)
				 (tests:glob-like-match (if item-patt item-patt "") itempath)))
			#t
			(if (null? tal)
			    #f
			    (loop (car tal)(cdr tal)))))))))))

;; if itempath is #f then look only at the testname part
;;
(define (tests:match->sqlqry patterns)
  (if (string? patterns)
      (let ((patts (string-split patterns ",")))
	(if (null? patts) ;;; no pattern(s) means no match, we will do no query
	    #f
	    (let loop ((patt (car patts))
		       (tal  (cdr patts))
		       (res  '()))
	      ;; (print "loop: patt: " patt ", tal " tal)
	      (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
		     (test-patt  (cadr patt-parts))
		     (item-patt  (cadddr patt-parts))
		     (test-qry   (db:patt->like "testname" test-patt))
		     (item-qry   (db:patt->like "item_path" item-patt))
		     (qry        (conc "(" test-qry " AND " item-qry ")")))
		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
		(if (null? tal)
		    (string-intersperse (append (reverse res)(list qry)) " OR ")
		    (loop (car tal)(cdr tal)(cons qry res)))))))
      #f))

;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
  (let* ((test-registry (make-hash-table))
	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
	 (test-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir testdat)) ;; )

(declare (unit testsmod))
(declare (uses commonmod))

(module testsmod
	*
	
(import scheme chicken data-structures extras)

(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)



(import commonmod)
;; (use (prefix ulex ulex:))


(include "common_records.scm")







































































































































































































































































































































































)