Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -878,11 +878,12 @@ (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) ;; (filter ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) ;; testsdat))) (if (not matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + ;;(vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (make-db:test-rec (id -1)) ;; (car matching)))) matching))) (testname (db:test-get-testname testdat)) (itempath (db:test-get-item-path testdat)) (testfullname (test:test-get-fullname testdat)) @@ -1396,12 +1397,12 @@ last-update) *dashboard-mode*) '()))) ;; get 'em all ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) + (let* ((aval (db:test-get-testname a));;(vector-ref a 2)) + (bval (db:test-get-testname b));;(vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) (if (and anum bnum) (< anum bnum) (string<= aval bval))))))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2013, Matthew Welland. +;; Copyright 2006-2016, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -11,14 +11,16 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) +;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc + +(require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension? (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) (import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) +(import (prefix base64 base64:)) ;; RADT => prefix?? (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -37,17 +39,17 @@ ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (print "err-status: " err-status) (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)))) -;; convert to -inline +;; convert to -inline RADT => how inline? (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) @@ -64,11 +66,11 @@ ;; 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 dbstruct run-id) +(define (db:get-db dbstruct run-id) ;; RADT => Where is dbstruct defined? (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin (let ((dbdat (if (or (not run-id) (eq? run-id 0)) @@ -75,10 +77,12 @@ (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) dbdat)))) +;;RADT => Purpose of dbdat? +;; (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) @@ -88,10 +92,11 @@ #f)) ;; mod-read: ;; 'mod modified data ;; 'read read data +;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct ;; (define (db:done-with dbstruct run-id mod-read) (if (not (sqlite3:database? dbstruct)) (begin (mutex-lock! *rundb-mutex*) @@ -106,19 +111,19 @@ ;; (define (db:with-db dbstruct run-id r/w proc . params) (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) + (db (db:dbdat-get-db dbdat))) ;;RADT => dbdat should already be a database, why need this function (db:delay-if-busy dbdat) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) - (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) ;; RA => Mark timestamp on defstruct RADT => How come 'mod not passed instead of r/w res)))) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== @@ -147,33 +152,35 @@ ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) (let* ((dbdir (db:get-dbdir)) (fname (if run-id - (if (eq? run-id 0) "main.db" (conc run-id ".db")) + (if (eq? run-id 0) "main.db" (conc run-id ".db")) ;;main.db is assigned if run-id 0; does it mean main.db same as 1.db??? #f))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname - (conc dbdir "/" fname) + (conc dbdir "/" fname) ;;RADT => why not creating fname db if does not exist here dbdir))) +;; Returns the database location as specified in config file +;; (define (db:get-dbdir) (or (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) + (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; RADT => advantage of PRAGMA here?? ;; open an sql database inside a file lock -;; ;; returns: db existed-prior-to-opening +;; RA => Returns a db handler; sets the lock if opened in writable mode ;; (define (db:lock-create-open fname initproc) ;; (if (file-exists? fname) ;; (let ((db (sqlite3:open-database fname))) ;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) @@ -262,14 +269,14 @@ ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem))))))) -;; This routine creates the db. It is only called if the db is not already ls opened +;; This routine creates the db if not already present. It is only called if the db is not already ls opened ;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let ((mdb (dbr:dbstruct-get-main dbstruct))) +(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((mdb (dbr:dbstruct-get-main dbstruct))) ;; RA => Returns the first reference in dbstruct (if mdb mdb (begin (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path 0)) @@ -2251,11 +2258,14 @@ (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))) + ;;(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))) + ;;(print (cons a b)) + (set! res (cons (alist->db:test-rec (db:qry-gen-alist qryvalstr (cons a b))) res))) + db qry run-id ))) (case qryvals @@ -2284,24 +2294,26 @@ (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (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 - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + ;;(set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + (cons (make-db:test-rec id: id testname: testname item_path: item-path state: state status: status) res)) db qry run-id))) res)) (define (db:get-testinfo-state-status dbstruct run-id test-id) - (let ((res #f)) + (let ((res '())) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (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 - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + ;;(set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + (cons (make-db:test-rec run_id: run-id testname: testname item_path: item-path state: state status: status) res)) db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) @@ -2568,12 +2580,16 @@ (res '())) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - res))) + ;;(set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) + (cons (make-db:test-rec id: id run-id: run-id testname: testname state: state status: status event_time: event-time + host: host cpuload: cpuload diskfree: diskfree uname: uname rundir: rundir item_path: item-path + run_duration: run-duration final_logf: final-logf comment: comment shortdir: shortdir + attemptnum: attemptnum archived: archived ) + res)) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") run-id) res)) @@ -2643,13 +2659,19 @@ run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) + (lambda (id run-id test-name state status event-time host cpu-load disk-free uname run-dir item-path run-duration final-logf comment short-dir attempt-num archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) + ;;(set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final-logf comment short-dir attemptnum archived))) + (set! res (cons + (make-db:test-rec id: id run-id: run-id test-name: test-name state: state status: status event-time: event-time + host: host cpu-load: cpu-load disk-free: disk-free uname: uname run-dir: run-dir item-path: item-path + run-duration: run-duration final-logf: final-logf comment: comment short-dir: short-dir + attempt-num: attempt-num archived: archived ) + res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -2679,11 +2701,11 @@ #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) - (set! res (apply vector a b))) + (print a));;set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") test-name item-path) res)))) @@ -3349,12 +3371,14 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) +;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval +;; (define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (if (not (configf:lookup *configdat* "server" "delay-on-busy")) ;;RADT => two conditions in a if block?? also understand what config looked up (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"))) @@ -3361,11 +3385,11 @@ (if (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) + (db:delay-if-busy count (- count 1))) ;; RADT => Don't we need to sent a dbstruct here? (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) @@ -3385,11 +3409,11 @@ (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else (debug:print-info 0 *default-log-port* "delaying db access due to high database load.") (thread-sleep! 12.8)))) - db) + db) ;; RADT => why does it need to return db, not #t "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 Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -63,30 +63,63 @@ (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) (define (dbr:dbstruct-set-localdb! v run-id db) (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) - -(define (make-db:test)(make-vector 20)) -(define-inline (db:test-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) -(define-inline (db:test-get-testname vec) (vector-ref vec 2)) -(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-process_id vec) (vector-ref vec 16)) -(define-inline (db:test-get-archived vec) (vector-ref vec 17)) +(require-extension typed-records) +(defstruct db:test-rec ((id -1) : number) + ((run-id -1) : number) + ((test-name "") : string) + ((state "") : string) + ((status "") : string) + ((event-time -1) : number) + ((host "") : string) + ((cpu-load -1) : number) + ((disk-free -1) : number) + ((uname "") : string) + ((run-dir "") : string) + ((item-path "") : string) + ((run-duration -1) : number) + ((final-logf "") : string) + ((comment "") : string) + ((process-id -1) : number) + ((archived -1) : number) + ((short-dir -1) : number) + ((attempt-num -1) : number)) + +(define (db:qry-gen-alist qrystr listvals) + (define listqry (string-split qrystr ",")) + (if (null? listqry) + '() + (let loop ((strhead (car listqry)) + (strtail (cdr listqry)) + (valhead (car listvals)) + (valtail (cdr listvals)) + (res '())) + (let* ((slot-val-pair (cons (string->symbol strhead) valhead))) + (if (or (null? strtail) + (null? valtail)) + (cons slot-val-pair res);;(print strhead valhead));;(cons (cons (string->symbol strhead) valhead) res)) + (loop (car strtail)(cdr strtail)(car valtail)(cdr valtail)(cons slot-val-pair res))))))) + +(define (db:test-get-id typed-rec) (db:test-rec-id typed-rec)) +(define (db:test-get-run_id typed-rec) (db:test-rec-run_id typed-rec)) +(define (db:test-get-testname typed-rec) (db:test-rec-testname typed-rec)) +(define (db:test-get-state typed-rec) (db:test-rec-state typed-rec)) +(define (db:test-get-status typed-rec) (db:test-rec-status typed-rec)) +(define (db:test-get-event_time typed-rec) (db:test-rec-event_time typed-rec)) +(define (db:test-get-host typed-rec) (db:test-rec-host typed-rec)) +(define (db:test-get-cpuload typed-rec) (db:test-rec-cpuload typed-rec)) +(define (db:test-get-diskfree typed-rec) (db:test-rec-diskfree typed-rec)) +(define (db:test-get-uname typed-rec) (db:test-rec-uname typed-rec)) +(define (db:test-get-rundir typed-rec) (db:test-rec-rundir typed-rec)) +(define (db:test-get-item-path typed-rec) (db:test-rec-item_path typed-rec)) +(define (db:test-get-run_duration typed-rec) (db:test-rec-run_duration typed-rec)) +(define (db:test-get-final_logf typed-rec) (db:test-rec-final_logf typed-rec)) +(define (db:test-get-comment typed-rec) (db:test-rec-comment typed-rec)) +(define (db:test-get-process_id typed-rec) (db:test-rec-process_id typed-rec)) +(define (db:test-get-archived typed-rec) (db:test-rec-archived typed-rec)) ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))