;;======================================================================
;; 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 processmod))
(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)
;; (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
((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)
)))) ;; )
;; (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)
(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 ""))
)