Megatest: Check-in [927cc58fa5]

Overview

Comment:	wip
Downloads:	Tarball \| ZIP archive \| SQL archive
Timelines:	family \| ancestors \| descendants \| both \| v1.6584-ck5
Files:	files \| file ages \| folders
SHA1:	927cc58fa5cb92e806670e4a68595d4e3b992dff
User & Date:	matt on 2021-04-11 22:59:56
Other Links:	branch diff \| manifest \| tags

Context

2021-04-12
01:04		wip check-in: 343bb924b9 user: matt tags: v1.6584-ck5
2021-04-11
22:59		wip check-in: 927cc58fa5 user: matt tags: v1.6584-ck5
19:48		commonmod and configmod done (mostly). check-in: 22e558a91c user: matt tags: v1.6584-ck5

Changes

Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified Makefile from [1e54314082] to [311ed20e61].

Modified api.scm from [a67aba3194] to [fe0670e24e].

Modified apimod.scm from [dc935cc366] to [e64577bdff].

Modified commonmod.scm from [1ddd60f72c] to [cb87ea5160].

Modified configfmod.scm from [d26d1d864a] to [db89810c48].

Modified dbmod.scm from [53ec91b1b0] to [1f28f31581].

Modified items.scm from [4777d396de] to [9baef2182e].

Added itemsmod.scm version [2c28ce118c].

Modified keys.scm from [6b0d666bea] to [7ccee887c9].

Added keysmod.scm version [7968275505].

Modified launch.scm from [914613830c] to [7a003a7e1f].

Deleted megatest-version.scm version [1b7155b24b].

Modified megatest.scm from [de12fbde81] to [38f8c22333].

Modified mt.scm from [872eb49e64] to [d039907f51].

Added mtmod.scm version [cbfcb5b3d1].

Modified rmt.scm from [8d300a7bd3] to [eab390880b].

Modified rmtmod.scm from [cb38f42270] to [10ab3c5767].

Modified server.scm from [c998f525fa] to [45c2c522e6].

Modified servermod.scm from [6e736887de] to [42471562b8].

Modified tasks.scm from [a6c2485239] to [ac7ebb4346].

Added tasksmod.scm version [620f29b153].

Modified tdb.scm from [c7832c1d4c] to [dba21185d8].

Modified tests.scm from [ef56b9a810] to [ee21381598].

Added testsmod.scm version [25f4896905].

︙
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38	24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40	- + + +	SRCFILES = # module source files MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \ cookie.scm mutils.scm mtargs.scm apimod.scm \ configfmod.scm commonmod.scm dbmod.scm rmtmod.scm \ debugprint.scm mtver.scm csv-xml.scm servermod.scm \ ~~hostinfo.scm adjutant.scm processmod.scm~~ hostinfo.scm adjutant.scm processmod.scm testsmod.scm \ itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \ tasksmod.scm pgdb.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o)
︙
48 49 50 51 52 53 54 55 56 57 ~~58 59~~ 60 61 62 63 64 65 66	50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77	+ - + + + - - + + + + + + + +	mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o # module dependencies mofiles/stml2.o : mofiles/cookie.o mofiles/dbi.o mofiles/dbi.o : mofiles/autoload.o mofiles/testsmod.o mofiles/apimod.o : mofiles/commonmod.o ~~mofiles/~~apimod.o mofiles/~~dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o~~ mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/mtmod.o : mofiles/debugprint.o mofiles/dbmod.o : mofiles/csv-xml.o mofiles/keysmod.o mofiles/mtmod.o mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o \ ~~mofiles/m~~egatest-version~~.o mofiles/processmod.o \ mofiles/configfmod.o~~ mofiles/mtver.o mofiles/processmod.o \ mofiles/configfmod.o mofiles/itemsmod.o mofiles/testmod.o : mofiles/rmtmod.o mofiles/rmtmod.o : mofiles/apimod.o mofiles/apimod.o : mofiles/tasksmod.o mofiles/tasksmod.o : mofiles/pgdb.o dashboard.o megatest.o : db_records.scm megatest-fossil-hash.scm ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info\|grep checkout:\| awk '{print $$2}')
︙
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101	89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112	- + - + - +	# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) # all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt ~~mtest: readline-fix.scm megatest.scm $(MOFILES) $(MOIMPFILES) ~~megatest-version.scm~~~~ mtest: readline-fix.scm megatest.scm $(MOFILES) $(MOIMPFILES) csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.scm -o mtest showmtesthash: @echo $(MTESTHASH) ~~dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) ~~megatest-version.scm~~ megatest-fossil-hash.scm~~ dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-fossil-hash.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard ~~mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm ~~megatest-version.scm~~~~ mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut # include makefile.inc TCMTOBJS = \ api.o \ archive.o \
︙
124 125 126 127 128 129 130 ~~131~~ 132 133 134 135 136 137 138	135 136 137 138 139 140 141 142 143 144 145 146 147 148 149	- +	tests.o \ subrun.o \ ezsteps.o # mofiles/rmtmod.o \ # mofiles/commonmod.o \ ~~tcmt : $(TCMTOBJS) tcmt.scm ~~megatest-version.scm~~~~ tcmt : $(TCMTOBJS) tcmt.scm csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html mkdir -p $(PREFIX)/share/docs
︙
341 342 343 344 345 346 347 ~~348~~ 349 350 ~~351~~ 352 353 354 ~~355~~ 356 357 358 359 360 361 362	352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373	- + - + - +	sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) ~~datashare-testing/spublish : spublish.scm $(OFILES) ~~megatest-version.scm~~~~ datashare-testing/spublish : spublish.scm $(OFILES) csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish ~~datashare-testing/sretrieve : sretrieve.scm $(OFILES) ~~megatest-version.scm~~~~ datashare-testing/sretrieve : sretrieve.scm $(OFILES) csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve ~~datashare-testing/sauthorize : sauthorize.scm $(OFILES) ~~megatest-version.scm~~~~ datashare-testing/sauthorize : sauthorize.scm $(OFILES) csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize sauth-init: mkdir -p datashare-testing rm datashare-testing/sauthorize rm datashare-testing/sretrieve rm datashare-testing/spublish
︙

︙
23 24 25 26 27 28 29 30 31 32 33 34 35 36	23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39	+ + +	(declare (uses debugprint)) (declare (uses stml2)) (declare (uses pkts)) (declare (uses processmod)) (declare (uses mtargs)) (declare (uses configfmod)) ;; odd but it works? (declare (uses itemsmod)) (module commonmod * (import scheme chicken.base chicken.condition chicken.file
︙
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83	72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87	- + +	mtver debugprint stml2 pkts processmod (prefix mtargs args:) configfmod itemsmod ) ;;====================================================================== ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions
︙
96 97 98 99 100 101 102 103 104 105 106 107 108 109	100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141	+ + + + + + + + + + + + + + + + + + + + + + + + + + + +	(define home (getenv "HOME")) (define user (getenv "USER")) ;; Globals ;; (define server-loop-heart-beat (current-seconds)) ;; copied from egg call-with-environment-variables ;; (define (call-with-environment-variables variables thunk) ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk." ;; (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") ;; (thunk "The thunk to execute with a modified environment")) (let ((pre-existing-variables (map (lambda (var-value) (let ((var (car var-value))) (cons var (get-environment-variable var)))) variables))) (dynamic-wind (lambda () (void)) (lambda () ;; (use posix) (for-each (lambda (var-value) (setenv (car var-value) (cdr var-value))) variables) (thunk)) (lambda () (for-each (lambda (var-value) (let ((var (car var-value)) (value (cdr var-value))) (if value (setenv var value) (unsetenv var)))) pre-existing-variables))))) ;; 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)) (let ((fmod-time (handle-exceptions ext
︙
221 222 223 224 225 226 227 ~~228~~ 229 230 231 232 233 234 235	253 254 255 256 257 258 259 260 261 262 263 264 265 266 267	- +	(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 configdat #f) ;; megatest.config data ==> moved to configfmod (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
︙
1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838	1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880	+ + + + + + + + + +	(begin ;; (print "NO MATCH: " hed) (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) (define (launch:is-test-alive host pid) (if (and host pid (not (equal? host "n/a"))) (let* ((cmd (conc "ssh " host " pstree -A " pid)) (output (with-input-from-pipe cmd read-lines))) (debug:print 2 default-log-port "Running " cmd " received " output) (if (eq? (length output) 0) #f #t)) #t)) ;; common:get-host-info was here ;; common:update-host-loads-table ;; common:get-least-loaded-host ;; common:wait-for-homehost-load (define (common:get-num-cpus remote-host)
︙
1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962	1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224	+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +	(else (if (> num-tries 0) ;; should be "num-tries-left". (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host)) (debug:print 0 default-log-port "Load on " effective-host " is acceptable at effective normalized load of " normalized-effective-load " continuing.")) (debug:print 0 default-log-port "Load on " effective-host ", " first" could not be retrieved. Giving up and continuing.")))))) ;;====================================================================== ;; server process management ;;====================================================================== ;; no elegance here ... ;; (define (tasks:kill-server hostname pid #!key (kill-switch "")) (debug:print-info 0 default-log-port "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (let* ((logdir (if (directory-exists? "logs") "logs/" "")) (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f)) (gzfile (if logfile (conc logfile ".gz")))) (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) (system (conc "nbfake kill "kill-switch" "pid)) (when logfile (thread-sleep! 0.5) (if (file-exists? gzfile) (delete-file gzfile)) (system (conc "gzip " logfile)) (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")))) (define (server:get-logs-list area-path) (let* ((server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server--.log")) (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))) server-logs)) ;; get a list of servers with all relevant data ;; ( mod-time host port start-time pid ) ;; (define (server:get-list areapath #!key (limit #f)) (let ((fname-rx (regexp "^(\|./)server-(\\d+)-(\\S+).log$")) (day-seconds ( 24 60 60))) ;; if the directory exists continue to get the list ;; otherwise attempt to create the logs dir and then ;; continue (if (if (directory-exists? (conc areapath "/logs")) '() (if (file-writable? areapath) (begin (condition-case (create-directory (conc areapath "/logs") #t) (exn (i/o file)(debug:print 0 default-log-port "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 default-log-port "ERROR: Unknown error attemtping to get server list. exn=" exn))) (directory-exists? (conc areapath "/logs"))) '())) ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited. (let* ((server-logs (server:get-logs-list areapath)) (num-serv-logs (length server-logs))) (if (or (null? server-logs) (= num-serv-logs 0)) (let () (debug:print 1 default-log-port "There are no servers running") '() ) (let loop ((hed (string-chomp (car server-logs))) (tal (cdr server-logs)) (res '())) (let* ((mod-time (handle-exceptions exn (begin (debug:print 0 default-log-port "failed to get modification time on " hed ", exn=" exn) (current-seconds)) ;; 0 (file-modification-time hed))) ;; default to very old so log gets ignored if deleted (down-time (- (current-seconds) mod-time)) (serv-dat (if (or (< num-serv-logs 10) (< down-time 900)) ;; day-seconds)) (server:logf-get-start-info hed) '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at (serv-rec (cons mod-time serv-dat)) (fmatch (string-match fname-rx hed)) (pid (if fmatch (string->number (list-ref fmatch 2)) #f)) (new-res (if (null? serv-dat) res (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let (if (null? tal) (if (and limit (> (length new-res) limit)) new-res ;; (take new-res limit) <= need intelligent sorting before this will work new-res) (loop (string-chomp (car tal)) (cdr tal) new-res))))))))) (define (server:get-num-alive srvlst) (let ((num-alive 0)) (for-each (lambda (server) (handle-exceptions exn (begin (debug:print-info 0 default-log-port "Unable to get server start-time and/or mod-time from " server ", exn=" exn)) (match-let (((mod-time host port start-time server-id pid) server)) (let* ((uptime (- (current-seconds) mod-time)) (runtime (if start-time (- mod-time start-time) 0))) (if (< uptime 5)(set! num-alive (+ num-alive 1))))))) srvlst) num-alive)) ;; given a list of servers get a list of valid servers, i.e. at least ;; 10 seconds old, has started and is less than 1 hour old and is ;; active (i.e. mod-time < 10 seconds ;; ;; mod-time host port start-time pid ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off ;; and servers should stick around for about two hours or so. ;; (define (server:get-best srvlst) (let* ((nums (server:get-num-servers)) (now (current-seconds)) (slst (sort (filter (lambda (rec) (if (and (list? rec) (> (length rec) 2)) (let ((start-time (list-ref rec 3)) (mod-time (list-ref rec 0))) ;; (print "start-time: " start-time " mod-time: " mod-time) (and start-time mod-time (> (- now start-time) 0) ;; been running at least 0 seconds (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds (or (not (configf:lookup configdat "server" "runtime")) ;; skip if not set (< (- now start-time) (+ (- (string->number (configf:lookup configdat "server" "runtime")) 180) (pseudo-random-integer 360)))) ;; under one hour running time +/- 180 )) #f)) srvlst) (lambda (a b) (< (list-ref a 3) (list-ref b 3)))))) (if (> (length slst) nums) (take slst nums) slst))) (define (server:get-first-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and srvrs (not (null? srvrs))) (car srvrs) #f))) (define (server:get-rand-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and (list? srvrs) (not (null? srvrs))) (let* ((len (length srvrs)) (idx (pseudo-random-integer len))) (list-ref srvrs idx)) #f))) (define (server:record->id servr) (handle-exceptions exn (begin (debug:print-info 0 default-log-port "Unable to get server id from " servr ", exn=" exn) #f) (match-let (((mod-time host port start-time server-id pid) servr)) (if server-id server-id #f)))) (define (server:get-num-servers #!key (numservers 2)) (let ((ns (string->number (or (configf:lookup configdat "server" "numservers") "notanumber")))) (or ns numservers))) ;; given a path to a server log return: host port startseconds ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let (define (server:logf-get-start-info logf) (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+)")) ;; SERVER STARTED: host:port AT timesecs server id (dbprep-rx (regexp "^SERVER: dbprep")) (dbprep-found 0)) (handle-exceptions exn (begin (debug:print-info 0 default-log-port "Unable to get server info from " logf ", exn=" exn) (list #f #f #f #f)) ;; no idea what went wrong, call it a bad server (with-input-from-file logf (lambda () (let loop ((inl (read-line)) (lnum 0)) (if (not (eof-object? inl)) (let ((mlst (string-match server-rx inl)) (dbprep (string-match dbprep-rx inl)) ) (if dbprep (set! dbprep-found 1) ) (if (not mlst) (if (< lnum 500) ;; give up if more than 500 lines of server log read (loop (read-line)(+ lnum 1)) (begin (debug:print-info 0 default-log-port "Unable to get server info from first 500 lines of " logf ) (list #f #f #f #f))) (let ((dat (cdr mlst))) (list (car dat) ;; host (string->number (cadr dat)) ;; port (string->number (caddr dat)) (cadr (cddr dat)))))) (begin (if dbprep-found (begin (debug:print-info 0 default-log-port "Server is in dbprep at " (current-seconds)) (thread-sleep! 25) ) (debug:print-info 0 default-log-port "Unable to get server info from " logf " at " (current-seconds)) ) (list #f #f #f #f))))))))) ;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; ;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5)) ;; (let* ((loadavg (common:get-cpu-load remote-host)) ;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again
︙
3102 3103 3104 3105 3106 3107 3108 3109 ~~3110~~	3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541	+ + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +	;; (debug:print-info 0 default-log-port "common-telemetry-log closure failure") ;; ) ;; (begin ;; (define common:telemetry-log-state 'closed) ;; (udp-close-socket common:telemetry-log-socket) ;; (set! common:telemetry-log-socket #f))))) ;;====================================================================== ;; test patt stuff ;;====================================================================== ;; 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))) ) (define glob-like-match-cache (make-hash-table)) (define (tests:cache-regexp str-in flag) (let* ((key (conc str-in flag))) (or (hash-table-ref/default glob-like-match-cache key #f) (let* ((newrx (regexp str-in flag))) (hash-table-set! glob-like-match-cache key newrx) newrx)))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let* ((like (substring-index "%" patt)) (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))) (rx (tests:cache-regexp finpatt (if like #t #f))) (res (string-match rx 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)) ;; 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 ;; if either is a list and none is a proc go ahead and call get-items ;; otherwise return #f - this is not an iterated test (cond ((procedure? items) (debug:print-info 4 default-log-port "items is a procedure, will calc later") items) ;; calc later ((procedure? itemstable) (debug:print-info 4 default-log-port "itemstable is a procedure, will calc later") itemstable) ;; calc later ((filter (lambda (x) (let ((val (car x))) (if (procedure? val) val #f))) (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now (debug:print-info 4 default-log-port "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated (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")))))) )

︙
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ~~34 35~~ 36 37 38 ~~39 40 41 42 43 44 45~~ 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61	19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80	+ + + + - + - - + + + + + + - - - - - - - + + + + + + + + + + + + + + + + + - + +	;;====================================================================== (declare (unit dbmod)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses mtargs)) (declare (uses mtver)) (declare (uses csv-xml)) (declare (uses keysmod)) (declare (uses mtmod)) (module dbmod * (import scheme ~~chicken.base~~ (prefix sqlite3 sqlite3:) chicken.base chicken.condition ~~chicken.~~process-context.posix~~ chicken.st~~ring~~~~ chicken.file chicken.file.posix chicken.format chicken.io chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context ~~chicken.~~file~~ chicken.~~time~~ chicken.fi~~le.posix~~ chicken.~~format~~ chicken.~~sort~~ ~~typed-records~~~~ chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.time.posix (prefix base64 base64:) csv-xml directory-utils matchable regex s11n srfi-1 srfi-13 srfi-18 srfi-69 stack typed-records z3 (prefix mtargs args:) commonmod configfmod debugprint keysmod ~~(prefix mtargs args:)~~ mtmod mtver ) ;;====================================================================== ;; Database access ;;======================================================================
︙
70 71 72 73 74 75 76 ~~77 78~~ 79 80 81 82 83 84 85	89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105	+ - - + +	;; (declare (uses common)) ;; (declare (uses keys)) ;; (declare (uses ods)) ;; (declare (uses client)) ;; (declare (uses mt)) ;; ;; (include "common_records.scm") ~~;; (include "db_records.scm") ;; (include "key_records.scm")~~ (include "db_records.scm") (include "key_records.scm") ;; (include "run_records.scm") (define number-of-writes 0) (define number-non-write-queries 0) ;;====================================================================== ;; R E C O R D S
︙
436 437 438 439 440 441 442 ~~443~~ 444 445 446 447 448 449 450	456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471	+ - +	(define (db:setup do-sync #!key (areapath #f)) ;; (cond (dbstruct-db dbstruct-db);; TODO: when multiple areas are supported, this optimization will be a hazard (else ;;(common:on-homehost?) (debug:print-info 13 default-log-port "db:setup entered (first time, not cached.)") (let* ((dbstruct (make-dbr:dbstruct))) (assert toppath "ERROR: db:setup called before launch:setup. This is fatal.") ~~(when (not toppath)~~ #;(when (not toppath) (debug:print-info 13 default-log-port "in db:setup, toppath not set; calling launch:setup") (launch:setup areapath: areapath)) (debug:print-info 13 default-log-port "Begin db:open-db") (db:open-db dbstruct areapath: areapath do-sync: do-sync) (debug:print-info 13 default-log-port "Done db:open-db") (set! dbstruct-db dbstruct) ;;(debug:print-info 13 default-log-port "new dbstruct = "(dbr:dbstruct->alist dbstruct))
︙
1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 ~~1053~~ 1054 1055 1056 1057 1058 1059 1060	1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082	+ - +	;; (apply db:call-with-cached-db db-cmd params) (apply rmt-cmd params)) ;;) ;; return the target db handle so it can be used ;; (define (db:cache-for-read-only source target #!key (use-last-update #f)) (assert toppath "ERROR: db:cache-for-read-only called before launch:setup. This is fatal.") (if (and (hash-table-ref/default global-db-store target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref global-db-store target) ~~(let* ((toppath (launch:setup))~~ (let* ((toppath toppath) ;; (launch:setup)) (targ-db-last-mod (if (common:file-exists? target) (file-modification-time target) 0)) (cache-db (or (hash-table-ref/default global-db-store target #f) (db:open-megatest-db path: target))) (source-db (db:open-megatest-db path: source)) (curr-time (current-seconds))
︙
1116 1117 1118 1119 1120 1121 1122 ~~1123~~ 1124 1125 1126 1127 1128 1129 1130	1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152	- +	(refndb (dbr:dbstruct-refndb dbstruct)) (allow-cleanup #t) ;; (if run-ids #f #t)) (servers (server:get-list toppath)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))) (data-synced 0)) ;; count of changed records (I hope) (for-each (lambda (option) (case option ;; kill servers ((killservers) (for-each (lambda (server) (handle-exceptions exn
︙
1353 1354 1355 1356 1357 1358 1359 ~~1360~~ 1361 1362 1363 1364 1365 1366 1367	1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390	+ - +	(for-each (lambda (key) (if (equal? (car key) trigger-name) (sqlite3:execute db (cadr key)))) db:trigger-list))) (define (db:initialize-main-db dbdat) (assert configinfo "ERROR: db:initialize-main-db called before configfiles loaded. This is fatal.") ~~(when (not configinfo)~~ #;(when (not configinfo) (launch:setup)) ;; added because Elena was getting stack dump because configinfo below was #f. (let* ((configdat (car configinfo)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys:make-key/field-string configdat)) (db (db:dbdat-get-db dbdat)))
︙
1963 1964 1965 1966 1967 1968 1969 ~~1970~~ 1971 1972 1973 1974 1975 1976 1977	1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001	+ - +	(db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) ;; call end of eud of run detection for posthook - from merge, is it needed? ;; (launch:end-of-run-check run-id) all-ids) ;;call end of eud of run detection for posthook ;; MATT: Moving this to rmt.scm - call right after calling find-and-mark-complete ~~(launch:end-of-run-check run-id)~~ ;; (launch:end-of-run-check run-id) ))))))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
︙
2364 2365 2366 2367 2368 2369 2370 ~~2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384~~ 2385 2386 2387 2388 2389 2390 2391	2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401	- - - - - - - - - - - - - -	;; 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))
︙
4909 4910 4911 4912 4913 4914 4915 4916 4917 4918	4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424	+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +	(tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) ))))) ;;====================================================================== ;; tdb stuff ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== ;; (require-extension (srfi 18) extras tcp) ;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) ;; (import (prefix sqlite3 sqlite3:)) ;; (import (prefix base64 base64:)) ;; ;; (declare (unit tdb)) ;; (declare (uses common)) ;; (declare (uses keys)) ;; (declare (uses ods)) ;; (declare (uses client)) ;; (declare (uses mt)) ;; (declare (uses db)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") ;; (include "run_records.scm") ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; ;;====================================================================== ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) ;; ;; Moved these tables into <runid>.db ;; THIS CODE TO BE REMOVED ;; ;; (define (open-test-db work-area) ;; (debug:print-info 11 default-log-port "open-test-db " work-area) ;; (if (and work-area ;; (directory? work-area) ;; (file-readable? work-area)) ;; (let* ((dbpath (conc work-area "/testdat.db")) ;; (dbexists (common:file-exists? dbpath)) ;; (work-area-writeable (file-writable? work-area)) ;; (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem ;; exn ;; (begin ;; (print-call-chain (current-error-port)) ;; (debug:print 2 default-log-port "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ;; ((condition-property-accessor 'exn 'message) exn)) ;; (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery ;; (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access ;; (if (or work-area-writeable ;; dbexists) ;; (sqlite3:open-database dbpath) ;; (sqlite3:open-database ":memory:")))) ;; (tdb-writeable (and (file-writable? work-area) ;; (file-writable? dbpath))) ;; (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") ;; (string->number (args:get-arg "-override-timeout")) ;; 136000)))) ;; ;; (if (and tdb-writeable ;; db-write-access) ;; (sqlite3:set-busy-handler! db handler)) ;; (if (not dbexists) ;; (begin ;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") ;; (debug:print-info 11 default-log-port "Initialized test database " dbpath) ;; (tdb:testdb-initialize db))) ;; ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; (debug:print-info 11 default-log-port "open-test-db END (sucessful)" work-area) ;; ;; now let's test that everything is correct ;; (handle-exceptions ;; exn ;; (begin ;; (print-call-chain (current-error-port)) ;; (debug:print-error 0 default-log-port "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " ;; dbpath ".\n " ;; ((condition-property-accessor 'exn 'message) exn)) ;; #f) ;; ;; Is there a cheaper single line operation that will check for existance of a table ;; ;; and raise an exception ? ;; (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) ;; db) ;; ;; no work-area or not readable - create a placeholder to fake rest of world out ;; (let ((baddb (sqlite3:open-database ":memory:"))) ;; (debug:print-info 11 default-log-port "open-test-db END (unsucessful)" work-area) ;; ;; provide an in-mem db (this is dangerous!) ;; (tdb:testdb-initialize baddb) ;; baddb))) ;; ;; find and open the testdat.db file for an existing test ;; (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) ;; (let* ((test-path (if work-area ;; work-area ;; (rmt:test-get-rundir-from-test-id test-id)))) ;; (debug:print 3 default-log-port "TEST PATH: " test-path) ;; (open-test-db test-path))) ;; ;; ;; find and open the testdat.db file for an existing test ;; (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) ;; (let* ((test-path (if work-area ;; work-area ;; (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) ;; (debug:print 3 default-log-port "TEST PATH: " test-path) ;; (open-test-db test-path))) ;; ;; ;; find and open the testdat.db file for an existing test ;; (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) ;; (let* ((test-path (if work-area ;; work-area ;; (db:test-get-rundir-from-test-id dbstruct run-id test-id))) ;; (tdb (open-test-db test-path))) ;; (apply proc tdb params))) ;; (define (tdb:testdb-initialize db) ;; (debug:print 11 default-log-port "db:testdb-initialize START") ;; (sqlite3:with-transaction ;; db ;; (lambda () ;; (for-each ;; (lambda (sqlcmd) ;; (sqlite3:execute db sqlcmd)) ;; (list "CREATE TABLE IF NOT EXISTS test_rundat ( ;; id INTEGER PRIMARY KEY, ;; update_time TIMESTAMP, ;; cpuload INTEGER DEFAULT -1, ;; diskfree INTEGER DEFAULT -1, ;; diskusage INTGER DEFAULT -1, ;; run_duration INTEGER DEFAULT 0);" ;; "CREATE TABLE IF NOT EXISTS test_data ( ;; id INTEGER PRIMARY KEY, ;; test_id INTEGER, ;; category TEXT DEFAULT '', ;; variable TEXT, ;; value REAL, ;; expected REAL, ;; tol REAL, ;; units TEXT, ;; comment TEXT DEFAULT '', ;; status TEXT DEFAULT 'n/a', ;; type TEXT DEFAULT '', ;; CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" ;; "CREATE TABLE IF NOT EXISTS test_steps ( ;; id INTEGER PRIMARY KEY, ;; test_id INTEGER, ;; stepname TEXT, ;; state TEXT DEFAULT 'NOT_STARTED', ;; status TEXT DEFAULT 'n/a', ;; event_time TIMESTAMP, ;; comment TEXT DEFAULT '', ;; logfile TEXT DEFAULT '', ;; CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" ;; ;; test_meta can be used for handing commands to the test ;; ;; e.g. KILLREQ ;; ;; the ackstate is set to 1 once the command has been completed ;; "CREATE TABLE IF NOT EXISTS test_meta ( ;; id INTEGER PRIMARY KEY, ;; var TEXT, ;; val TEXT, ;; ackstate INTEGER DEFAULT 0, ;; CONSTRAINT metadat_constraint UNIQUE (var));")))) ;; (debug:print 11 default-log-port "db:testdb-initialize END")) ;; This routine moved to db:read-test-data ;; (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) tdb "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (sqlite3:finalize! tdb) (reverse res))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== ;; ;; get a list of test_data records matching categorypatt ;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f)) ;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) ;; (if (sqlite3:database? tdb) ;; (let ((res '())) ;; (sqlite3:for-each-row ;; (lambda (id test_id category variable value expected tol units comment status type) ;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) ;; tdb ;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) ;; (sqlite3:finalize! tdb) ;; (reverse res)) ;; '()))) (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (tdb:step-get-time-as-string vec) (seconds->time-string (tdb:step-get-event_time vec))) ;; get a pretty table to summarize steps ;; ;; NOT USED, WILL BE REMOVED ;; (define (tdb:get-steps-table steps);; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 default-log-port "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile (vector (tdb:step-get-stepname step) "" "" "" "" "")))) (debug:print 6 default-log-port "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) (debug:print 4 default-log-port "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 default-log-port "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) (sort steps (lambda (a b) (cond ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) ;; Move this to steps.scm ;; ;; get a pretty table to summarize steps ;; (define (tdb:get-steps-table-list steps) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 default-log-port "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status (vector (tdb:step-get-stepname step) "" "" "" "" "")))) (debug:print 6 default-log-port "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) (debug:print 4 default-log-port "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 default-log-port "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) (sort steps (lambda (a b) (cond ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) ;; ;; Move to steps.scm ;; (define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) (vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) (string<? (conc (vector-ref a 2)) (conc (vector-ref b 2))) #f)) (string<? (conc time-a)(conc time-b)))))))) ;; ;; (define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes) ;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) ;; (if (sqlite3:database? tdb) ;; (begin ;; (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" ;; cpuload diskfree minutes) ;; (sqlite3:finalize! tdb)) ;; (debug:print 2 default-log-port "Can't update testdat.db for test " test-id " read-only or non-existant")))) ;; ;; ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status) ;; Putting the commandline into ( )'s means no control over the shell. ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files ;; or equivalent. No need to do this. Just run it? (let* ((fullcmd (conc "nbfake " cmd " " test-id " " test-rundir " " trigger " " test-name " " item-path " " ;; has / prepended to deal with toplevel tests actual-state " " actual-status " " event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) (file-writable? test-rundir)) test-rundir) ((and (directory-exists? toppath) (file-writable? toppath)) toppath) (else (conc "/tmp/" (current-user-name)))) "/" logname)) (debug:print-info 0 default-log-port "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG")) ;; (call-with-environment-variables ;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname))) ;; (lambda () (process-run fullcmd) (if prev-nbfake-log (setenv "NBFAKE_LOG" prev-nbfake-log) (unsetenv "NBFAKE_LOG")) )) ;; )) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat (let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (duration (db:test-get-run_duration test-dat)) (comment (db:test-get-comment test-dat)) (event-time (db:test-get-event_time test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) ;; (mutex-lock! triggers-mutex) (handle-exceptions exn (begin (debug:print-error 0 default-log-port " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn "\n test-rundir="test-rundir "\n test-name="test-name "\n item-path="item-path "\n state="state "\n status="status "\n") (print-call-chain (current-error-port)) #f) (if (and test-name test-rundir) ;; #f means no dir set yet ;; (common:file-exists? test-rundir) ;; (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" (or test-name "no such test")) (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) (cons "MT_ITEMPATH" (or item-path ""))) (lambda () (if (directory-exists? test-rundir) (push-directory test-rundir) (push-directory toppath)) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let* ((munged-trigger (string-translate trigger "/ " "--")) (logname (conc "last-trigger-" munged-trigger ".log"))) ;; first any triggers from the testconfig (let ((cmd (configf:lookup tconfig "triggers" trigger))) (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status))) ;; next any triggers from megatest.config (let ((cmd (configf:lookup configdat "triggers" trigger))) (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status))))) (list (conc state "/" status) (conc state "/") (conc "/" status))) (pop-directory)) ))) ;; (mutex-unlock! triggers-mutex) ))))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default testconfigs test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path configdat))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (common:file-exists? tconfig-file) (file-readable? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup configdat "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! testconfigs test-name newtcfg) (if old-link-tree (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin (debug:print-error 0 default-log-port "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) )

︙
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241	131 132 133 134 135 136 137 138 139 140 141 142 143 144	- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -	(cdr remt) (if (member failed-test waitons) (begin (debug:print 0 default-log-port "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ~~;;======================================================================~~ ~~;; T R I G G E R S~~ ~~;;======================================================================~~ ~~(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status)~~ ~~;; Putting the commandline into ( )'s means no control over the shell.~~ ~~;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files~~ ~~;; or equivalent. No need to do this. Just run it?~~ ~~(let* ((fullcmd (conc "nbfake "~~ ~~cmd " "~~ ~~test-id " "~~ ~~test-rundir " "~~ ~~trigger " "~~ ~~test-name " "~~ ~~item-path " " ;; has / prepended to deal with toplevel tests~~ ~~actual-state " "~~ ~~actual-status " "~~ ~~event-time~~ )) ~~(prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))~~ ~~(setenv "NBFAKE_LOG" (conc (cond~~ ~~((and (directory-exists? test-rundir)~~ ~~(file-writable? test-rundir))~~ ~~test-rundir)~~ ~~((and (directory-exists? toppath)~~ ~~(file-writable? toppath))~~ toppath) ~~(else (conc "/tmp/" (current-user-name))))~~ ~~"/" logname))~~ ~~(debug:print-info 0 default-log-port "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))~~ ~~;; (call-with-environment-variables~~ ~~;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))~~ ~~;; (lambda ()~~ ~~(process-run fullcmd)~~ ~~(if prev-nbfake-log~~ ~~(setenv "NBFAKE_LOG" prev-nbfake-log)~~ ~~(unsetenv "NBFAKE_LOG"))~~ ~~)) ;; ))~~ ~~(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)~~ ~~(if test-id~~ ~~(let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))~~ ~~(if test-dat~~ ~~(let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; )~~ ~~(test-name (db:test-get-testname test-dat))~~ ~~(item-path (db:test-get-item-path test-dat))~~ ~~(duration (db:test-get-run_duration test-dat))~~ ~~(comment (db:test-get-comment test-dat))~~ ~~(event-time (db:test-get-event_time test-dat))~~ ~~(tconfig #f)~~ ~~(state (if newstate newstate (db:test-get-state test-dat)))~~ ~~(status (if newstatus newstatus (db:test-get-status test-dat))))~~ ~~;; (mutex-lock! triggers-mutex)~~ ~~(handle-exceptions~~ ~~exn~~ ~~(begin~~ ~~(debug:print-error 0 default-log-port " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus~~ ~~"\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn~~ ~~"\n test-rundir="test-rundir~~ ~~"\n test-name="test-name~~ ~~"\n item-path="item-path~~ ~~"\n state="state~~ ~~"\n status="status~~ ~~"\n")~~ ~~(print-call-chain (current-error-port))~~ ~~#f)~~ ~~(if (and test-name~~ ~~test-rundir) ;; #f means no dir set yet~~ ~~;; (common:file-exists? test-rundir)~~ ~~;; (directory? test-rundir))~~ ~~(call-with-environment-variables~~ ~~(list (cons "MT_TEST_NAME" (or test-name "no such test"))~~ ~~(cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))~~ ~~(cons "MT_ITEMPATH" (or item-path "")))~~ ~~(lambda ()~~ ~~(if (directory-exists? test-rundir)~~ ~~(push-directory test-rundir)~~ ~~(push-directory toppath))~~ ~~(set! tconfig (mt:lazy-read-test-config test-name))~~ ~~(for-each (lambda (trigger)~~ ~~(let* ((munged-trigger (string-translate trigger "/ " "--"))~~ ~~(logname (conc "last-trigger-" munged-trigger ".log")))~~ ~~;; first any triggers from the testconfig~~ ~~(let ((cmd (configf:lookup tconfig "triggers" trigger)))~~ ~~(if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))~~ ~~;; next any triggers from megatest.config~~ ~~(let ((cmd (configf:lookup configdat "triggers" trigger)))~~ ~~(if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))~~ ~~(list~~ ~~(conc state "/" status)~~ ~~(conc state "/")~~ ~~(conc "/" status)))~~ ~~(pop-directory))~~ ~~)))~~ ~~;; (mutex-unlock! triggers-mutex)~~ ~~)))))~~ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id))
︙
273 274 275 276 277 278 279 ~~280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305~~	176 177 178 179 180 181 182	- - - - - - - - - - - - - - - - - - - - - - - - - -	#t);) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) ~~(define (mt:lazy-read-test-config test-name)~~ ~~(let ((tconf (hash-table-ref/default testconfigs test-name #f)))~~ ~~(if tconf~~ ~~tconf~~ ~~(let ((test-dirs (tests:get-tests-search-path configdat)))~~ ~~(let loop ((hed (car test-dirs))~~ ~~(tal (cdr test-dirs)))~~ ~~;; Setting MT_LINKTREE here is almost certainly unnecessary.~~ ~~(let ((tconfig-file (conc hed "/" test-name "/testconfig")))~~ ~~(if (and (common:file-exists? tconfig-file)~~ ~~(file-readable? tconfig-file))~~ ~~(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup configdat "setup" "linktree"))~~ ~~(old-link-tree (get-environment-variable "MT_LINKTREE")))~~ ~~(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))~~ ~~(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]~~ ~~(hash-table-set! testconfigs test-name newtcfg)~~ ~~(if old-link-tree~~ ~~(setenv "MT_LINKTREE" old-link-tree)~~ ~~(unsetenv "MT_LINKTREE"))~~ ~~newtcfg))~~ ~~(if (null? tal)~~ ~~(begin~~ ~~(debug:print-error 0 default-log-port "No readable testconfig found for " test-name)~~ ~~#f)~~ ~~(loop (car tal)(cdr tal))))))))))~~

︙
22 23 24 25 26 27 28 ~~29 30~~ 31 32 33 34 35 36 37	22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38	- - + + +	(declare (uses commonmod)) (declare (uses apimod)) (module rmtmod * (import scheme ~~(pr~~efix sqlite3 sqlite3:)~~~~ chicken.random (prefix sqlite3 sqlite3:) typed-records srfi-18 commonmod apimod )
︙
78 79 80 81 82 83 84 85	79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095	- + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +	(ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid params))) ;; need to call this on the other side ;; (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) #;(with-input-from-string (ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid (with-output-to-string (lambda ()(serialize params)))) (lambda ()(deserialize))) ) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm \| grep rmt: \|perl -pi -e 's/\(define\s+\((\S+)\W.$/\1/'\|sort -u ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; (define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. (let ((runremote (or area-dat runremote)) (cinfo (if (remote? runremote) (remote-conndat runremote) #f))) (if cinfo cinfo (if (server:check-if-running areapath) (client:setup areapath) #f)))) ;;====================================================================== (define send-receive-mutex (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (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))) (if (> attemptnum 2) (debug:print 0 default-log-port "INFO: attemptnum in rmt:send-receive is " attemptnum)) (cond ((> attemptnum 2) (thread-sleep! 0.053)) ((> attemptnum 10) (thread-sleep! 0.5)) ((> attemptnum 20) (thread-sleep! 1))) (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15))) (begin (server:run toppath) (thread-sleep! 3))) ;;DOT digraph megatest_state_status { ;;DOT ranksep=0; ;;DOT // rankdir=LR; ;;DOT node [shape="box"]; ;;DOT "rmt:send-receive" -> MUTEXLOCK; ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; } ;; 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)) (attemptnum (+ 1 attemptnum)) (readonly-mode (rmtmod:calc-ro-mode runremote toppath))) ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; ;; 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-init-remote)) (let* ((server-info (remote-server-info runremote))) (if server-info (begin (remote-server-url-set! runremote (server:record->url server-info)) (remote-server-id-set! runremote (server:record->id server-info))))) (set! runremote runremote))) ;; new runremote will come from this on next iteration ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"]; ;; DOT SET_HOMEHOST -> MUTEXLOCK; ;; 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 ;;DOT EXIT; ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" } ;; give up if more than 150 attempts ((> attemptnum 150) (debug:print 0 default-log-port "ERROR: 150 tries to start/connect to server. Giving up.") (exit 1)) ;;DOT CASE2 [label="local\nreadonly\nquery"]; ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2} ;;DOT CASE2 -> "rmt:open-qry-close-locally"; ;; 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) ) ;;DOT CASE3 [label="write in\nread-only mode"]; ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3} ;;DOT CASE3 -> "#f"; ;; 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) ;; ;;DOT CASE4 [label="reset\nconnection"]; ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} ;;DOT CASE4 -> "rmt:send-receive"; ;; 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)) ;;DOT CASE5 [label="local\nread"]; ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5}; ;;DOT CASE5 -> "rmt:open-qry-close-locally"; ;; 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)) ;;DOT CASE6 [label="init\nremote"]; ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6}; ;;DOT CASE6 -> "rmt:send-receive"; ;; 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) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. (set! runremote (make-init-remote)) (let* ((server-info (remote-server-info runremote))) (if server-info (begin (remote-server-url-set! runremote (server:record->url server-info)) (remote-server-id-set! runremote (server:record->id server-info))))) (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)) ;;DOT CASE7 [label="homehost\nwrite"]; ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7}; ;;DOT CASE7 -> "rmt:open-qry-close-locally"; ;; 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)) ;;DOT CASE8 [label="force\nserver"]; ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8}; ;;DOT CASE8 -> "rmt:open-qry-close-locally"; ;; 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-info (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-info (begin (remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed (remote-server-id-set! runremote (server:record->id server-info))) (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))) ;;DOT CASE9 [label="force server\nnot on homehost"]; ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9}; ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive"; ((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 ;;DOT CASE10 [label="on homehost"]; ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10}; ;;DOT CASE10 -> "rmt:open-qry-close-locally"; ;; 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)) ;;DOT CASE11 [label="send_receive"]; ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11}; ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"]; ;;DOT CASE11 -> "RESULT" [label="call succeeded"]; ;; not on homehost, do server query (else (extras-case-11 default-log-port runremote cmd params attemptnum rid))))) ;;DOT } ;; 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") ;; (mutex-lock! rmt-mutex) (let* ((conninfo (remote-conndat runremote)) (dat-in (case (remote-transport runremote) ((http) (condition-case ;; handling here has ;; caused a lot of ;; problems. However it ;; is needed to deal with ;; attemtped ;; communication to ;; servers that have gone ;; away (http-transport:client-api-send-receive 0 conninfo cmd params) ((servermismatch) (vector #f "Server id mismatch" )) ((commfail)(vector #f "communications fail")) ((exn)(vector #f "other fail" (print-call-chain))))) (else (debug:print 0 default-log-port "ERROR: transport " (remote-transport runremote) " not supported") (exit)))) ;; No Title ;; Error: (vector-ref) out of range ;; #(#<condition: (exn type)> (#("db.scm:3740: regex#regexp" #f #f) #("db.scm:3739: regex#string-substitute" #f #f) #("db.scm:3738: base64#base64-decode" #f #f) #("db.scm:3737: z3#z3:decode-buffer" #f #f) #("db.scm:3736: with-input-from-string" #f #f) #("db.scm:3741: s11n#deserialize" #f #f) #("api.scm:374: api:execute-requests" #f #f) #("api.scm:139: call-with-current-continuation" #f #f) #("api.scm:139: with-exception-handler" #f #f) #("api.scm:139: ##sys#call-with-values" #f #f) #("api.scm:158: string->symbol" #f #f) #("api.scm:160: current-milliseconds" #f #f) #("api.scm:161: dbr:dbstruct-read-only" #f #f) #("api.scm:139: k15" #f #f) #("api.scm:139: g19" #f #f) #("api.scm:142: get-call-chain" #f #f)) #("get-test-info-by-id" (1102 507299))) ;; 6 ;; ;; Call history: ;; ;; http-transport.scm:306: thread-terminate! ;; http-transport.scm:307: debug:print-info ;; common_records.scm:235: debug:debug-mode ;; rmt.scm:259: k587 ;; rmt.scm:259: g591 ;; rmt.scm:276: http-transport:server-dat-update-last-access ;; http-transport.scm:364: current-seconds ;; rmt.scm:282: debug:print-info ;; common_records.scm:235: debug:debug-mode ;; rmt.scm:283: mutex-unlock! ;; rmt.scm:287: extras-transport-succeded <-- ;; +-----------------------------------------------------------------------------+ ;; \| Exit Status : 70 ;; (dat (if (and (vector? dat-in) ;; ... check it is a correct size (> (vector-length dat-in) 1)) dat-in (vector #f (conc "communications fail (type 2), dat-in=" dat-in)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (and (vector? conninfo) (< 5 (vector-length conninfo))) (http-transport:server-dat-update-last-access conninfo) ;; refresh access time (begin (debug:print 0 default-log-port "INFO: Should not get here! conninfo=" conninfo) (set! conninfo #f) (remote-conndat-set! runremote #f) ;; NOTE: runremote is global copy of runremote. Purpose: factor out global. (http-transport:close-connections area-dat: runremote))) (debug:print-info 13 default-log-port "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) (mutex-unlock! rmt-mutex) (if success ;; success only tells us that the transport was ;; successful, have to examine the data to see if ;; there was a detected issue at the other end (extras-transport-succeded default-log-port rmt-mutex attemptnum runremote res params rid cmd) (begin (debug:print-error 0 default-log-port " dat=" dat) (extras-transport-failed default-log-port rmt-mutex attemptnum runremote cmd rid params)) ))) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 default-log-port "DB Stats\n========") (debug:print 18 default-log-port (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref db-stats cmd))) (debug:print 18 default-log-port (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys db-stats) (lambda (a b) (> (vector-ref (hash-table-ref db-stats a) 0) (vector-ref (hash-table-ref db-stats b) 0))))))) (define (rmt:get-max-query-average run-id) (mutex-lock! db-stats-mutex) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) (substring-index runkey x)) (hash-table-keys db-stats))) (res (if (null? cmds) (cons 'none 0) (let loop ((cmd (car cmds)) (tal (cdr cmds)) (max-cmd (car cmds)) (res 0)) (let* ((cmd-dat (hash-table-ref db-stats cmd)) (tot (vector-ref cmd-dat 0)) (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction (currmax (max res curravg)) (newmax-cmd (if (> curravg res) cmd max-cmd))) (if (null? tal) (if (> tot 10) (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! db-stats-mutex) res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-writable? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully (begin (debug:print 0 default-log-port "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record (vector #t '())))) ;; we could also check that the returned types are valid (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (debug:print 0 default-log-port "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 default-log-port "local query failed. Trying again.") (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 default-log-port "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! db-multi-sync-mutex) / (set! db-last-access start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! db-multi-sync-mutex))))) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (res (handle-exceptions exn (begin (print "transport failed. exn=" exn) #f) (http-transport:client-api-send-receive run-id connection-info cmd params)))) (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) ;;====================================================================== ;; ;; A C T U A L A P I C A L L S ;; ;;====================================================================== ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server run-id (list run-id))) (define (rmt:start-server run-id) (rmt:send-receive 'start-server 0 (list run-id))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) (rmt:send-receive 'login run-id (list toppath megatest-version my-client-signature))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; (define (rmt:login-no-auto-client-setup connection-info) (case transport-type ;; run-id of 0 is just a placeholder ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list toppath megatest-version my-client-signature))) ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list toppath megatest-version run-id my-client-signature))) )) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) ;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host (define (rmt:get-latest-host-load hostname) (rmt:send-receive 'get-latest-host-load 0 (list hostname))) (define (rmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr (rmt:send-receive 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) (define (rmt:get-run-record-ids target run keynames test-patt) (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt))) (define (rmt:get-changed-record-ids since-time) (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) (define (rmt:drop-all-triggers) (rmt:send-receive 'drop-all-triggers #f '())) (define (rmt:create-all-triggers) (rmt:send-receive 'create-all-triggers #f '())) ;;====================================================================== ;; T E S T M E T A ;;====================================================================== (define (rmt:get-tests-tags) (rmt:send-receive 'get-tests-tags #f '())) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; These require run-id because the values come from the run! ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) (if db-keys db-keys (let ((res (rmt:send-receive 'get-keys #f '()))) (set! db-keys res) res))) (define (rmt:get-keys-write) ;; dummy query to force server start (let ((res (rmt:send-receive 'get-keys-write #f '()))) (set! db-keys res) res)) ;; we don't reuse run-id's (except possibly after a db cleanup) so it is safe ;; to cache the resuls in a hash ;; (define (rmt:get-key-vals run-id) (or (hash-table-ref/default keyvals run-id #f) (let ((res (rmt:send-receive 'get-key-vals #f (list run-id)))) (hash-table-set! keyvals run-id res) res))) (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) (rmt:send-receive 'get-target run-id (list run-id))) (define (rmt:get-run-times runpatt targetpatt) (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar (define (rmt:register-test run-id test-name item-path) (rmt:general-call 'register-test run-id run-id test-name item-path)) (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) ;; run-id is NOT used ;; (define (rmt:get-test-info-by-id run-id test-id) (if (number? test-id) (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 default-log-port "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 default-log-port "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) ;; (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 default-log-port "rmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) (define (rmt:get-tests-for-run-state-status run-id testpatt last-update) (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids run-ids (rmt:get-all-run-ids))) (result '())) (if (null? run-id-list) '() (let loop ((hed (car run-id-list)) (tal (cdr run-id-list)) (threads '())) (if (> (length threads) 5) (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads)) (let* ((newthread (make-thread (lambda () (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) (debug:print-error 0 default-log-port "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.054) ;; give that thread some time to start (if (null? tal) newthreads (loop (car tal)(cdr tal) newthreads)))))) result)) ;; ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; ;; ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) ;; (let ((run-id-list (if run-ids ;; run-ids ;; (rmt:get-all-run-ids)))) ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) (define (rmt:test-set-state-status run-id test-id state status msg) (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (rmt:test-toplevel-num-items run-id test-name) (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (rmt:test-get-logfile-info run-id test-name) (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) (define (rmt:get-testinfo-state-status run-id test-id) (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (rmt:test-set-log! run-id test-id logf) (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-set-top-process-pid run-id test-id pid) (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (rmt:test-get-top-process-pid run-id test-id) (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) ;; NOTE: This will open and access ALL run databases. ;; (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (rmt:get-count-tests-running-for-run-id run-id) (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) (define (rmt:get-not-completed-cnt run-id) (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id) (rmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (rmt:get-count-tests-running-for-testname run-id testname) (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) (define (rmt:set-state-status-and-roll-up-run run-id state status) (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status))) (define (rmt:update-pass-fail-counts run-id test-name) (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) (define (rmt:get-raw-run-stats run-id) (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) (define (rmt:get-test-times runname target) (rmt:send-receive 'get-test-times #f (list runname target ))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) (rmt:send-receive 'get-run-info run-id (list run-id))) (define (rmt:get-num-runs runpatt) (rmt:send-receive 'get-num-runs #f (list runpatt))) (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys) (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys))) ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user contour) (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) (define (rmt:get-run-name-from-id run-id) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) (define (rmt:delete-run run-id) (rmt:send-receive 'delete-run run-id (list run-id))) (define (rmt:update-run-stats run-id stats) (rmt:send-receive 'update-run-stats #f (list run-id stats))) (define (rmt:delete-old-deleted-test-records) (rmt:send-receive 'delete-old-deleted-test-records #f '())) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (rmt:simple-get-runs runpatt count offset target last-update) (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update))) (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) (rmt:send-receive 'get-prev-run-ids #f (list run-id))) (define (rmt:lock/unlock-run run-id lock unlock user) (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (rmt:get-run-status run-id) (rmt:send-receive 'get-run-status #f (list run-id))) (define (rmt:get-run-state run-id) (rmt:send-receive 'get-run-state #f (list run-id))) (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-tesdata-on-repilcate-db old-lt new-lt) (rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime)) (launch:end-of-run-check run-id)) ;; ) (define (rmt:get-main-run-stats run-id) (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) (define (rmt:inc-var varname) (rmt:send-receive 'inc-var #f (list varname))) (define (rmt:dec-var varname) (rmt:send-receive 'dec-var #f (list varname))) (define (rmt:add-var varname value) (rmt:send-receive 'add-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (rmt:find-and-mark-incomplete run-id ovr-deadtime)) run-ids))) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this at the client end since we have to connect to multiple run-id dbs ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) (let* ((keyvals (rmt:get-key-val-pairs run-id)) (keys (rmt:get-keys)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (if (not keyvals) #f (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 default-log-port "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses #f #f #f ;; offset limit not-in hide/not-hide #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode (debug:print 4 default-log-port "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) (define (rmt:get-run-stats) (rmt:send-receive 'get-run-stats #f '())) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated. ;; ;; If given work area ;; 1. Find the testdat.db file ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 default-log-port "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:delete-steps-for-test! run-id test-id) (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) (define (rmt:get-steps-info-by-id test-step-id) (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt))) (define (rmt:get-data-info-by-id test-data-id) (rmt:send-receive 'get-data-info-by-id #f (list test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) (rmt:send-receive 'testmeta-get-record #f (list testname))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== (define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) (define (rmt:tasks-add action owner target runname testpatt params) (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) (define (rmt:tasks-get-last target runname) (rmt:send-receive 'tasks-get-last #f (list target runname))) ;;====================================================================== ;; N O S Y N C D B ;;====================================================================== (define (rmt:no-sync-set var val) (rmt:send-receive 'no-sync-set #f `(,var ,val))) (define (rmt:no-sync-get/default var default) (rmt:send-receive 'no-sync-get/default #f `(,var ,default))) (define (rmt:no-sync-del! var) (rmt:send-receive 'no-sync-del! #f `(,var))) (define (rmt:no-sync-get-lock keyname) (rmt:send-receive 'no-sync-get-lock #f `(,keyname))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) (define (rmt:archive-register-block-name bdisk-id archive-path) (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) (define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) (define (rmt:archive-register-disk bdisk-name bdisk-path df) (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) (define (rmt:test-set-archive-block-id run-id test-id archive-block-id) (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (rmt:test-get-archive-block-info archive-block-id) (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) (define (rmtmod:calc-ro-mode runremote toppath) (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote) (let* ((dbfile (conc toppath "/megatest.db")) (ro-mode (not (file-writable? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (remote-ro-mode-set! runremote ro-mode) (remote-ro-mode-checked-set! runremote #t) ro-mode) ro-mode)))) (define (extras-readonly-mode rmt-mutex log-port cmd params) (mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 3") (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) #f) (define (extras-transport-failed default-log-port rmt-mutex attemptnum runremote cmd rid params) (debug:print 0 default-log-port "WARNING: communication failed. Trying again, try num: " attemptnum) (mutex-lock! rmt-mutex) (remote-conndat-set! runremote #f) (http-transport:close-connections area-dat: runremote) (remote-server-url-set! runremote #f) (mutex-unlock! rmt-mutex) (debug:print-info 12 default-log-port "rmt:send-receive, case 9.1") (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) (define (extras-transport-succeded default-log-port rmt-mutex attemptnum runremote res params rid cmd) (if (and (vector? res) (eq? (vector-length res) 2) (eq? (vector-ref res 1) 'overloaded)) ;; since we are ;; looking at the ;; data to carry the ;; error we'll use a ;; fairly obtuse ;; combo to minimise ;; the chances of ;; some sort of ;; collision. this ;; is the case where ;; the returned data ;; is bad or the ;; server is ;; overloaded and we ;; want to ease off ;; the queries (let ((wait-delay (+ attemptnum (* attemptnum 10)))) (debug:print 0 default-log-port "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") (mutex-lock! rmt-mutex) (http-transport:close-connections area-dat: runremote) (set! runremote #f) ;; force starting over (mutex-unlock! rmt-mutex) (thread-sleep! wait-delay) (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) res)) ;; All good, return res #;(set-functions rmt:send-receive remote-server-url-set! http-transport:close-connections remote-conndat-set! debug:print debug:print-info remote-ro-mode remote-ro-mode-set! remote-ro-mode-checked-set! remote-ro-mode-checked) )










































































































































































































































































1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266	+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +	;;====================================================================== ;; 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 itemsmod)) (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses configfmod)) (module itemsmod * (import scheme chicken.base chicken.condition chicken.file chicken.io chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context chicken.sort chicken.string chicken.time debugprint mtargs pkts (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) (srfi 18) directory-utils format matchable md5 message-digest regex regex-case sparse-vectors srfi-1 srfi-13 srfi-69 stack typed-records z3 configfmod ) ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) ;; (declare (unit items)) ;; (declare (uses common)) ;; ;; (include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) (let loop ((hed (car itemlist)) (tal (cdr itemlist))) (if (null? tal) (for-each (lambda (item) (if (> (length curritemkey) (- hierdepth 2)) (set! res (append res (list (append curritemkey (list (list (car hed) item)))))))) (cadr hed)) (begin (for-each (lambda (item) (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal)))) (cadr hed)) (loop (car tal)(cdr tal))))) res)) ;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall"))) ;; => ((("ANIMAL" "Elephant") ("SEASON" "Spring")) ;; (("ANIMAL" "Elephant") ("SEASON" "Fall")) ;; (("ANIMAL" "Lion") ("SEASON" "Spring")) ;; (("ANIMAL" "Lion") ("SEASON" "Fall"))) (define (item-assoc->item-list itemsdat) (if (and itemsdat (not (null? itemsdat))) (let ((itemlst (filter (lambda (x) (list? x)) (map (lambda (x) (debug:print 6 default-log-port "item-assoc->item-list x: " x) (if (< (length x) 2) (begin (debug:print-error 0 default-log-port "malformed items spec " (string-intersperse x " ")) (list (car x)'())) (let* ((name (car x)) (items (cadr x)) (ilist (list name (if (string? items) (string-split items) '())))) (if (null? ilist) (debug:print-error 0 default-log-port "No items specified for " name)) ilist))) itemsdat)))) (let ((debuglevel 5)) (debug:print 5 default-log-port "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin (pp itemsdat) (print " => ") (pp itemlst)))) (if (> (length itemlst) 0) (process-itemlist #f '() itemlst) '())) '())) ;; return a list consisting on a single null list for non-item runs ;; Nope, not now, return null as of 6/6/2011 ;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))) ;; => ((("ANIMAL" "Elephant")("SEASON" "Spring")) ;; (("ANIMAL" "Lion") ("SEASON" "Winter"))) (define (item-table->item-list itemtable) (let ((newlst (map (lambda (x) (if (> (length x) 1) (list (car x) (string-split (cadr x))) (list x '()))) itemtable)) (res '())) ;; a list of items (let loop ((indx 0) (item '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...) (elflag #f)) (for-each (lambda (row) (let ((rowname (car row)) (rowdat (cadr row))) (set! item (append item (list (if (< indx (length rowdat)) (let ((new (list rowname (list-ref rowdat indx)))) ;; (debug:print 0 default-log-port "New: " new) (set! elflag #t) new ) ;; i.e. had at least on legit value to use (list rowname "-"))))))) newlst) (if elflag (begin (set! res (append res (list item))) (loop (+ indx 1) '() #f))) res))) ;; Nope, not now, return null as of 6/6/2011 (define (items:check-valid-items class item) (let ((valid-values (let ((s (configf:lookup configdat "validvalues" class))) (if s (string-split s) #f)))) (if valid-values (if (member item valid-values) item #f) item))) ;; '(("k1" "k2" "k3") ;; ("a" "b" "c") ;; ("d" "e" "f")) ;; ;; => '((("k1" "a")("k2" "b")("k3" "c")) ;; (("k1" "d")("k2" "e")("k3" "f"))) ;; (define (items:first-row-intersperse data) (if (< (length data) 2) '() (let ((header (car data)) (rows (cdr data))) (map (lambda (row) (map list header row)) rows)))) ;; k1/k2/k3 ;; a/b/c ;; d/e/f ;; => '(("k1" "k2" "k3") ;; ("a" "b" "c") ;; ("d" "e" "f")) ;; ;; => '((("k1" "a")("k2" "b")("k3" "c")) ;; (("k1" "d")("k2" "e")("k3" "f"))) ;; (define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space (if (and fname (file-exists? fname)) (items:first-row-intersperse (case ftype ((slash space) (let ((splitter (case ftype ((slash) (lambda (x)(string-split x "/"))) (else string-split)))) (debug:print 0 default-log-port "Reading " fname " of type " ftype) (with-input-from-file fname (lambda () (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) res (loop (read-line)(cons (splitter inl) res)))))))) ((sxml)(with-input-from-file fname read)) (else (debug:print 0 default-log-port "items file type " ftype " not recognised")))) (begin (if fname (debug:print 0 default-log-port "no items file " fname " found")) '()))) (define (items:get-items-from-config tconfig) (let* ((slashf (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ... (sxmlf (configf:lookup tconfig "itemopts" "sxml")) ;; '(("a" "b" "c")("d" "e" "f") ...) (spacef (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ... (have-items (hash-table-ref/default tconfig "items" #f)) (have-itable (hash-table-ref/default tconfig "itemstable" #f)) (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) (debug:print 5 default-log-port "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) ;; evaluate the proc item)) items)) (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) ;; evaluate the proc item)) itemstable)) (if (and have-items (null? items)) (debug:print 0 default-log-port "WARNING:[items] section in testconfig but no entries defined")) (if (and have-itable (null? itemstable))(debug:print 0 default-log-port "WARNNG:[itemstable] section in testconfig but no entries defined")) (if (or (not (null? items)) (not (null? itemstable)) slashf sxmlf spacef) (append (item-assoc->item-list items) (item-table->item-list itemstable) (items:read-items-file slashf 'slash) (items:read-items-file sxmlf 'sxml) (items:read-items-file spacef 'space)) '(())))) ;; (pp (item-assoc->item-list itemdat)) )

︙
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350	154 155 156 157 158 159 160 161 162 163 164 165 166 167	- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -	#;(common:wait-for-homehost-load load-limit (conc " delaying server start due to load on homehost. limit is " load-limit)) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) (thread-join! log-rotate) (pop-directory))) ~~;; given a path to a server log return: host port startseconds~~ ~~;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let~~ ~~(define (server:logf-get-start-info logf)~~ ~~(let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+)")) ;; SERVER STARTED: host:port AT timesecs server id~~ ~~(dbprep-rx (regexp "^SERVER: dbprep"))~~ ~~(dbprep-found 0))~~ ~~(handle-exceptions~~ ~~exn~~ ~~(begin~~ ~~(debug:print-info 0 default-log-port "Unable to get server info from " logf ", exn=" exn)~~ ~~(list #f #f #f #f)) ;; no idea what went wrong, call it a bad server~~ ~~(with-input-from-file~~ ~~logf~~ ~~(lambda ()~~ ~~(let loop ((inl (read-line))~~ ~~(lnum 0))~~ ~~(if (not (eof-object? inl))~~ ~~(let ((mlst (string-match server-rx inl))~~ ~~(dbprep (string-match dbprep-rx inl))~~ ) ~~(if dbprep~~ ~~(set! dbprep-found 1)~~ ) ~~(if (not mlst)~~ ~~(if (< lnum 500) ;; give up if more than 500 lines of server log read~~ ~~(loop (read-line)(+ lnum 1))~~ ~~(begin~~ ~~(debug:print-info 0 default-log-port "Unable to get server info from first 500 lines of " logf )~~ ~~(list #f #f #f #f)))~~ ~~(let ((dat (cdr mlst)))~~ ~~(list (car dat) ;; host~~ ~~(string->number (cadr dat)) ;; port~~ ~~(string->number (caddr dat))~~ ~~(cadr (cddr dat))))))~~ ~~(begin~~ ~~(if dbprep-found~~ ~~(begin~~ ~~(debug:print-info 0 default-log-port "Server is in dbprep at " (current-seconds))~~ ~~(thread-sleep! 25)~~ ) ~~(debug:print-info 0 default-log-port "Unable to get server info from " logf " at " (current-seconds))~~ ) ~~(list #f #f #f #f)))))))))~~ ~~;; get a list of servers with all relevant data~~ ~~;; ( mod-time host port start-time pid )~~ ;; ~~(define (server:get-list areapath #!key (limit #f))~~ ~~(let ((fname-rx (regexp "^(\|./)server-(\\d+)-(\\S+).log$"))~~ ~~(day-seconds ( 24 60 60)))~~ ~~;; if the directory exists continue to get the list~~ ~~;; otherwise attempt to create the logs dir and then~~ ~~;; continue~~ ~~(if (if (directory-exists? (conc areapath "/logs"))~~ ~~'()~~ ~~(if (file-writable? areapath)~~ ~~(begin~~ ~~(condition-case~~ ~~(create-directory (conc areapath "/logs") #t)~~ ~~(exn (i/o file)(debug:print 0 default-log-port "ERROR: Cannot create directory at " (conc areapath "/logs")))~~ ~~(exn ()(debug:print 0 default-log-port "ERROR: Unknown error attemtping to get server list. exn=" exn)))~~ ~~(directory-exists? (conc areapath "/logs")))~~ ~~'()))~~ ~~;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.~~ ~~(let* ((server-logs (server:get-logs-list areapath))~~ ~~(num-serv-logs (length server-logs)))~~ ~~(if (or (null? server-logs) (= num-serv-logs 0))~~ ~~(let ()~~ ~~(debug:print 1 default-log-port "There are no servers running")~~ ~~'()~~ ) ~~(let loop ((hed (string-chomp (car server-logs)))~~ ~~(tal (cdr server-logs))~~ ~~(res '()))~~ ~~(let* ((mod-time (handle-exceptions~~ ~~exn~~ ~~(begin~~ ~~(debug:print 0 default-log-port "failed to get modification time on " hed ", exn=" exn)~~ ~~(current-seconds)) ;; 0~~ ~~(file-modification-time hed))) ;; default to very old so log gets ignored if deleted~~ ~~(down-time (- (current-seconds) mod-time))~~ ~~(serv-dat (if (or (< num-serv-logs 10)~~ ~~(< down-time 900)) ;; day-seconds))~~ ~~(server:logf-get-start-info hed)~~ ~~'())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at~~ ~~(serv-rec (cons mod-time serv-dat))~~ ~~(fmatch (string-match fname-rx hed))~~ ~~(pid (if fmatch (string->number (list-ref fmatch 2)) #f))~~ ~~(new-res (if (null? serv-dat)~~ ~~res~~ (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let ~~(if (null? tal)~~ ~~(if (and limit~~ ~~(> (length new-res) limit))~~ ~~new-res ;; (take new-res limit) <= need intelligent sorting before this will work~~ ~~new-res)~~ ~~(loop (string-chomp (car tal)) (cdr tal) new-res)))))))))~~ ~~(define (server:get-num-alive srvlst)~~ ~~(let ((num-alive 0))~~ ~~(for-each~~ ~~(lambda (server)~~ ~~(handle-exceptions~~ ~~exn~~ ~~(begin~~ ~~(debug:print-info 0 default-log-port "Unable to get server start-time and/or mod-time from " server ", exn=" exn))~~ ~~(match-let (((mod-time host port start-time server-id pid)~~ ~~server))~~ ~~(let* ((uptime (- (current-seconds) mod-time))~~ ~~(runtime (if start-time~~ ~~(- mod-time start-time)~~ ~~0)))~~ ~~(if (< uptime 5)(set! num-alive (+ num-alive 1)))))))~~ ~~srvlst)~~ ~~num-alive))~~ ~~;; given a list of servers get a list of valid servers, i.e. at least~~ ~~;; 10 seconds old, has started and is less than 1 hour old and is~~ ~~;; active (i.e. mod-time < 10 seconds~~ ;; ~~;; mod-time host port start-time pid~~ ;; ~~;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off~~ ~~;; and servers should stick around for about two hours or so.~~ ;; ~~(define (server:get-best srvlst)~~ ~~(let* ((nums (server:get-num-servers))~~ ~~(now (current-seconds))~~ ~~(slst (sort~~ ~~(filter (lambda (rec)~~ ~~(if (and (list? rec)~~ ~~(> (length rec) 2))~~ ~~(let ((start-time (list-ref rec 3))~~ ~~(mod-time (list-ref rec 0)))~~ ~~;; (print "start-time: " start-time " mod-time: " mod-time)~~ ~~(and start-time mod-time~~ ~~(> (- now start-time) 0) ;; been running at least 0 seconds~~ ~~(< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds~~ ~~(or (not (configf:lookup configdat "server" "runtime")) ;; skip if not set~~ ~~(< (- now start-time)~~ ~~(+ (- (string->number (configf:lookup configdat "server" "runtime"))~~ ~~180)~~ ~~(pseudo-random-integer 360)))) ;; under one hour running time +/- 180~~ )) ~~#f))~~ ~~srvlst)~~ ~~(lambda (a b)~~ ~~(< (list-ref a 3)~~ ~~(list-ref b 3))))))~~ ~~(if (> (length slst) nums)~~ ~~(take slst nums)~~ ~~slst)))~~ ~~(define (server:get-first-best areapath)~~ ~~(let ((srvrs (server:get-best (server:get-list areapath))))~~ ~~(if (and srvrs~~ ~~(not (null? srvrs)))~~ ~~(car srvrs)~~ ~~#f)))~~ ~~(define (server:get-rand-best areapath)~~ ~~(let ((srvrs (server:get-best (server:get-list areapath))))~~ ~~(if (and (list? srvrs)~~ ~~(not (null? srvrs)))~~ ~~(let* ((len (length srvrs))~~ ~~(idx (pseudo-random-integer len)))~~ ~~(list-ref srvrs idx))~~ ~~#f)))~~ ~~(define (server:record->id servr)~~ ~~(handle-exceptions~~ ~~exn~~ ~~(begin~~ ~~(debug:print-info 0 default-log-port "Unable to get server id from " servr ", exn=" exn)~~ ~~#f)~~ ~~(match-let (((mod-time host port start-time server-id pid)~~ ~~servr))~~ ~~(if server-id~~ ~~server-id~~ ~~#f))))~~ (define (server:record->url servr) (handle-exceptions exn (begin (debug:print-info 0 default-log-port "Unable to get server url from " servr ", exn=" exn) #f) (match-let (((mod-time host port start-time server-id pid)
︙
431 432 433 434 435 436 437 ~~438 439 440 441 442~~ 443 444 445 446 447 448 449	248 249 250 251 252 253 254 255 256 257 258 259 260 261	- - - - -	(server:kind-run areapath)) (thread-sleep! 5) (loop (server:check-if-running areapath) (+ try-num 1))))))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. ~~(define (server:get-num-servers #!key (numservers 2))~~ ~~(let ((ns (string->number~~ ~~(or (configf:lookup configdat "server" "numservers") "notanumber"))))~~ ~~(or ns numservers)))~~ ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; (define (server:check-if-running areapath) ;; #!key (numservers "2")) (let* ((ns (server:get-num-servers)) (servers (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers))
︙

︙
14 15 16 17 18 19 20 ~~21 22 23~~ 24 ~~25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42~~ 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222	14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29	- - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -	;; 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/>. ;; ;;====================================================================== ~~;;======================================================================~~ ~~;; Database access~~ ~~;;======================================================================~~ ~~;; (require-extension (srfi 18) extras tcp)~~ ~~;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)~~ ~~;; (import (prefix sqlite3 sqlite3:))~~ ~~;; (import (prefix base64 base64:))~~ ;; ~~;; (declare (unit tdb))~~ ~~;; (declare (uses common))~~ ~~;; (declare (uses keys))~~ ~~;; (declare (uses ods))~~ ~~;; (declare (uses client))~~ ~~;; (declare (uses mt))~~ ~~;; (declare (uses db))~~ ;; ~~;; (include "common_records.scm")~~ ~~;; (include "db_records.scm")~~ ~~;; (include "key_records.scm")~~ ~~;; (include "run_records.scm")~~ ;; All moved into dbmod.scm ~~;;======================================================================~~ ;; ~~;; T E S T D A T A B A S E S~~ ;; ~~;;======================================================================~~ ~~;;======================================================================~~ ~~;; T E S T S P E C I F I C D B~~ ~~;;======================================================================~~ ~~;; Create the sqlite db for the individual test(s)~~ ;; ~~;; Moved these tables into <runid>.db~~ ~~;; THIS CODE TO BE REMOVED~~ ;; ~~(define (open-test-db work-area)~~ ~~(debug:print-info 11 default-log-port "open-test-db " work-area)~~ ~~(if (and work-area~~ ~~(directory? work-area)~~ ~~(file-readable? work-area))~~ ~~(let* ((dbpath (conc work-area "/testdat.db"))~~ ~~(dbexists (common:file-exists? dbpath))~~ ~~(work-area-writeable (file-writable? work-area))~~ ~~(db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem~~ ~~exn~~ ~~(begin~~ ~~(print-call-chain (current-error-port))~~ ~~(debug:print 2 default-log-port "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"~~ ~~((condition-property-accessor 'exn 'message) exn))~~ ~~(set! dbexists #f) ;; must force re-creation of tables, more tom-foolery~~ ~~(sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access~~ ~~(if (or work-area-writeable~~ ~~dbexists)~~ ~~(sqlite3:open-database dbpath)~~ ~~(sqlite3:open-database ":memory:"))))~~ ~~(tdb-writeable (and (file-writable? work-area)~~ ~~(file-writable? dbpath)))~~ ~~(handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")~~ ~~(string->number (args:get-arg "-override-timeout"))~~ ~~136000))))~~ ~~(if (and tdb-writeable~~ db-write-access) ~~(sqlite3:set-busy-handler! db handler))~~ ~~(if (not dbexists)~~ ~~(begin~~ ~~(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")~~ ~~(debug:print-info 11 default-log-port "Initialized test database " dbpath)~~ ~~(tdb:testdb-initialize db)))~~ ~~;; (sqlite3:execute db "PRAGMA synchronous = 0;")~~ ~~(debug:print-info 11 default-log-port "open-test-db END (sucessful)" work-area)~~ ~~;; now let's test that everything is correct~~ ~~(handle-exceptions~~ ~~exn~~ ~~(begin~~ ~~(print-call-chain (current-error-port))~~ ~~(debug:print-error 0 default-log-port "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "~~ ~~dbpath ".\n "~~ ~~((condition-property-accessor 'exn 'message) exn))~~ ~~#f)~~ ~~;; Is there a cheaper single line operation that will check for existance of a table~~ ~~;; and raise an exception ?~~ ~~(sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))~~ ~~db)~~ ~~;; no work-area or not readable - create a placeholder to fake rest of world out~~ ~~(let ((baddb (sqlite3:open-database ":memory:")))~~ ~~(debug:print-info 11 default-log-port "open-test-db END (unsucessful)" work-area)~~ ~~;; provide an in-mem db (this is dangerous!)~~ ~~(tdb:testdb-initialize baddb)~~ ~~baddb)))~~ ~~;; find and open the testdat.db file for an existing test~~ ~~(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))~~ ~~(let* ((test-path (if work-area~~ ~~work-area~~ ~~(rmt:test-get-rundir-from-test-id test-id))))~~ ~~(debug:print 3 default-log-port "TEST PATH: " test-path)~~ ~~(open-test-db test-path)))~~ ~~;; find and open the testdat.db file for an existing test~~ ~~(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))~~ ~~(let* ((test-path (if work-area~~ ~~work-area~~ ~~(db:test-get-rundir-from-test-id dbstruct run-id test-id))))~~ ~~(debug:print 3 default-log-port "TEST PATH: " test-path)~~ ~~(open-test-db test-path)))~~ ~~;; find and open the testdat.db file for an existing test~~ ~~(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)~~ ~~(let* ((test-path (if work-area~~ ~~work-area~~ ~~(db:test-get-rundir-from-test-id dbstruct run-id test-id)))~~ ~~(tdb (open-test-db test-path)))~~ ~~(apply proc tdb params)))~~ ~~(define (tdb:testdb-initialize db)~~ ~~(debug:print 11 default-log-port "db:testdb-initialize START")~~ ~~(sqlite3:with-transaction~~ db ~~(lambda ()~~ ~~(for-each~~ ~~(lambda (sqlcmd)~~ ~~(sqlite3:execute db sqlcmd))~~ ~~(list "CREATE TABLE IF NOT EXISTS test_rundat (~~ ~~id INTEGER PRIMARY KEY,~~ ~~update_time TIMESTAMP,~~ ~~cpuload INTEGER DEFAULT -1,~~ ~~diskfree INTEGER DEFAULT -1,~~ ~~diskusage INTGER DEFAULT -1,~~ ~~run_duration INTEGER DEFAULT 0);"~~ ~~"CREATE TABLE IF NOT EXISTS test_data (~~ ~~id INTEGER PRIMARY KEY,~~ ~~test_id INTEGER,~~ ~~category TEXT DEFAULT '',~~ ~~variable TEXT,~~ ~~value REAL,~~ ~~expected REAL,~~ ~~tol REAL,~~ ~~units TEXT,~~ ~~comment TEXT DEFAULT '',~~ ~~status TEXT DEFAULT 'n/a',~~ ~~type TEXT DEFAULT '',~~ ~~CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"~~ ~~"CREATE TABLE IF NOT EXISTS test_steps (~~ ~~id INTEGER PRIMARY KEY,~~ ~~test_id INTEGER,~~ ~~stepname TEXT,~~ ~~state TEXT DEFAULT 'NOT_STARTED',~~ ~~status TEXT DEFAULT 'n/a',~~ ~~event_time TIMESTAMP,~~ ~~comment TEXT DEFAULT '',~~ ~~logfile TEXT DEFAULT '',~~ ~~CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"~~ ~~;; test_meta can be used for handing commands to the test~~ ~~;; e.g. KILLREQ~~ ~~;; the ackstate is set to 1 once the command has been completed~~ ~~"CREATE TABLE IF NOT EXISTS test_meta (~~ ~~id INTEGER PRIMARY KEY,~~ ~~var TEXT,~~ ~~val TEXT,~~ ~~ackstate INTEGER DEFAULT 0,~~ ~~CONSTRAINT metadat_constraint UNIQUE (var));"))))~~ ~~(debug:print 11 default-log-port "db:testdb-initialize END"))~~ ~~;; This routine moved to db:read-test-data~~ ;; ~~(define (tdb:read-test-data tdb test-id categorypatt)~~ ~~(let ((res '()))~~ ~~(sqlite3:for-each-row~~ ~~(lambda (id test_id category variable value expected tol units comment status type)~~ ~~(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))~~ ~~tdb~~ ~~"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)~~ ~~(sqlite3:finalize! tdb)~~ ~~(reverse res)))~~ ~~;;======================================================================~~ ~~;; T E S T D A T A~~ ~~;;======================================================================~~ ~~;; ;; get a list of test_data records matching categorypatt~~ ~~;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f))~~ ~~;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)))~~ ~~;; (if (sqlite3:database? tdb)~~ ~~;; (let ((res '()))~~ ~~;; (sqlite3:for-each-row~~ ~~;; (lambda (id test_id category variable value expected tol units comment status type)~~ ~~;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))~~ ~~;; tdb~~ ~~;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)~~ ~~;; (sqlite3:finalize! tdb)~~ ~~;; (reverse res))~~ ~~;; '())))~~ ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 default-log-port lin)
︙
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414	45 46 47 48 49 50 51	- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -	(rmt:csv->test-data run-id test-id lin) ;;) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) ~~(define (tdb:get-prev-tol-for-test tdb test-id category variable)~~ ~~;; Finish me?~~ ~~(values #f #f #f))~~ ~~;;======================================================================~~ ~~;; S T E P S~~ ~~;;======================================================================~~ ~~(define (tdb:step-get-time-as-string vec)~~ ~~(seconds->time-string (tdb:step-get-event_time vec)))~~ ~~;; get a pretty table to summarize steps~~ ;; ~~;; NOT USED, WILL BE REMOVED~~ ;; ~~(define (tdb:get-steps-table steps);; organise the steps for better readability~~ ~~(let ((res (make-hash-table)))~~ ~~(for-each~~ ~~(lambda (step)~~ ~~(debug:print 6 default-log-port "step=" step)~~ ~~(let ((record (hash-table-ref/default~~ ~~res~~ ~~(tdb:step-get-stepname step)~~ ~~;; stepname start end status Duration Logfile~~ ~~(vector (tdb:step-get-stepname step) "" "" "" "" ""))))~~ ~~(debug:print 6 default-log-port "record(before) = " record~~ ~~"\nid: " (tdb:step-get-id step)~~ ~~"\nstepname: " (tdb:step-get-stepname step)~~ ~~"\nstate: " (tdb:step-get-state step)~~ ~~"\nstatus: " (tdb:step-get-status step)~~ ~~"\ntime: " (tdb:step-get-event_time step))~~ ~~(case (string->symbol (tdb:step-get-state step))~~ ~~((start)(vector-set! record 1 (tdb:step-get-event_time step))~~ ~~(vector-set! record 3 (if (equal? (vector-ref record 3) "")~~ ~~(tdb:step-get-status step)))~~ ~~(if (> (string-length (tdb:step-get-logfile step))~~ 0) ~~(vector-set! record 5 (tdb:step-get-logfile step))))~~ ~~((end)~~ ~~(vector-set! record 2 (any->number (tdb:step-get-event_time step)))~~ ~~(vector-set! record 3 (tdb:step-get-status step))~~ ~~(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))~~ ~~(endt (any->number (vector-ref record 2))))~~ ~~(debug:print 4 default-log-port "record[1]=" (vector-ref record 1)~~ ~~", startt=" startt ", endt=" endt~~ ~~", get-status: " (tdb:step-get-status step))~~ ~~(if (and (number? startt)(number? endt))~~ ~~(seconds->hr-min-sec (- endt startt)) "-1")))~~ ~~(if (> (string-length (tdb:step-get-logfile step))~~ 0) ~~(vector-set! record 5 (tdb:step-get-logfile step))))~~ ~~(else~~ ~~(vector-set! record 2 (tdb:step-get-state step))~~ ~~(vector-set! record 3 (tdb:step-get-status step))~~ ~~(vector-set! record 4 (tdb:step-get-event_time step))))~~ ~~(hash-table-set! res (tdb:step-get-stepname step) record)~~ ~~(debug:print 6 default-log-port "record(after) = " record~~ ~~"\nid: " (tdb:step-get-id step)~~ ~~"\nstepname: " (tdb:step-get-stepname step)~~ ~~"\nstate: " (tdb:step-get-state step)~~ ~~"\nstatus: " (tdb:step-get-status step)~~ ~~"\ntime: " (tdb:step-get-event_time step))))~~ ~~;; (else (vector-set! record 1 (tdb:step-get-event_time step)))~~ ~~(sort steps (lambda (a b)~~ ~~(cond~~ ~~((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)~~ ~~((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))~~ ~~(< (tdb:step-get-id a) (tdb:step-get-id b)))~~ ~~(else #f)))))~~ ~~res))~~ ~~;; Move this to steps.scm~~ ;; ~~;; get a pretty table to summarize steps~~ ;; ~~(define (tdb:get-steps-table-list steps)~~ ~~;; organise the steps for better readability~~ ~~(let ((res (make-hash-table)))~~ ~~(for-each~~ ~~(lambda (step)~~ ~~(debug:print 6 default-log-port "step=" step)~~ ~~(let ((record (hash-table-ref/default~~ ~~res~~ ~~(tdb:step-get-stepname step)~~ ~~;; stepname start end status~~ ~~(vector (tdb:step-get-stepname step) "" "" "" "" ""))))~~ ~~(debug:print 6 default-log-port "record(before) = " record~~ ~~"\nid: " (tdb:step-get-id step)~~ ~~"\nstepname: " (tdb:step-get-stepname step)~~ ~~"\nstate: " (tdb:step-get-state step)~~ ~~"\nstatus: " (tdb:step-get-status step)~~ ~~"\ntime: " (tdb:step-get-event_time step))~~ ~~(case (string->symbol (tdb:step-get-state step))~~ ~~((start)(vector-set! record 1 (tdb:step-get-event_time step))~~ ~~(vector-set! record 3 (if (equal? (vector-ref record 3) "")~~ ~~(tdb:step-get-status step)))~~ ~~(if (> (string-length (tdb:step-get-logfile step))~~ 0) ~~(vector-set! record 5 (tdb:step-get-logfile step))))~~ ~~((end)~~ ~~(vector-set! record 2 (any->number (tdb:step-get-event_time step)))~~ ~~(vector-set! record 3 (tdb:step-get-status step))~~ ~~(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))~~ ~~(endt (any->number (vector-ref record 2))))~~ ~~(debug:print 4 default-log-port "record[1]=" (vector-ref record 1)~~ ~~", startt=" startt ", endt=" endt~~ ~~", get-status: " (tdb:step-get-status step))~~ ~~(if (and (number? startt)(number? endt))~~ ~~(seconds->hr-min-sec (- endt startt)) "-1")))~~ ~~(if (> (string-length (tdb:step-get-logfile step))~~ 0) ~~(vector-set! record 5 (tdb:step-get-logfile step))))~~ ~~(else~~ ~~(vector-set! record 2 (tdb:step-get-state step))~~ ~~(vector-set! record 3 (tdb:step-get-status step))~~ ~~(vector-set! record 4 (tdb:step-get-event_time step))))~~ ~~(hash-table-set! res (tdb:step-get-stepname step) record)~~ ~~(debug:print 6 default-log-port "record(after) = " record~~ ~~"\nid: " (tdb:step-get-id step)~~ ~~"\nstepname: " (tdb:step-get-stepname step)~~ ~~"\nstate: " (tdb:step-get-state step)~~ ~~"\nstatus: " (tdb:step-get-status step)~~ ~~"\ntime: " (tdb:step-get-event_time step))))~~ ~~;; (else (vector-set! record 1 (tdb:step-get-event_time step)))~~ ~~(sort steps (lambda (a b)~~ ~~(cond~~ ~~((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)~~ ~~((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))~~ ~~(< (tdb:step-get-id a) (tdb:step-get-id b)))~~ ~~(else #f)))))~~ ~~res))~~ ;; ~~;; Move to steps.scm~~ ;; ~~(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table~~ ~~(map (lambda (x)~~ ~~;; take advantage of the \n on time->string~~ ~~(vector~~ ~~(vector-ref x 0)~~ ~~(let ((s (vector-ref x 1)))~~ ~~(if (number? s)(seconds->time-string s) s))~~ ~~(let ((s (vector-ref x 2)))~~ ~~(if (number? s)(seconds->time-string s) s))~~ ~~(vector-ref x 3) ;; status~~ ~~(vector-ref x 4)~~ ~~(vector-ref x 5))) ;; time delta~~ ~~(sort (hash-table-values comprsteps)~~ ~~(lambda (a b)~~ ~~(let ((time-a (vector-ref a 1))~~ ~~(time-b (vector-ref b 1)))~~ ~~(if (and (number? time-a)(number? time-b))~~ ~~(if (< time-a time-b)~~ #t ~~(if (eq? time-a time-b)~~ ~~(string<? (conc (vector-ref a 2))~~ ~~(conc (vector-ref b 2)))~~ ~~#f))~~ ~~(string<? (conc time-a)(conc time-b))))))))~~ ;; ~~(define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)~~ ~~(let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))~~ ~~(if (sqlite3:database? tdb)~~ ~~(begin~~ ~~(sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"~~ ~~cpuload diskfree minutes)~~ ~~(sqlite3:finalize! tdb))~~ ~~(debug:print 2 default-log-port "Can't update testdat.db for test " test-id " read-only or non-existant"))))~~