>;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
(declare (unit tdb))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses mtargs))
(declare (uses rmtmod))
(module tdb
*
(import scheme
chicken
data-structures
)
(require-extension (srfi 18) extras tcp)
(import srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5
message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(import commonmod
debugprint
rmtmod
(prefix mtargs args:))
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;; (include "run_records.scm")
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
;;======================================================================
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
;; (assert (number? run-id) "FATAL: Run id required.")
;; (let* ((test-path (if (string? work-area)
;; work-area
;; (rmt:test-get-rundir-from-test-id run-id test-id))))
;; (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;; (open-test-db test-path)))
;; =not-used= ;; Create the sqlite db for the individual test(s)
;; =not-used= ;;
;; =not-used= ;; Moved these tables into <runid>.db
;; =not-used= ;; THIS CODE TO BE REMOVED
;; =not-used= ;;
;; =not-used= (define (open-test-db work-area)
;; =not-used= (debug:print-info 11 *default-log-port* "open-test-db " work-area)
;; =not-used= (if (and work-area
;; =not-used= (directory? work-area)
;; =not-used= (file-read-access? work-area))
;; =not-used= (let* ((dbpath (conc work-area "/testdat.db"))
;; =not-used= (dbexists (common:file-exists? dbpath))
;; =not-used= (work-area-writeable (file-write-access? work-area))
;; =not-used= (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
;; =not-used= exn
;; =not-used= (begin
;; =not-used= (print-call-chain (current-error-port))
;; =not-used= (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
;; =not-used= ((condition-property-accessor 'exn 'message) exn))
;; =not-used= (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
;; =not-used= (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
;; =not-used= (if (or work-area-writeable
;; =not-used= dbexists)
;; =not-used= (sqlite3:open-database dbpath)
;; =not-used= (sqlite3:open-database ":memory:"))))
;; =not-used= (tdb-writeable (and (file-write-access? work-area)
;; =not-used= (file-write-access? dbpath)))
;; =not-used= (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
;; =not-used= (string->number (args:get-arg "-override-timeout"))
;; =not-used= 136000))))
;; =not-used=
;; =not-used= (if (and tdb-writeable
;; =not-used= *db-write-access*)
;; =not-used= (sqlite3:set-busy-handler! db handler))
;; =not-used= (if (not dbexists)
;; =not-used= (begin
;; =not-used= (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
;; =not-used= (debug:print-info 11 *default-log-port* "Initialized test database " dbpath)
;; =not-used= (tdb:testdb-initialize db)))
;; =not-used= ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
;; =not-used= (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area)
;; =not-used= ;; now let's test that everything is correct
;; =not-used= (handle-exceptions
;; =not-used= exn
;; =not-used= (begin
;; =not-used= (print-call-chain (current-error-port))
;; =not-used= (debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
;; =not-used= dbpath ".\n "
;; =not-used= ((condition-property-accessor 'exn 'message) exn))
;; =not-used= #f)
;; =not-used= ;; Is there a cheaper single line operation that will check for existance of a table
;; =not-used= ;; and raise an exception ?
;; =not-used= (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
;; =not-used= db)
;; =not-used= ;; no work-area or not readable - create a placeholder to fake rest of world out
;; =not-used= (let ((baddb (sqlite3:open-database ":memory:")))
;; =not-used= (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area)
;; =not-used= ;; provide an in-mem db (this is dangerous!)
;; =not-used= (tdb:testdb-initialize baddb)
;; =not-used= baddb)))
;; =not-used=
;; =not-used= ;; find and open the testdat.db file for an existing test
;; =not-used= (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
;; =not-used= (let* ((test-path (if work-area
;; =not-used= work-area
;; =not-used= (rmt:test-get-rundir-from-test-id test-id))))
;; =not-used= (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;; =not-used= (open-test-db test-path)))
;; =not-used=
;; =not-used= ;; find and open the testdat.db file for an existing test
;; =not-used= (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
;; =not-used= (let* ((test-path (if work-area
;; =not-used= work-area
;; =not-used= (db:test-get-rundir-from-test-id dbstruct run-id test-id))))
;; =not-used= (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;; =not-used= (open-test-db test-path)))
;; =not-used=
;; =not-used= ;; find and open the testdat.db file for an existing test
;; =not-used= (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
;; =not-used= (let* ((test-path (if work-area
;; =not-used= work-area
;; =not-used= (db:test-get-rundir-from-test-id dbstruct run-id test-id)))
;; =not-used= (tdb (open-test-db test-path)))
;; =not-used= (apply proc tdb params)))
;; =not-used=
;; =not-used= (define (tdb:testdb-initialize db)
;; =not-used= (debug:print 11 *default-log-port* "db:testdb-initialize START")
;; =not-used= (sqlite3:with-transaction
;; =not-used= db
;; =not-used= (lambda ()
;; =not-used= (for-each
;; =not-used= (lambda (sqlcmd)
;; =not-used= (sqlite3:execute db sqlcmd))
;; =not-used= (list "CREATE TABLE IF NOT EXISTS test_rundat (
;; =not-used= id INTEGER PRIMARY KEY,
;; =not-used= update_time TIMESTAMP,
;; =not-used= cpuload INTEGER DEFAULT -1,
;; =not-used= diskfree INTEGER DEFAULT -1,
;; =not-used= diskusage INTGER DEFAULT -1,
;; =not-used= run_duration INTEGER DEFAULT 0);"
;; =not-used= "CREATE TABLE IF NOT EXISTS test_data (
;; =not-used= id INTEGER PRIMARY KEY,
;; =not-used= test_id INTEGER,
;; =not-used= category TEXT DEFAULT '',
;; =not-used= variable TEXT,
;; =not-used= value REAL,
;; =not-used= expected REAL,
;; =not-used= tol REAL,
;; =not-used= units TEXT,
;; =not-used= comment TEXT DEFAULT '',
;; =not-used= status TEXT DEFAULT 'n/a',
;; =not-used= type TEXT DEFAULT '',
;; =not-used= CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
;; =not-used= "CREATE TABLE IF NOT EXISTS test_steps (
;; =not-used= id INTEGER PRIMARY KEY,
;; =not-used= test_id INTEGER,
;; =not-used= stepname TEXT,
;; =not-used= state TEXT DEFAULT 'NOT_STARTED',
;; =not-used= status TEXT DEFAULT 'n/a',
;; =not-used= event_time TIMESTAMP,
;; =not-used= comment TEXT DEFAULT '',
;; =not-used= logfile TEXT DEFAULT '',
;; =not-used= CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
;; =not-used= ;; test_meta can be used for handing commands to the test
;; =not-used= ;; e.g. KILLREQ
;; =not-used= ;; the ackstate is set to 1 once the command has been completed
;; =not-used= "CREATE TABLE IF NOT EXISTS test_meta (
;; =not-used= id INTEGER PRIMARY KEY,
;; =not-used= var TEXT,
;; =not-used= val TEXT,
;; =not-used= ackstate INTEGER DEFAULT 0,
;; =not-used= CONSTRAINT metadat_constraint UNIQUE (var));"))))
;; =not-used= (debug:print 11 *default-log-port* "db:testdb-initialize END"))
;; =not-used=
;; =not-used= ;; This routine moved to db:read-test-data
;; =not-used= ;;
;; =not-used= (define (tdb:read-test-data tdb test-id categorypatt)
;; =not-used= (let ((res '()))
;; =not-used= (sqlite3:for-each-row
;; =not-used= (lambda (id test_id category variable value expected tol units comment status type)
;; =not-used= (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
;; =not-used= tdb
;; =not-used= "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
;; =not-used= (sqlite3:finalize! tdb)
;; =not-used= (reverse res)))
;;======================================================================
;; T E S T D A T A
;;======================================================================
;; ;; get a list of test_data records matching categorypatt
;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f))
;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)))
;; (if (sqlite3:database? tdb)
;; (let ((res '()))
;; (sqlite3:for-each-row
;; (lambda (id test_id category variable value expected tol units comment status type)
;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
;; tdb
;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
;; (sqlite3:finalize! tdb)
;; (reverse res))
;; '())))
;; NOTE: Run this local with #f for db !!!
(define (tdb:load-test-data run-id test-id)
(let loop ((lin (read-line)))
(if (not (eof-object? lin))
(begin
(debug:print 4 *default-log-port* lin)
;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
(rmt:csv->test-data run-id test-id lin)
;;)
(loop (read-line)))))
;; roll up the current results.
;; FIXME: Add the status too
(rmt:test-data-rollup run-id test-id #f))
;; ;; NOTE: Run this local with #f for db !!!
;; (define (tdb:load-logpro-data run-id test-id)
;; (let loop ((lin (read-line)))
;; (if (not (eof-object? lin))
;; (begin
;; (debug:print 4 *default-log-port* lin)
;; ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
;; (rmt:csv->test-data run-id test-id lin)
;; ;;)
;; (loop (read-line)))))
;; ;; roll up the current results.
;; ;; FIXME: Add the status too
;; (rmt:test-data-rollup run-id test-id #f))
;;======================================================================
;; S T E P S
;;======================================================================
(define (tdb:step-get-time-as-string vec)
(seconds->time-string (tdb:step-get-event_time vec)))
;; get a pretty table to summarize steps
;;
;; NOT USED, WILL BE REMOVED
;;
(define (tdb:get-steps-table steps);; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status Duration Logfile
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
;; Move this to steps.scm
;;
;; get a pretty table to summarize steps
;;
(define (tdb:get-steps-table-list steps)
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
;;
;; Move to steps.scm
;;
(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s))
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s))
(vector-ref x 3) ;; status
(vector-ref x 4)
(vector-ref x 5))) ;; time delta
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b))))))))
;;
;; (define (tdb:remote-update-testdat-meta-info run-id test-id work-area
;; cpuload diskfree minutes)
;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
;; (if (sqlite3:database? tdb)
;; (begin
;; (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
;; cpuload diskfree minutes)
;; (sqlite3:finalize! tdb))
;; (debug:print 2 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant"))))
;;
)