Overview
| Comment: | Added instrumentation to many database access routines |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
333996fd2f6085fd109c739f3f6dff82 |
| User & Date: | matt on 2012-10-18 23:50:58 |
| Other Links: | manifest | tags |
Context
|
2012-10-19
| ||
| 17:02 | Changed rpc info messages to level 12, added debug to test4 invocation of server, added option to run server in conjunction with -runall or -runtests check-in: 73998460e8 user: mrwellan tags: trunk | |
|
2012-10-18
| ||
| 23:50 | Added instrumentation to many database access routines check-in: 333996fd2f user: matt tags: trunk | |
| 22:45 | Null merge from sqlite3-logging, everything was cherrypicked earlier? check-in: 61707d689e user: matt tags: trunk | |
Changes
Modified db.scm from [eec092b8fe] to [8c633b99ea].
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
((string-match (regexp "no" #t) syncval) 0)
((string-match (regexp "(off|normal|full)" #t) syncval) syncval)
(else
(debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
#f))))
(if val
(begin
| | | > > > > | > < > > | 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 |
((string-match (regexp "no" #t) syncval) 0)
((string-match (regexp "(off|normal|full)" #t) syncval) syncval)
(else
(debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
#f))))
(if val
(begin
(debug:print-info 11 "db:set-sync, setting pragma synchronous to " val)
(sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
(debug:print-info 11 "open-db, dbpath=" dbpath)
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(db:initialize db))
(db:set-sync db)
db))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-no-exception-handling START, idb=" idb ", params=" params)
(let* ((db (if idb idb (open-db)))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! db))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res))
(define (open-run-close-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-exception-handling START, idb=" idb ", params=" params)
(let ((runner (lambda ()
(let* ((db (if idb idb (open-db)))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! db))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res))))
(handle-exceptions
exn
(begin
(debug:print 0 "EXCEPTION: database probably overloaded?")
(debug:print 0 " " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain)
(thread-sleep! (random 120))
(debug:print-info 0 "trying db call one more time....")
(runner))
(runner))))
(define open-run-close open-run-close-exception-handling)
(define *global-delta* 0)
(define *last-global-delta-printed* 0)
(define (open-run-close-measure proc idb . params)
(debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params)
(let* ((start-ms (current-milliseconds))
(db (if idb idb (open-db)))
(throttle (string->number (config-lookup *configdat* "setup" "throttle"))))
(db:set-sync db)
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! db))
;; scale by 10, average with current value.
(set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
(if throttle throttle 0.01)))
2))
(if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
(begin
(debug:print-info 1 "launch throttle factor=" *global-delta*)
(set! *last-global-delta-printed* *global-delta*)))
(debug:print-info 11 "open-run-close-measure END" )
res))
(define (db:initialize db)
(debug:print-info 11 "db:initialize START")
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys)))
(for-each (lambda (key)
(let ((keyn (vector-ref key 0)))
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
;; Must do this *after* running patch db !! No more.
(db:set-var db "MEGATEST_VERSION" megatest-version)
))
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; Create the sqlite db for the individual test(s)
(define (open-test-db testpath)
(if (and (directory? testpath)
(file-read-access? testpath))
(let* ((dbpath (conc testpath "/testdat.db"))
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
| > > | < > > > | > | 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 |
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
;; Must do this *after* running patch db !! No more.
(db:set-var db "MEGATEST_VERSION" megatest-version)
(debug:print-info 11 "db:initialize END")
))
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; Create the sqlite db for the individual test(s)
(define (open-test-db testpath)
(debug:print-info 11 "open-test-db " testpath)
(if (and (directory? testpath)
(file-read-access? testpath))
(let* ((dbpath (conc testpath "/testdat.db"))
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000))))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(begin
(sqlite3:execute db "PRAGMA synchronous = FULL;")
(debug:print 0 "Initialized test database " dbpath)
(db:testdb-initialize db)))
;; (sqlite3:execute db "PRAGMA synchronous = 0;")
(debug:print-info 11 "open-test-db END (sucessful)" testpath)
db)
(begin
(debug:print-info 11 "open-test-db END (unsucessful)" testpath)
#f)))
;; find and open the testdat.db file for an existing test
(define (db:open-test-db-by-test-id db test-id)
(let* ((test-path (db:test-get-rundir-from-test-id db test-id)))
(open-test-db test-path)))
(define (db:testdb-initialize db)
(debug:print 11 "db:testdb-initialize START")
(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,
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
;; 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,
| | > | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 |
;; 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 "db:testdb-initialize END"))
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
|
| ︙ | ︙ | |||
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 |
;;======================================================================
;; meta get and set vars
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
(define (db:get-var db var)
(let* ((start-ms (current-milliseconds))
(throttle (let ((t (config-lookup *configdat* "setup" "throttle")))
(if t (string->number t) t)))
(res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db "SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
;; scale by 10, average with current value.
(set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
(if throttle throttle 0.01)))
2))
(if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
(begin
(debug:print-info 4 "launch throttle factor=" *global-delta*)
(set! *last-global-delta-printed* *global-delta*)))
res))
(define (db:set-var db var val)
| > > > | > > > > | 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 |
;;======================================================================
;; meta get and set vars
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
(define (db:get-var db var)
(debug:print-info 11 "db:get-var START " var)
(let* ((start-ms (current-milliseconds))
(throttle (let ((t (config-lookup *configdat* "setup" "throttle")))
(if t (string->number t) t)))
(res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db "SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
;; scale by 10, average with current value.
(set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
(if throttle throttle 0.01)))
2))
(if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
(begin
(debug:print-info 4 "launch throttle factor=" *global-delta*)
(set! *last-global-delta-printed* *global-delta*)))
(debug:print-info 11 "db:get-var END " var)
res))
(define (db:set-var db var val)
(debug:print-info 11 "db:set-var START " var " " val)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)
(debug:print-info 11 "db:set-var END " var " " val)
)
;; use a global for some primitive caching, it is just silly to re-read the db
;; over and over again for the keys since they never change
(define (db:get-keys db)
(if *db-keys* *db-keys*
(let ((res '()))
(debug:print-info 11 "db:get-keys START (cache miss)")
(sqlite3:for-each-row
(lambda (key keytype)
(set! res (cons (vector key keytype) res)))
db
"SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;")
(set! *db-keys* res)
(debug:print-info 11 "db:get-keys END (cache miss)")
res)))
(define (db:get-value-by-header row header field)
(debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field)
(if (null? header) #f
(let loop ((hed (car header))
(tal (cdr header))
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 | " ORDER BY event_time DESC " (if (number? count) (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) "")))) | | > > > | > > | > > | > | > | > | > > | 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 |
" ORDER BY event_time DESC "
(if (number? count)
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
""))))
(debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (cons (apply vector a x) res)))
db
qrystr
)
(debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
;; just get count of runs
(define (db:get-num-runs db runpatt)
(let ((numruns 0))
(debug:print-info 11 "db:get-num-runs START " runpatt)
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
db
"SELECT COUNT(id) FROM runs WHERE runname LIKE ?;" runpatt)
(debug:print-info 11 "db:get-num-runs END " runpatt)
numruns))
;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
(define (db:get-run-info db run-id)
(if (hash-table-ref/default *run-info-cache* run-id #f)
(hash-table-ref *run-info-cache* run-id)
(let* ((res #f)
(keys (db:get-keys db))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append (map key:get-fieldname keys)
remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ","))))
(debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
(conc "SELECT " keystr " FROM runs WHERE id=?;")
run-id)
(debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
(hash-table-set! *run-info-cache* run-id finalres)
finalres))))
(define (db:set-comment-for-run db run-id comment)
(debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment)
(sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)
(debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment))
;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run db run-id)
(sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id))
(define (db:update-run-event_time db run-id)
(debug:print-info 11 "db:update-run-event_time START run-id: " run-id)
(sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)
(debug:print-info 11 "db:update-run-event_time END run-id: " run-id))
(define (db:lock/unlock-run db run-id lock unlock user)
(let ((newlockval (if lock "locked"
(if unlock
"unlocked"
"locked")))) ;; semi-failsafe
(sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
(sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
user (conc newlockval " " run-id))
(debug:print-info 1 "" newlockval " run number " run-id)))
;;======================================================================
;; K E Y S
;;======================================================================
;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs db run-id)
(let* ((keys (get-keys db))
(res '()))
(debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")))
;; (debug:print 0 "qry: " qry)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (list (key:get-fieldname key) key-val) res)))
db qry run-id)))
keys)
(debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id)
(reverse res)))
;; get key vals for a given run-id
(define (db:get-key-vals db run-id)
(let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f)))
(if mykeyvals
mykeyvals
(let* ((keys (get-keys db))
(res '()))
(debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")))
;; (debug:print 0 "qry: " qry)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons key-val res)))
db qry run-id)))
keys)
(debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id)
(let ((final-res (reverse res)))
(hash-table-set! *keyvals* run-id final-res)
final-res)))))
;; The target is keyval1/keyval2..., cached in *target* as it is used often
(define (db:get-target db run-id)
(let ((mytarg (hash-table-ref/default *target* run-id #f)))
(if mytarg
mytarg
(let* ((keyvals (db:get-key-vals db run-id))
(thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
(hash-table-set! *target* run-id thekey)
thekey))))
;;======================================================================
;; T E S T S
;;======================================================================
(define (db:tests-register-test db run-id test-name item-path)
(debug:print-info 11 "db:tests-register-test START db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(for-each
(lambda (pth)
(sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');"
run-id
test-name
pth))
item-paths)
(debug:print-info 11 "db:tests-register-test END db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
#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
(define (db:get-tests-for-run db run-id testpatt states statuses
#!key (not-in #t)
(sort-by #f) ;; 'rundir 'event_time
)
(debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by)
(let* ((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 not-in "NOT" "")
" IN ('"
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
(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
run-id
;; (if testpatt testpatt "%")
;; (if itempatt itempatt "%"))
)
res))
;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db test-id)
;; Breaking it into two queries for better file access interleaving
(let* ((tdb (db:open-test-db-by-test-id db test-id)))
;; test db's can go away - must check every time
| > | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
(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
run-id
;; (if testpatt testpatt "%")
;; (if itempatt itempatt "%"))
)
(debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by)
res))
;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db test-id)
;; Breaking it into two queries for better file access interleaving
(let* ((tdb (db:open-test-db-by-test-id db test-id)))
;; test db's can go away - must check every time
|
| ︙ | ︙ |