Overview
Comment: | Re-re-got sdb working |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | inmem-per-run-db |
Files: | files | file ages | folders |
SHA1: |
9016fa9bb44e14a63eb84b2a3b5a5f2e |
User & Date: | matt on 2013-11-28 23:17:04 |
Other Links: | branch diff | manifest | tags |
Context
2013-11-30
| ||
08:15 | Still hosed check-in: cfb597082f user: matt tags: inmem-per-run-db | |
2013-11-28
| ||
23:17 | Re-re-got sdb working check-in: 9016fa9bb4 user: matt tags: inmem-per-run-db | |
2013-11-27
| ||
08:47 | Merged in couple minor fixes from trunk check-in: 07ba8e0db4 user: mrwellan tags: inmem-per-run-db | |
Changes
Modified api.scm from [ce13ad7a8d] to [1a4f3a977f].
︙ | |||
86 87 88 89 90 91 92 93 94 95 96 97 98 99 | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | + | port: port) (set! *server-run* #f) (thread-sleep! 3) (if pid (process-signal pid signal/kill) (thread-start! th1)) '(#t "exit process started"))) ((sdb-qry) (apply sdb:qry params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) (else (list "ERROR" 0)))) |
︙ |
Modified client.scm from [ff8925d9f6] to [bb155c569c].
︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | + + + + + + | (define (client:setup #!key (numtries 3)) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: failed to find megatest.config, exiting") (exit)))) (push-directory *toppath*) ;; This is probably NOT needed ;; clients get the sdb:qry proc created here (if (not sdb:qry) (begin (set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here (sdb:qry 'setup #f))) (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) (let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) (set! *transport-type* (if hostinfo (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) |
︙ |
Modified db.scm from [e04dda63c7] to [eb748807b3].
︙ | |||
161 162 163 164 165 166 167 | 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 | - - + + + + - - + + + + + + + + + | (if (not dbexists) (db:initialize-megatest-db db)) (dbr:dbstruct-set-main! dbstruct db) db)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; |
︙ | |||
193 194 195 196 197 198 199 | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | - - + + | (for-each (lambda (runvec) (let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))) (if (sqlite3:database? rundb) (sqlite3:finalize! rundb) (debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database")))) (hash-table-values (vector-ref dbstruct 1))) |
︙ | |||
224 225 226 227 228 229 230 | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | - + | '("uname" #f) '("rundir_id" #f) '("shortdir_id" #f) '("item_path" #f) '("state" #f) '("status" #f) '("attemptnum" #f) |
︙ | |||
283 284 285 286 287 288 289 | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | - + | '("uname" #f) '("rundir_id" #f) '("shortdir_id" #f) '("item_path" #f) '("state" #f) '("status" #f) '("attemptnum" #f) |
︙ | |||
500 501 502 503 504 505 506 | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | - + | uname TEXT DEFAULT 'n/a', rundir_id INTEGER DEFAULT -1, shortdir_id INTEGER DEFAULT -1, item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, |
︙ | |||
1124 1125 1126 1127 1128 1129 1130 | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 | - + | ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (let* ((qryvalstr (case qryvals ((shortlist) "id,run_id,testname,item_path,state,status") |
︙ | |||
1229 1230 1231 1232 1233 1234 1235 | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 | - - + + + + + + + + + + + + + + | db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} |
︙ | |||
1347 1348 1349 1350 1351 1352 1353 | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 | - + - + - + - + - + - + - + | (lambda (id) ;; run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment ) (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment ))) (db:get-db dbstruct run-id) "SELECT id FROM tests WHERE testname=? AND item_path=?;" testname item-path) res)) |
︙ | |||
1686 1687 1688 1689 1690 1691 1692 | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 | - + | THEN 'PASS' ELSE status END WHERE id=?;") ;; DONE '(test-set-log "UPDATE tests SET final_logf_id=? WHERE id=?;") ;; DONE '(test-set-rundir-by-test-id "UPDATE tests SET rundir_id=? WHERE id=?") ;; DONE '(test-set-rundir "UPDATE tests SET rundir_id=? AND testname=? AND item_path=?;") ;; DONE '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE |
︙ | |||
2019 2020 2021 2022 2023 2024 2025 | 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 | - + | "Cpu Load" ; 20 ))) (results (list runsheader)) (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment")) (mainqry (conc "SELECT t.testname,r.id,runname," keysstr ",t.testname, t.item_path,tm.description,t.state,t.status, |
︙ |
Modified db_records.scm from [b201cba7e0] to [1641bf9d8d].
︙ | |||
85 86 87 88 89 90 91 92 93 94 95 96 97 98 | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | + | (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) (define-inline (db:test-get-host vec) (vector-ref vec 6)) (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) (define-inline (db:test-get-uname vec) (vector-ref vec 9)) ;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) |
︙ |
Modified http-transport.scm from [c84c869b01] to [fe01ff5087].
︙ | |||
429 430 431 432 433 434 435 | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 | - + - + - + + | (let loop ((count 0)) ;; Use this opportunity to sync the inmemdb to db (let ((start-time (current-milliseconds)) (sync-time #f) (rem-time #f)) (if *inmemdb* (db:sync-touched *inmemdb*)) (set! sync-time (- (current-milliseconds) start-time)) |
︙ | |||
458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 | + + + | (set! spid (tasks:server-get-server-id tdb #f iface port #f)))) ;; NOTE: Get rid of this mechanism! It really is not needed... ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) (tasks:server-update-heartbeat tdb spid) ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access ;; Transfer *last-db-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) |
︙ | |||
522 523 524 525 526 527 528 529 530 531 532 533 534 535 | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | + | ;; Database connection (set! *inmemdb* (db:setup)) (thread-start! th2) (thread-start! th3) (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (sdb:qry 'finalize) (exit))) (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () |
︙ |
Modified launch.scm from [e529e7dcc7] to [d626b39a2a].
︙ | |||
521 522 523 524 525 526 527 | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 | - + | ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo ;; (filedb:get-path *fdb* ;; (db:get-path dbstruct |
︙ |
Modified megatest.scm from [6fa480ef4e] to [8dad4b95f7].
︙ | |||
356 357 358 359 360 361 362 | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | - + | (hash-table-keys args:arg-hash) '("-list-servers" "-stop-server" "-show-cmdinfo" "-list-runs"))) (if (setup-for-run) (begin |
︙ | |||
382 383 384 385 386 387 388 | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | - - | "fs")))) (debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo) (case chosen-transport ((http) (set! *transport-type 'http) (server:ensure-running) ;; Get rid of this |
︙ | |||
616 617 618 619 620 621 622 | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | + - + | (if (not (or (equal? (db:test-get-status test) "PASS") (equal? (db:test-get-status test) "WARN") (equal? (db:test-get-state test) "NOT_STARTED"))) (begin (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) "\n uname: " (sdb:qry 'getstr (db:test-get-uname test)) "\n rundir: " (sdb:qry 'getstr ;; (filedb:get-path *fdb* |
︙ | |||
1194 1195 1196 1197 1198 1199 1200 | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 | - + | ;; this is the socket if we are a client ;; (if (and *runremote* ;; (socket? *runremote*)) ;; (close-socket *runremote*)) (if sdb:qry (sdb:qry 'finalize #f)) |
︙ |
Modified mt.scm from [ad70d7d352] to [650c958bb7].
︙ | |||
125 126 127 128 129 130 131 | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | - - + + + - + | ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers run-id test-id newstate newstatus) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) |
︙ |
Modified rmt.scm from [df4a047b28] to [ac40e99ede].
︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | + + + + | ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call (append (list stmtname run-id) params))) (define (rmt:sync-inmem->db) (rmt:send-receive 'sync-inmem->db '())) (define (rmt:sdb-qry qry val) ;; add caching if qry is 'getid or 'getstr (rmt:send-receive 'sdb-qry (list qry val))) ;;====================================================================== ;; K E Y S ;;====================================================================== (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs (list run-id))) |
︙ | |||
142 143 144 145 146 147 148 | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | - + | (define (rmt:get-previous-test-run-record run-id test-name item-path) (rmt:send-receive 'get-previous-test-run-record (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 (list run-id test-name item-path))) |
︙ |
Modified runs.scm from [8f583e8498] to [ea6181b322].
︙ | |||
1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 | + | (let ((skip-test #f) (skip-check (configf:get-section test-conf "skip"))) (cond ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) ;; run-ids = #f means *all* runs (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) |
︙ | |||
1248 1249 1250 1251 1252 1253 1254 | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 | - - + + + - + | ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) |
︙ |
Modified sdb.scm from [0b5707be89] to [b5405355dd].
︙ | |||
19 20 21 22 23 24 25 | 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 | - - + + - + - + - + | (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit sdb)) ;; (define (sdb:open fname) |
︙ | |||
75 76 77 78 79 80 81 | 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 | - + + + + + + | ;; Numbers get passed though in both directions ;; (define (make-sdb:qry fname) (let ((sdb #f) (scache (make-hash-table)) (icache (make-hash-table))) (lambda (cmd var) |
Modified tests.scm from [133fdce6ed] to [15f8b06685].
︙ | |||
132 133 134 135 136 137 138 | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | - - + + | #f)) ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) |
︙ |