Megatest

tdb.scm at tip
Login

File tdb.scm from the latest check-in


>;;======================================================================
;; 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"))))
;;     
)