Overview
Comment: | Added channel for result codes to http communication. Fixed some unit tests |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.60 |
Files: | files | file ages | folders |
SHA1: |
98ffd649bac9259ee9d23c0485a85604 |
User & Date: | matt on 2014-11-16 17:37:40 |
Other Links: | branch diff | manifest | tags |
Context
2014-11-16
| ||
20:02 | Better error reporting (use stderr), faster registration of tests, bug fix in tasks path to db handling check-in: 3757f74464 user: matt tags: v1.60 | |
17:37 | Added channel for result codes to http communication. Fixed some unit tests check-in: 98ffd649ba user: matt tags: v1.60 | |
08:30 | Handle errors in data transmission (e.g. corruption in flight). check-in: 7ca86d7e47 user: matt tags: v1.60 | |
Changes
Modified api.scm from [2952b351e1] to [a688529701].
︙ | ︙ | |||
45 46 47 48 49 50 51 | get-run-ids-matching-target get-runs-by-patt get-steps-data login testmeta-get-record)) ;; These are called by the server on recipt of /api calls | | > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | get-run-ids-matching-target get-runs-by-patt get-steps-data login testmeta-get-record)) ;; These are called by the server on recipt of /api calls ;; - keep it simple, only return the actual result of the call, i.e. no meta info here ;; (define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; KEYS |
︙ | ︙ |
Modified db.scm from [f81dab27b4] to [15f2be2e7b].
︙ | ︙ | |||
2464 2465 2466 2467 2468 2469 2470 | (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 | (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) (if (not (configf:lookup *configdat* "server" "delay-on-busy")) (and dbdat (db:dbdat-get-db dbdat)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) ((5) (thread-sleep! 0.4) (db:delay-if-busy count: 4)) ((4) (thread-sleep! 0.8) (db:delay-if-busy count: 3)) ((3) (thread-sleep! 1.6) (db:delay-if-busy count: 2)) ((2) (thread-sleep! 3.2) (db:delay-if-busy count: 1)) ((1) (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct run-id #f |
︙ | ︙ |
Modified http-transport.scm from [b0912eff93] to [0ec84bc71c].
︙ | ︙ | |||
240 241 242 243 244 245 246 | ;; (define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) | | > | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | ;; (define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) (res #f) (success #t)) (handle-exceptions exn (if (> numretries 0) (begin (mutex-unlock! *http-mutex*) (thread-sleep! 1) (handle-exceptions |
︙ | ︙ | |||
271 272 273 274 275 276 277 | ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. (let* ((send-recieve (lambda () (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) | > > | | | > | | | | | | | | | | | | 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 | ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. (let* ((send-recieve (lambda () (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) (set! res (vector success (handle-exceptions exn (begin (set! success #f) (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (hash-table-delete! *runremote* run-id) ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine. #f) (with-input-from-request ;; was dat fullurl (list (cons 'key "thekey") (cons 'cmd cmd) (cons 'params params)) read-string)))) ;; Shouldn't this be a call to the managed call-all-connections stuff above? (close-all-connections!) (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) #f)) |
︙ | ︙ |
Modified rmt.scm from [a3b0e53bfe] to [7a184ad9b2].
︙ | ︙ | |||
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 | (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) (begin (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 0)) ;; clean out old connections (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) 60))) (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and connection (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) (mutex-unlock! *db-multi-sync-mutex*) (let* ((run-id (if rid rid 0)) | > > > > > > > > > > | < < < < < < < < < < < < > | > > | | > | > | | > > > > | 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 | (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) (begin (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) (define (rmt:get-connection-info run-id) (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) (if cinfo cinfo ;; NB// can cache the answer for server running for 10 seconds ... ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 0)) ;; clean out old connections (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) 60))) (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and connection (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) (mutex-unlock! *db-multi-sync-mutex*) (let* ((run-id (if rid rid 0)) (connection-info (rmt:get-connection-info run-id)) (jparams (db:obj->string params))) (if connection-info ;; use the server if have connection info (let* ((dat (http-transport:client-api-send-receive run-id connection-info cmd jparams)) (res (if dat (vector-ref dat 1) #f)) (success (if dat (vector-ref dat 0) #f))) (http-transport:server-dat-update-last-access connection-info) (if success (db:string->obj res) ;; (if (< attemptnum 100) ;; (begin ;; (hash-table-delete! *runremote* run-id) ;; (thread-sleep! 0.5) ;; (rmt:send-receive cmd rid params attempnum: (+ attemptnum 1))) ;; (begin ;; (print-call-chain) ;; (debug:print 0 "ERROR: too many attempts to communicate have failed. Giving up. Kill your mtest processes and start over") ;; (exit 1))))) (begin ;; let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; no longer killing the server in http-transport:client-api-send-receive ;; may kill it here but what are the criteria? ;; start with three calls then kill server |
︙ | ︙ | |||
120 121 122 123 124 125 126 | (if (> curr-max-val max-avg-qry) (if (common:low-noise-print 10 "start server due to max average query too long") (begin (debug:print-info 0 "Max average query, " (inexact->exact (round curr-max-val)) "ms (" (car curr-max) ") exceeds " max-avg-qry "ms, try starting server ...") (server:kind-run run-id)) (debug:print-info 3 "Max average query, " (inexact->exact (round curr-max-val)) "ms (" (car curr-max) ") below " max-avg-qry "ms, not starting server..."))) (rmt:open-qry-close-locally cmd run-id params))))))) | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | (if (> curr-max-val max-avg-qry) (if (common:low-noise-print 10 "start server due to max average query too long") (begin (debug:print-info 0 "Max average query, " (inexact->exact (round curr-max-val)) "ms (" (car curr-max) ") exceeds " max-avg-qry "ms, try starting server ...") (server:kind-run run-id)) (debug:print-info 3 "Max average query, " (inexact->exact (round curr-max-val)) "ms (" (car curr-max) ") below " max-avg-qry "ms, not starting server..."))) (rmt:open-qry-close-locally cmd run-id params))))))) (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin (debug:print 0 "WARNING: stats collection failed in update-db-stats") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) |
︙ | ︙ | |||
203 204 205 206 207 208 209 | ;; just set it every time. Is a write more expensive than a read and does it matter? (hash-table-set! *db-local-sync* run-id start-time) ;; the oldest "write" (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)) | | | | | > > | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | ;; just set it every time. Is a write more expensive than a read and does it matter? (hash-table-set! *db-local-sync* run-id start-time) ;; the oldest "write" (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)) (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) (dat (http-transport:client-api-send-receive run-id connection-info cmd jparams))) (if (and dat (vector-ref dat 0)) (db:string->obj (vector-ref dat 1)) (begin (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " res) res)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string (lambda () (json-write dat)))) |
︙ | ︙ |
Modified tests/Makefile from [8c34524e1b] to [502a984b43].
︙ | ︙ | |||
17 18 19 20 21 22 23 | FS = $(shell df -T .|tail -1|awk '{print $$2}') VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5) # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" | | > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | FS = $(shell df -T .|tail -1|awk '{print $$2}') VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5) # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9 unit : ./rununittest.sh basicserver $(DEBUG) server : cd ..;make -j;make install cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) stopserver : cd ..;make -j && make install |
︙ | ︙ |
Modified tests/rununittest.sh from [f7741d546c] to [d9bb67915f].
1 2 3 4 5 6 7 8 9 10 | #!/bin/bash # Usage: rununittest.sh testname debuglevel # # Ensure all is made (cd ..;make && make install) # Clean setup # | > > > > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | #!/bin/bash # Usage: rununittest.sh testname debuglevel # # Ensure all is made (cd ..;make && make install) # put megatest on path from correct location mtbindir=$(readlink -f ../bin) export PATH="${mtbindir}:$PATH" # Clean setup # dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 |
Modified tests/simplerun/megatest.config from [a2b32bd6f4] to [4850198caf].
︙ | ︙ | |||
8 9 10 11 12 13 14 | # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable | | | | 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 | # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] useshell yes launcher nbfind # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns |
Modified tests/tests.scm from [ceeda9f906] to [9d9074d93d].
︙ | ︙ | |||
22 23 24 25 26 27 28 | (let ((files (glob "*_records.scm"))) (for-each (lambda (file) (print "Loading " file) (load file)) files)) | < < > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | (let ((files (glob "*_records.scm"))) (for-each (lambda (file) (print "Loading " file) (load file)) files)) (let* ((unit-test-name (list-ref (argv) 4)) (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) |
Modified tests/unittests/basicserver.scm from [b1c30eb42e] to [9a659fa835].
1 2 3 4 5 6 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; | | | > | | < < | < | < < > < > < | < > | > > > | > | | > > > > > > > > > | > > > > > > | < | < < | < | > > > > | | | < > > | < | > | < | > > > > > | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | < < | | | | | | | | | | | | | | | | | | > > | 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 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (delete-file* "logs/1.log") (define run-id 1) (test "setup for run" #t (begin (launch:setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) ;; NON Server tests go here (test #f #f (db:dbdat-get-path *db*)) (test #f #f (db:get-run-name-from-id *db* run-id)) ;; (exit) ;; Server tests go here (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) (server:kind-run run-id) (test "did server start within 20 seconds?" #t (let loop ((remtries 20) (running (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) (if running (> running 0) (if (> remtries 0) (begin (thread-sleep! 1.1) (loop (- remtries 1) (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))))))) (test "did server become available" #t (let loop ((remtries 10) (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) (if res (vector? res) (begin (if (> remtries 0) (begin (thread-sleep! 1.1) (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) res))))) (test #f #f (not (client:setup run-id))) (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) (test #f '(#t "successful login") (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id)) (test #f '(#t "successful login") (rmt:login run-id)) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) (test #f '() (rmt:get-all-run-ids)) (test #f #f (rmt:get-run-name-from-id run-id)) ;; test killing server ;; (tasks:kill-server-run-id run-id) (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) ;; (test #f #f (client:setup run-id)) ;; (set! *transport-type* 'http) ;; ;; (test "setup for run" #t (begin (launch:setup-for-run) ;; (string? (getenv "MT_RUN_AREA_HOME")))) ;; ;; (test "server-register, get-best-server" #t (let ((res #f)) ;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) ;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) ;; (number? (vector-ref res 3)))) ;; ;; (test "de-register server" #f (let ((res #f)) ;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) ;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) ;; ;; (define server-pid #f) ;; ;; ;; Not sure how the following should work, replacing it with system of megatest -server ;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; ;; (daemon:ize) ;; ;; (server:launch 'http))))) ;; ;; (set! server-pid pid) ;; ;; (number? pid))) ;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") ;; ;; (let loop ((n 10)) ;; (thread-sleep! 1) ;; need to wait for server to start. ;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) ;; (print "tasks:get-best-server returned " res) ;; (if (and (not res) ;; (> n 0)) ;; (loop (- n 1))))) ;; ;; (test "get-best-server" #t (begin ;; (client:launch) ;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) ;; (vector? dat)))) ;; ;; (define *keys* (keys:config-get-fields *configdat*)) ;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) ;; ;; (test #f #t (string? (car *runremote*))) ;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) ;; ;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test ;; ;; ;; RUNS ;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) ;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) ;; (vector-ref (vector-ref rinfo 1) 3))) ;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) ;; ;; ;; TESTS ;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) ;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) ;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) ;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) ;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) ;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) ;; (test "get keys" #t (list? (rmt:get-keys))) ;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) ;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) ;; (db:test-get-comment trec))) ;; ;; ;; MORE RUNS ;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) ;; (header (vector-ref runs 0)) ;; (data (vector-ref runs 1))) ;; (and (list? header) ;; (list? data) ;; (vector? (car data))))) ;; ;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) ;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) ;; ;; ;;====================================================================== ;; ;; D B ;; ;;====================================================================== ;; ;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) ;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) ;; (+ (db:test-get-pass_count dat) ;; (db:test-get-fail_count dat)))) ;; ;; (define testregistry (make-hash-table)) ;; (for-each ;; (lambda (tname) ;; (for-each ;; (lambda (itempath) ;; (let ((tkey (conc tname "/" itempath)) ;; (rpass (random 10)) ;; (rfail (random 10))) ;; (hash-table-set! testregistry tkey (list tname itempath)) ;; (rmt:general-call 'register-test 1 tname itempath) ;; (let* ((tid (rmt:get-test-id 1 tname itempath)) ;; (tdat (rmt:get-test-info-by-id tid))) ;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) ;; (let* ((resdat (rmt:get-test-info-by-id tid))) ;; (test "set/get pass fail counts" (list rpass rfail) ;; (list (db:test-get-pass_count resdat) ;; (db:test-get-fail_count resdat))))))) ;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) ;; (list "test1" "test2" "test3" "test4" "test5")) ;; ;; ;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) ;; (exit) |