Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -364,10 +364,13 @@ (or (configf:lookup *configdat* "setup" "testsuite" ) (if *toppath* (pathname-file *toppath*) (pathname-file (current-directory))))) +(define (common:get-area-path-signature) + (message-digest-string (md5-primitive) *toppath*)) + ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) @@ -520,10 +523,31 @@ (pathname-directory (pathname-directory (pathname-directory exe-path)))) #f))) +;; return first path that can be created or already exists and is writable +;; +(define (common:get-create-writeable-dir dirs) + (if (null? dirs) + #f + (let loop ((hed (car dirs)) + (tal (cdr dirs))) + (let ((res (or (and (directory? hed) + (file-write-access? hed) + hed) + (handle-exceptions + exn + #f + (create-directory hed #t))))) + (if (and (string? res) + (directory? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -204,11 +204,11 @@ ;; (if (file-exists? fname) ;; (let ((db (sqlite3:open-database fname))) ;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) ;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; db) - (let* ((parent-dir (pathname-directory fname)) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) @@ -280,14 +280,14 @@ db) (begin (dbr:dbstruct-inmem-set! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context - (db:sync-tables db:sync-tests-only db inmem) + (db:sync-tables db:sync-tests-only #f db inmem) (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? (dbr:dbstruct-refdb-set! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db + (db:sync-tables db:sync-tests-only #f inmem refdb) ;; use inmem as the reference, don't read again from db ;; 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))))))) @@ -322,12 +322,12 @@ (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; -(define (db:open-megatest-db) - (let* ((dbpath (conc *toppath* "/megatest.db")) +(define (db:open-megatest-db #!key (path #f)) + (let* ((dbpath (or path (conc *toppath* "/megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) @@ -358,11 +358,11 @@ (> mtime stime) force-sync) (begin (db:delay-if-busy maindb) (db:delay-if-busy olddb) - (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) + (let ((num-synced (db:sync-tables (db:sync-main-list maindb) #f maindb olddb))) (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) @@ -377,11 +377,11 @@ force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) - (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) + (let ((num-synced (db:sync-tables db:sync-tests-only #f inmem refdb rundb olddb))) ;; (mutex-unlock! *http-mutex*) num-synced) (begin ;; (mutex-unlock! *http-mutex*) 0)))))) @@ -576,11 +576,15 @@ #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; -(define (db:sync-tables tbls fromdb todb . slave-dbs) +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (mutex-unlock! *db-sync-mutex*) @@ -624,15 +628,26 @@ (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) + (use-last-update (if last-update + (if (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields)) + (begin + (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields + #f)) + #f)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " " (car last-update) ">=" (cdr last-update)) + "") + ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) @@ -705,11 +720,12 @@ fromdats) (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (should-print (or (debug:debug-mode 12) + (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) @@ -781,10 +797,55 @@ FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;")) + +(define *global-db-store* (make-hash-table)) + +;; return the target db handle so it can be used +;; +(define (db:cache-for-read-only source target #!key (use-last-update #f)) + (if (and (hash-table-ref/default *global-db-store* target #f) + (>= (file-modification-time target)(file-modification-time source))) + (hash-table-ref *global-db-store* target) + (let* ((toppath (launch:setup)) + (targ-db-last-mod (if (file-exists? target) + (file-modification-time target) + 0)) + (cache-db (or (hash-table-ref/default *global-db-store* target #f) + (db:open-megatest-db path: target))) + (source-db (db:open-megatest-db path: source)) + (curr-time (current-seconds)) + (res '()) + (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f))) + (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) + (db:sync-tables db:sync-tests-only last-update source-db cache-db) + (hash-table-set! *global-db-store* target cache-db) + cache-db))) + +;; call a proc with a cached db +;; +(define (db:call-with-cached-db proc . params) + ;; first cache the db in /tmp + (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) + (fname (conc (common:get-area-path-signature) ".db")) + (cache-dir (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) "/" cname-part) + (conc "/tmp/" (current-user-name) "-" cname-part) + (conc "/tmp/" (current-user-name) "_" cname-part))))) + ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) + (if (not cache-dir) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") + (exit 1)) + (let* ((cache-db (db:cache-for-read-only + (conc *toppath* "/megatest.db") + (conc cache-dir "/" fname) + use-last-update: #t))) + (apply proc cache-db params) + )))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records @@ -819,11 +880,11 @@ ;; clear out junk records ;; (if (member 'dejunk options) (begin (db:delay-if-busy mtdb) - (db:clean-up mtdb))) + (db:clean-up mtdb))) ;; adjust test-ids to fit into proper range ;; (if (member 'adj-testids options) (begin @@ -832,11 +893,11 @@ ;; sync runs, test_meta etc. ;; (if (member 'old2new options) (begin - (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (db:sync-tables (db:sync-main-list mtdb) #f mtdb (db:get-db dbstruct #f)) (for-each (lambda (run-id) (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) @@ -887,15 +948,15 @@ (lambda () (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) (if (eq? run-id 0) (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) + (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb) (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) (begin ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) + (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb) (db:clean-up-rundb (db:get-db fromdb run-id))))) (set! count (+ count 1)) (debug:print 0 *default-log-port* "Finished clean up of " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total))))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -141,10 +141,11 @@ -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : migrate a database from v1.55 series to v1.60 series -sync-to-megatest.db : migrate data back to megatest.db + -use-db-cache : use cached access to db to reduce load -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname @@ -259,12 +260,14 @@ "-archive" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" - ) - (list "-h" "-help" "--help" + "-target-db" + "-source-db" + ) + (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" "-showkeys" @@ -277,11 +280,12 @@ "-daemonize" "-preclean" "-rerun-clean" "-rerun-all" "-clean-cache" - + "-cache-db" + "-use-db-cache" ;; misc "-repl" "-lock" "-unlock" "-list-servers" @@ -481,10 +485,18 @@ (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== + +(if (and (args:get-arg "-cache-db") + (args:get-arg "-source-db")) + (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) + (target-db (conc temp-dir "/cached.db")) + (source-db (args:get-arg "-source-db"))) + (db:cache-for-read-only source-db target-db) + (set! *didsomething* #t))) ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") (begin @@ -1039,31 +1051,41 @@ (define (get-value-by-fieldname datavec test-field-index fieldname) (let ((indx (hash-table-ref/default test-field-index fieldname #f))) (if indx (if (>= indx (vector-length datavec)) - #f ;; index to high, should raise an error I suppose + #f ;; index too high, should raise an error I suppose (vector-ref datavec indx)) #f))) +;; Add db direct +;; +(define (dispatch-query access-mode rmt-cmd db-cmd . params) + (if (eq? access-mode 'cached) + (apply db:call-with-cached-db db-cmd params) + (apply rmt-cmd params))) + ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; ;; IDEA: megatest list -runname blah% ... ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup) (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) + (access-mode (if (args:get-arg "-use-db-cache") 'cached 'rmt)) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runsdat (dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) ;; this is "-since" support. This looks at last mod times of .db files ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) @@ -1129,11 +1151,11 @@ (let* ((run-id (db:get-value-by-header run header "id")) (runname (db:get-value-by-header run header "runname")) (states (string-split (or (args:get-arg "-state") "") ",")) (statuses (string-split (or (args:get-arg "-status") "") ",")) (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + (dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc ;; use qryvals if test-spec provided (if tests-spec (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f) @@ -1254,11 +1276,11 @@ ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* ;; (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (let ((steps (dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step)