15164
15165
15166
15167
15168
15169
15170
15171
15172
15173
15174
|
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
(set! res (cons (apply vector a b) res)))
db
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
(string-intersperse (map conc test-ids) ",") ");"))
res))))
)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
15165
15166
15167
15168
15169
15170
15171
15172
15173
15174
15175
15176
15177
15178
15179
15180
15181
15182
15183
15184
15185
15186
15187
15188
15189
15190
15191
15192
15193
15194
15195
15196
15197
15198
15199
15200
15201
15202
15203
15204
15205
15206
15207
15208
15209
15210
15211
15212
15213
15214
15215
15216
15217
15218
15219
15220
15221
15222
15223
15224
15225
15226
15227
15228
15229
15230
15231
15232
15233
15234
15235
15236
15237
15238
15239
15240
15241
15242
15243
15244
15245
15246
15247
15248
15249
15250
15251
15252
15253
15254
15255
15256
15257
15258
15259
15260
15261
15262
15263
15264
15265
15266
15267
15268
15269
15270
15271
15272
15273
15274
15275
15276
15277
15278
15279
15280
15281
15282
15283
15284
15285
15286
15287
15288
15289
15290
15291
15292
15293
15294
15295
15296
15297
15298
15299
15300
15301
15302
15303
15304
15305
15306
15307
15308
15309
15310
15311
15312
15313
15314
15315
15316
15317
15318
15319
15320
15321
15322
15323
15324
15325
15326
15327
15328
15329
15330
15331
15332
15333
15334
15335
15336
15337
15338
15339
15340
15341
15342
15343
15344
15345
15346
15347
15348
15349
15350
15351
15352
15353
15354
15355
15356
15357
15358
15359
15360
15361
15362
15363
15364
15365
15366
15367
15368
15369
15370
15371
15372
15373
15374
15375
15376
15377
15378
15379
15380
15381
15382
15383
15384
15385
15386
15387
15388
15389
15390
15391
15392
15393
15394
15395
15396
15397
15398
15399
15400
15401
15402
15403
15404
15405
15406
15407
15408
15409
15410
15411
15412
15413
15414
15415
15416
15417
15418
15419
15420
15421
15422
15423
15424
15425
15426
15427
15428
15429
15430
15431
15432
15433
15434
15435
15436
15437
15438
15439
15440
15441
15442
15443
15444
15445
15446
15447
15448
15449
15450
15451
15452
15453
15454
15455
15456
15457
15458
15459
15460
15461
15462
15463
15464
15465
15466
15467
15468
15469
15470
15471
15472
15473
15474
15475
15476
15477
15478
15479
15480
15481
15482
15483
15484
15485
15486
15487
15488
15489
15490
15491
15492
15493
15494
15495
15496
15497
15498
15499
15500
15501
15502
15503
15504
15505
15506
15507
15508
15509
15510
15511
15512
15513
15514
|
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
(set! res (cons (apply vector a b) res)))
db
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
(string-intersperse (map conc test-ids) ",") ");"))
res))))
;; (db:with-db alldat run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db alldat run-id r/w proc . params)
(let* ((have-struct (alldat? alldat))
(dbdat (if have-struct
(db:get-db alldat)
#f))
(db (if have-struct
(db:dbdat-get-db dbdat)
alldat))
(use-mutex (> (alldat-api-process-request-count alldat) 25))
(db-with-db-mutex (alldat-db-with-db-mutex alldat))
(log-port (alldat-log-port alldat)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 log-port (alldat-api-process-request-count alldat) " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" (alldat-max-api-process-requests alldat)))
(debug:print-info 2 log-port "Parallel api request count: " (alldat-api-process-request-count alldat) " max parallel requests: " (alldat-max-api-process-requests alldat)))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 log-port "sqlite3 issue in db:with-db, alldat=" alldat ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
;; there is no recovering at this time. exit
(exit 50))
(if use-mutex (mutex-lock! db-with-db-mutex))
(let ((res (apply proc db params)))
(if use-mutex (mutex-unlock! db-with-db-mutex))
(if dbdat (stack-push! (alldat-dbstack alldat) dbdat))
res))))
(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
;; get a useful subset of the tests data (used in dashboard
;; use db:mintest-get-{id ,run_id,testname ...}
;;
(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
(db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
;; 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
;; mode:
;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
;;
(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
(let* ((qryvalstr (case qryvals
((shortlist) "id,run_id,testname,item_path,state,status")
((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
(else qryvals)))
(res '())
;; if states or statuses are null then assume match all when not-in is false
(states-qry (if (null? states)
#f
(conc " state "
(if (eq? mode 'dashboard)
" IN ('"
(if not-in
" NOT IN ('"
" IN ('"))
(string-intersperse states "','")
"')")))
(statuses-qry (if (null? statuses)
#f
(conc " status "
(if (eq? mode 'dashboard)
" IN ('"
(if not-in
" NOT IN ('"
" IN ('") )
(string-intersperse statuses "','")
"')")))
(interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
(if states-qry
(conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
"")))
(states-statuses-qry
(cond
((and states-qry statuses-qry)
(case mode
((dashboard)
(if not-in
(conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
" OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
(conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
" OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
(else (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
(states-qry
(case mode
((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry)
(else (conc " AND " states-qry))))
(statuses-qry
(case mode
((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
(else (conc " AND " statuses-qry))))
(else "")))
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT " qryvalstr
(if run-id
" FROM tests WHERE run_id=? "
" FROM tests WHERE ? > 0 ") ;; should work?
(if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
states-statuses-qry
(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
(if last-update (conc " AND last_update >= " last-update " ") "")
(case sort-by
((rundir) " ORDER BY length(rundir) ")
((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
((event_time) " ORDER BY event_time ")
(else (if (string? sort-by)
(conc " ORDER BY " sort-by " ")
" ")))
(if sort-order sort-order " ")
(if limit (conc " LIMIT " limit) " ")
(if offset (conc " OFFSET " offset) " ")
";"
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
(db:with-db dbstruct run-id #f
(lambda (db)
(sqlite3:for-each-row
(lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
db
qry
(or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
)))
(case qryvals
((shortlist)(map db:test-short-record->norm res))
((#f) res)
(else res))))
(define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time"
"host" "cpuload" "diskfree" "uname" "rundir" "item_path"
"run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" "last_update"))
(define (db:test-short-record->norm inrec)
;; "id,run_id,testname,item_path,state,status"
;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(vector (vector-ref inrec 0) ;; id
(vector-ref inrec 1) ;; run_id
(vector-ref inrec 2) ;; testname
(vector-ref inrec 4) ;; state
(vector-ref inrec 5) ;; status
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
;; 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))
;; 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)))
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs dbstruct runpatt count offset keypatts)
(let* ((res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
(if (null? keypatts) ""
(conc " AND "
(string-join
(map (lambda (keypatt)
(let ((key (car keypatt))
(patt (cadr keypatt)))
(db:patt->like key patt)))
keypatts)
" AND ")))
" AND state != 'deleted' ORDER BY event_time DESC "
(if (number? count)
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
""))))
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (cons (apply vector a x) res)))
db
qrystr
)))
(debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
(define (db:dbdat-get-path dbdat)
(if (pair? dbdat)
(cdr dbdat)
#f))
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
(string-intersperse keys ","))
;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
dbdat))
;; Get/open a database
;; if run-id => get run specific db
;; if #f => get main db
;; if db already open - return inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
(define (db:get-db alldat) ;; run-id)
(if (stack? (alldat-dbstack alldat))
(if (stack-empty? (alldat-dbstack alldat))
(let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area alldat))))
;; (stack-push! (alldat-dbstack alldat) newdb)
newdb)
(stack-pop! (alldat-dbstack alldat)))
(db:open-db alldat)))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
(let ((toppath (alldat-areapath alldat))
(configdat (alldat-mtconfig alldat))
(log-port (alldat-log-port alldat))
(tmpdb-stack (alldat-dbstack alldat))) ;; RA => Returns the first reference in alldat
(if (stack? tmpdb-stack)
(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((max-stale-tmp (configf:lookup-number configdat "server" "filling-db-max-stale-seconds" default: 10))
(dbpath (common:get-db-tmp-area alldat)) ;; path to tmp db area
(dbexists (file-exists? dbpath))
(tmpdbfname (conc dbpath "/megatest.db"))
(dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (file-exists? (conc toppath "/megatest.db")))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc toppath "/megatest.db")) #f))
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? mtdbpath))
;;(mtdbmodtime (if mtdbexists
;;(common:lazy-sqlite-db-modification-time mtdbpath)
;;#f)) ; moving this before db:open-megatest-db is
;;called. if wal mode is on -WAL and -shm file get
;;created with causing the tmpdbmodtime timestamp
;;always greater than mtdbmodtime (tmpdbmodtime (if
;;dbfexists (common:lazy-sqlite-db-modification-time
;;tmpdbfname) #f))
;;if wal mode is on -WAL and -shm file get created when
;;db:open-megatest-db is called. modtimedelta will
;;always be < 10 so db in tmp not get synced
;;(tmpdbmodtime (if dbfexists (db:get-last-update-time
;;(car tmpdb)) #f)) (fmt (file-modification-time
;;tmpdbfname))
(modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(debug:print 0 log-port "ERROR: attempted to drop triggers on MTRA/megatest.db but failed. Error is " msg)
(set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access
(when write-access
(sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
(sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")))
;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime "
;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath*
;;"/megatest.db")) (debug:print-info 13 log-port
;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists"
;;and write-access="write-access)
(if (and dbexists (not write-access))
(begin
(set! *db-write-access* #f)
(alldat-read-only-set! alldat #t)))
(alldat-mtdb-set! alldat mtdb)
(alldat-tmpdb-set! alldat tmpdb)
(alldat-dbstack-set! alldat (make-stack)) ;; why a stack?
(stack-push! (alldat-dbstack alldat) tmpdb) ;; olddb is already a (cons db path)
(alldat-refndb-set! alldat refndb)
;; (mutex-unlock! *rundb-mutex*)
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
(debug:print 1 log-port "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list alldat) #f mtdb refndb tmpdb)
;touch tmp db to avoid wal mode wierdness
(set! (file-modification-time tmpdbfname) (current-seconds))
(debug:print-info 13 log-port "db:sync-all-tables-list done.")
)
(debug:print 4 log-port " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync alldat 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
)
|