Megatest

     typed-records
     z3)

(import stml2
	)

(module commonmod
	(
	 ;; globals
	 *already-seen-runconfig-info*
	 *common:badly-ended-states*
	 *common:dont-roll-up-states*
	 *common:ended-states*
	 *common:not-started-ok-statuses*
	 *common:running-states*
	 *common:std-states*
	 *common:std-statuses*
	 *common:well-ended-states*
	 *configdat*
	 *configinfo*
	 *configstatus*
	 *db-access-allowed*
	 *db-api-call-time*
	 *db-cache-path*
	 *db-keys*
	 *default-area-tag*
	 *env-vars-by-run-id*
	 *globalexitstatus*
	 *host-loads*
	 *keyvals*
	 *last-launch*
	 *launch-setup-mutex*
	 *logged-in-clients*
	 *my-client-signature*
	 *on-exit-procs*
	 *passnum*
	 *pkts-info*
	 *pre-reqs-met-cache*
	 *runconfigdat*
	 *runremote*
	 *server-id*
	 *server-info*
	 *target*
	 *task-db*
	 *test-meta-updated*
	 *testconfigs*
	 *time-to-exit*
	 *toppath*
	 *toptest-paths*
	 *transport-type*

	 *common:this-exe-dir*

	 common:list-is-sublist
	 seconds->year-week/day-time
	 common:find-start-mark-and-mark-delta

	 common:with-orig-env
	 alist->env-vars
	 any->number
	 any->number-if-possible
	 assoc/default
	 client:get-signature
	 
	 common:alist-ref/default
	 common:clear-caches
	 common:dir-clean-up
	 common:directory-exists?
	 common:directory-writable?
	 common:fail-safe
	 common:file-exists?
	 common:find-local-megatest
	 common:generic-ssh
	 common:get-area-path-signature
	 common:get-color-from-status
	 common:get-cpu-load
	 common:get-create-writeable-dir
	 common:get-fields
	 common:get-intercept
	 common:get-megatest-exe
	 common:get-megatest-exe-dir
	 common:get-megatest-exe-path
	 common:get-mtexe
	 common:get-normalized-cpu-load
	 common:get-normalized-cpu-load
	 common:get-num-cpus
	 common:get-param-mapping
	 common:get-signature
	 common:get-toppath
	 common:hms-string->seconds
	 common:htree->html
	 common:human-time
	 common:in-running-test?
	 common:join-backgrounded-threads
	 common:lazy-sqlite-db-modification-time
	 common:list->htree
	 common:list-or-null
	 common:logpro-exit-code->status-sym
	 common:low-noise-print
	 common:make-tmpdir-name
	 common:max
	 common:min-max
	 common:nice-path
         nice-path
	 common:pkts-spec
	 common:raw-get-remote-host-load
	 common:read-encoded-string
	 common:real-path
	 common:send-thunk-to-background-thread
	 common:simple-file-lock
	 common:simple-file-lock-and-wait
	 common:simple-file-release-lock
	 common:sparse-list-generate-index
	 common:special-sort
	 common:steps-can-proceed-given-status-sym
	 common:sum
	 common:to-alist
	 common:unix-ping
	 common:val->alist
	 common:version-signature
	 common:which
	 common:with-env-vars
	 common:without-vars
	 common:worse-status-sym
	 commonmod:get-cpu-load
	 commonmod:is-test-alive
	 db:mintest-get-event_time
	 db:patt->like
	 
	 db:test-data-get-category
	 db:test-data-get-comment
	 db:test-data-get-expected
	 db:test-data-get-id
	 db:test-data-get-last_update
	 db:test-data-get-status
	 db:test-data-get-test_id
	 db:test-data-get-tol
	 db:test-data-get-type
	 db:test-data-get-units
	 db:test-data-get-value
	 db:test-data-get-variable
	 db:test-get-archived
	 db:test-get-comment
	 db:test-get-cpuload
	 db:test-get-diskfree
	 db:test-get-event_time
	 db:test-get-final_logf
	 db:test-get-fullname
	 db:test-get-host
	 db:test-get-id
	 db:test-get-is-toplevel
	 db:test-get-item-path
	 db:test-get-last_update
	 db:test-get-process_id
	 db:test-get-run_duration
	 db:test-get-run_id
	 db:test-get-rundir
	 db:test-get-state
	 db:test-get-status
	 db:test-get-testname
	 db:test-get-uname
	 db:test-make-full-name
	 db:test-set-state!
	 db:test-set-status!
	 db:test-set-testname!
	 
	 db:testmeta-get-author
	 db:testmeta-get-description
	 db:testmeta-get-owner
	 db:testmeta-get-reviewed
	 db:testmeta-get-tags
	 
	 get-area-path-signature
	 get-normalized-cpu-load
	 getenv
	 host-last-cpuload
	 host-last-cpuload-set!
	 host-last-update
	 host-last-update-set!
	 host-last-used
	 host-last-used-set!
	 host-reachable
	 host-reachable-set!
	 item-list->path
	 keys->keystr
	 keys->valslots
	 keys:config-get-fields
	 keys:target->keyval
	 keys:target-set-args
	 make-db:testmeta
	 make-host
	 make-sparse-array
	 make-tests:testqueue
	 megatest-fossil-hash
	 megatest-version
	 number-of-processes-running
	 patt-list-match
	 rmt:transport-mode
	 runs:get-std-run-fields
	 safe-setenv
	 save-environment-as-files
	 sdb:qry
	 seconds->hr-min-sec
	 seconds->quarter
	 seconds->time-string
	 seconds->work-week/day
	 seconds->work-week/day-time
	 seconds->year-work-week/day-time
	 setenv
	 sparse-array-ref
	 sparse-array-set!
	 status-sym->string
	 stop-the-train
	 tasks:wait-on-journal
	 
	 tdb:step-get-comment
	 tdb:step-get-event_time
	 tdb:step-get-id
	 tdb:step-get-last_update
	 tdb:step-get-logfile
	 tdb:step-get-state
	 tdb:step-get-status
	 tdb:step-get-stepname
	 tdb:step-get-test_id
	 tdb:steps-table-get-end
	 tdb:steps-table-get-log-file
	 tdb:steps-table-get-runtime
	 tdb:steps-table-get-start
	 tdb:steps-table-get-status
	 tdb:steps-table-get-stepname
	 
	 tests:glob-like-match
	 tests:lookup-itemmap
	 tests:match
	 tests:match->sqlqry

	 tests:testqueue-get-item_path
	 tests:testqueue-get-itemdat
	 tests:testqueue-get-items
	 tests:testqueue-get-priority
	 tests:testqueue-get-testconfig
	 tests:testqueue-get-testname
	 tests:testqueue-get-waitons
	 tests:testqueue-set-item_path!
	 tests:testqueue-set-itemdat!
	 tests:testqueue-set-items!
	 tests:testqueue-set-priority!
	 
	 val->alist
	 )
	
(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  (prefix base64 base64:)

	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  system-information

	  debugprint
	  megatest-fossil-hash
	  
  )))

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "common_records.scm")

;; http - use the old http + in /tmp db
;; tcp  - use tcp transport with cachedb db
;; nfs  - use direct to disk access (read-only)
;;
(define rmt:transport-mode (make-parameter 'tcp))

                 (string-match "^(.*/csi|csi)$" (car argv))
                 (string-match "^-(s|ss|sx|script)$" (cadr argv)))
            (caddr argv))
           (else (car argv))))
         (fullpath (realpath this-script)))
    fullpath))

;; get rid of these, no need to slow down start up
;;======================================================================

(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:get-sync-lock-filepath)

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

;; environment vars handy stuff from common.scm
;;
(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.
	  (substring-index "." key)) ;; periods are not allowed in 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))

  ;; convert string a=1; b=2; c=a silly thing; d=
  (let ((valstr (lookup cfgdat section var)))
    (if valstr
	(val->alist valstr)
	'()))) ;; should it return empty list or #f to indicate not set?





(define (common:make-tmpdir-name areapath tmpadj)
  (let* ((area (pathname-file areapath))
         (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
    (unless (directory-exists? dname)
      (create-directory dname #t))
    dname))

;; misc conversion, data manipulation functions
;;======================================================================

;;======================================================================
;; old stuff from keys.scm
;;======================================================================




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

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

(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f))
  (if (not (string? path))

  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define keys:config-get-fields common:get-fields)

;;======================================================================
;; db_records.scm
;;======================================================================

;;======================================================================
;; dbstruct
;;======================================================================

(define (make-db:test)(make-vector 20))
(define (db:test-get-id           vec) (vector-ref vec 0))
(define (db:test-get-run_id       vec) (vector-ref vec 1))
(define (db:test-get-testname     vec) (vector-ref vec 2))
(define (db:test-get-state        vec) (vector-ref vec 3))
(define (db:test-get-status       vec) (vector-ref vec 4))
(define (db:test-get-event_time   vec) (vector-ref vec 5))
(define (db:test-get-host         vec) (vector-ref vec 6))
(define (db:test-get-cpuload      vec) (vector-ref vec 7))
(define (db:test-get-diskfree     vec) (vector-ref vec 8))
(define (db:test-get-uname        vec) (vector-ref vec 9))
;; (define (db:test-get-rundir       vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir       vec) (vector-ref vec 10))
(define (db:test-get-item-path    vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf   vec) (vector-ref vec 13))
(define (db:test-get-comment      vec) (vector-ref vec 14))
(define (db:test-get-process_id   vec) (vector-ref vec 16))
(define (db:test-get-archived     vec) (vector-ref vec 17))
(define (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count   vec) (vector-ref vec 16))
(define (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

;; (define (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))

;; Test record utility functions

;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
  (and (equal? (db:test-get-item-path vec) "")      ;; test is not an item
       (equal? (db:test-get-uname vec)     "n/a"))) ;; test has never been run

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define (db:mintest-get-status       vec)    (vector-ref  vec 4))
(define (db:mintest-get-event_time   vec)    (vector-ref  vec 5))
(define (db:mintest-get-item_path    vec)    (vector-ref  vec 6))

;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id            vec)    (vector-ref  vec 0))
(define (db:testmeta-get-testname      vec)    (vector-ref  vec 1))
(define (db:testmeta-get-author        vec)    (vector-ref  vec 2))
(define (db:testmeta-get-owner         vec)    (vector-ref  vec 3))
(define (db:testmeta-get-description   vec)    (vector-ref  vec 4))
(define (db:testmeta-get-reviewed      vec)    (vector-ref  vec 5))
(define (db:testmeta-get-iterated      vec)    (vector-ref  vec 6))
(define (db:testmeta-get-avg_runtime   vec)    (vector-ref  vec 7))
(define (db:testmeta-get-avg_disk      vec)    (vector-ref  vec 8))
(define (db:testmeta-get-tags          vec)    (vector-ref  vec 9))
(define (db:testmeta-set-id!           vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname!     vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author!       vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner!        vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description!  vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed!     vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated!     vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime!  vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk!     vec val)(vector-set! vec 8 val))

;;======================================================================
;; S I M P L E   R U N
;;======================================================================

;; (defstruct id  "runname" "state" "status" "owner" "event_time"

;;======================================================================
;; T E S T   D A T A 
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id               vec)    (vector-ref  vec 0))
(define (db:test-data-get-test_id          vec)    (vector-ref  vec 1))
(define (db:test-data-get-category         vec)    (vector-ref  vec 2))
(define (db:test-data-get-variable         vec)    (vector-ref  vec 3))
(define (db:test-data-get-value            vec)    (vector-ref  vec 4))
(define (db:test-data-get-expected         vec)    (vector-ref  vec 5))
(define (db:test-data-get-tol              vec)    (vector-ref  vec 6))
(define (db:test-data-get-units            vec)    (vector-ref  vec 7))
(define (db:test-data-get-comment          vec)    (vector-ref  vec 8))
(define (db:test-data-get-status           vec)    (vector-ref  vec 9))
(define (db:test-data-get-type             vec)    (vector-ref  vec 10))
(define (db:test-data-get-last_update      vec)    (vector-ref  vec 11))

(define (db:test-data-set-id!              vec val)(vector-set!  vec 0  val))
(define (db:test-data-set-test_id!         vec val)(vector-set!  vec 1  val))
(define (db:test-data-set-category!        vec val)(vector-set!  vec 2  val))
(define (db:test-data-set-variable!        vec val)(vector-set!  vec 3  val))
(define (db:test-data-set-value!           vec val)(vector-set!  vec 4  val))
(define (db:test-data-set-expected!        vec val)(vector-set!  vec 5  val))
(define (db:test-data-set-tol!             vec val)(vector-set!  vec 6  val))
(define (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
(define (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
(define (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
(define (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define (tdb:step-get-comment         vec)    (vector-ref  vec 7))
(define (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
(define (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; ;; The data structure for handing off requests via wire
;; (define (make-cdb:packet)(make-vector 6))
;; (define (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
;; (define (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
;; (define (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
;; (define (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
;; (define (cdb:packet-get-params       vec)    (vector-ref  vec 4))
;; (define (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
;; (define (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
;; (define (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
;; (define (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
;; (define (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
;; (define (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
;; (define (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))

;;======================================================================
;; key_records
;;======================================================================

(define (keys->valslots keys) ;; => ?,?,? ....
  (string-intersperse (map (lambda (x) "?") keys) ","))

;; (define (keys->key/field keys . additional)
;;   (string-join (map (lambda (k)(conc k " TEXT"))
;; 		    (append keys additional)) ","))

(define (item-list->path itemdat)
  (if (list? itemdat)
      (string-intersperse  (map cadr itemdat) "/")
      ""))


;;======================================================================
;; test_records
;;======================================================================

;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 7 #f))
(define (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))
(define (tests:testqueue-get-item_path    vec)    (vector-ref  vec 6))

(define (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))
(define (tests:testqueue-set-item_path!   vec val)(vector-set! vec 6 val))


)