Megatest

(define (db:general-sqlite-error-dump exn stmt . params)
  (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 
;;
(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)
     (if (eq? err-status 'done)

			     (eq? run-id 0))
			 (db:open-main dbstruct)
			 (db:open-rundb dbstruct run-id)
			 )))
	  dbdat))))

;; legacy handling of structure for managing db's. Refactor this into dbr:?
;;
(define (db:dbdat-get-db dbdat)
  (if (pair? dbdat)
      (car dbdat)
      dbdat))

(define (db:dbdat-get-path dbdat)
  (if (pair? dbdat)

;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
  (let* ((dbdat (if (dbr:dbstruct? 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))) 
    (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))

    (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) 
	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")))

			   (file-write-access? fname)
			   dir-writable )))
    (if file-write ;; dir-writable
	(let (;; (lock    (obtain-dot-lock fname 1 5 10))
	      (db      (sqlite3:open-database fname)))
	  (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	  (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	  (if (not file-exists)(initproc db))
	  (if (not file-exists)
	      (begin
		(if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp
		    (sqlite3:execute db "PRAGMA journal_mode=WAL;")
		    (print "Creating " fname " in NON-WAL mode."))
		(initproc db)))
	  ;; (release-dot-lock fname)
	  db)
	(begin
	  (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
	  (sqlite3:open-database fname))))) ;; )

;; This routine creates the db. It is only called if the db is not already opened

	    (if (and (not dbexists)
		     *db-write-access*) ;; did not have a prior db and do have write access
		(db:multi-db-sync #f 'old2new))  ;; migrate data from megatest.db automatically
	    dbdat)))))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; open the local db for direct access (no server)
;;
(define (db:open-local-db-handle)
  (or *dbstruct-db*
      (let ((dbstruct (db:setup #f local: #t)))
	(set! *dbstruct-db* dbstruct)
	dbstruct)))
	  
;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db)
  (let* ((dbpath       (conc *toppath* "/megatest.db"))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)

	      (set! tot-count (+ tot-count count))
	      (if (> count 0)
		  (if should-print (debug:print 0 *default-log-port* (format #f "    ~10a ~5a" tblname count))))))
	  (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
       tot-count)))
   (mutex-unlock! *db-sync-mutex*)))


(define (db:patch-schema-rundb run-id frundb)
  ;;
  ;; remove this some time after September 2016 (added in version v1.6031
  ;;
  (for-each
   (lambda (table-name)
     (handle-exceptions
      exn
      (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
          (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
          (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
      (sqlite3:execute
       frundb
       (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
     (sqlite3:execute
      frundb
      (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
     (sqlite3:execute
      frundb
      (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE " table-name " SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))
     )
   '("tests" "test_steps" "test_data")))

(define (db:patch-schema-maindb run-id maindb)
  ;;
  ;; remove all these some time after september 2016 (added in v1.6031
  ;;
  (handle-exceptions
   exn
   (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
       (debug:print 0 *default-log-port* "Column last_update already added to runs table")
       (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none"))
   (sqlite3:execute
    maindb
    "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0"))
  ;; these schema changes don't need exception handling
  (sqlite3:execute
   maindb
   "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE runs SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;")
  (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats (
                              id     INTEGER PRIMARY KEY,
                              run_id INTEGER,
                              state  TEXT,
                              status TEXT,
                              count  INTEGER,
                              last_update INTEGER DEFAULT (strftime('%s','now')))")
  (sqlite3:execute maindb "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db

    (if (member 'new2old options)
	(let* ((maindb      (make-dbr:dbstruct path: toppath local: #t))
	       (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0)))))
	       (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <))
	       (count       1)
	       (total       (length all-run-ids))
	       (dead-runs  '()))
          ;; first fix schema if needed
	  (for-each
	   (lambda (run-id)
          (map
           (lambda (th)
             (thread-join! th))
           (map
            (lambda (run-id)
	     (debug:print 0 *default-log-port* "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total)
	     (set! count (+ count 1))
	     (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
		    (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
              (thread-start! 
               (make-thread
                (lambda ()
                  (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
                         (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
	       ;; (db:delay-if-busy frundb)
	       ;; (db:delay-if-busy mtdb)
	       ;; (db:clean-up frundb)
	       (if (eq? run-id 0)
		   (let ((maindb  (db:dbdat-get-db (db:get-db fromdb #f))))
                    (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)
		     (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))
                          (db:patch-schema-maindb run-id maindb))
		     ;; 
		     ;; Feb 18, 2016: add field last_update to runs table
                        (db:patch-schema-rundb run-id frundb)))
		     ;;
		     ;; remove all these some time after september 2016 (added in v1.6031
		     ;;
		     (handle-exceptions
		      exn
		      (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
			  (debug:print 0 *default-log-port* "Column last_update already added to runs table")
			  (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none"))
                  (set! count (+ count 1))
                  (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
            all-run-ids))
		      (sqlite3:execute
		       maindb
          ;; Then sync and fix db's
		       "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0"))
		     ;; these schema changes don't need exception handling
		     (sqlite3:execute
		      maindb
          (set! count 0)
          (process-fork
           (lambda ()
             (map
		      "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE runs SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;")
		     (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats (
                              id     INTEGER PRIMARY KEY,
                              run_id INTEGER,
                              state  TEXT,
                              status TEXT,
                              count  INTEGER,
                              last_update INTEGER DEFAULT (strftime('%s','now')))")
		     (sqlite3:execute maindb "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
              (lambda (th)
                (thread-join! th))
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
              (map
               (lambda (run-id)
                 (thread-start! 
                  (make-thread
                   (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)
                               END;")
		     )
		   (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:clean-up-rundb (db:get-db fromdb run-id))
                           (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)
                             (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:clean-up-rundb (db:get-db fromdb run-id)))))
		     ;;
		     ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data
		     ;;
		     ;; remove this some time after September 2016 (added in version v1.6031
		     ;;
		     (for-each
                     (set! count (+ count 1))
		      (lambda (table-name)
			(handle-exceptions
			 exn
			 (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
			     (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
                     (debug:print 0 *default-log-port* "Finished clean up of "
			     (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
			 (sqlite3:execute
			  frundb
                                  (if (eq? run-id 0)
			  (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
			(sqlite3:execute
			 frundb
			 (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
                                      " main.db " (conc run-id ".db")) ", " count " of " total)))))
			(sqlite3:execute
			 frundb
               all-run-ids))))
			 (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE " table-name " SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))
			)

		      '("tests" "test_steps" "test_data"))))))
	   all-run-ids)
	  ;; removed deleted runs
          ;; removed deleted runs
	  (let ((dbdir (tasks:get-task-db-path)))
	    (for-each (lambda (run-id)
			(let ((fullname (conc dbdir "/" run-id ".db")))
			  (if (file-exists? fullname)
			      (begin
				(debug:print 0 *default-log-port* "Removing database file for deleted run " fullname)
				(delete-file fullname)))))

    
    (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
    (if (and (null? incompleted)
	     (null? oldlaunched)
	     (null? toplevels))
	#f
	#t)))

;; given a launch delay (minimum time from last launch) return amount of time to wait
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
  

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)

;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (res     '())
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
    (for-each (lambda (keyval)
		(let* ((key    (car keyval))
		       (patt   (cadr keyval))

			       (conc " AND last_update >= " last-update " ")
			       " ")
			" ORDER BY event_time "
			(if limit  (conc " LIMIT " limit)   "")
			(if offset (conc " OFFSET " offset) "")
			";"))
    (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
    (vector header 
            (reverse
    (db:with-db dbstruct #f #f ;; reads db, does not write to it.
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (a . r)
		     (set! res (cons (list->vector (cons a r)) res)))
		   db
		   qry-str
		   runnamepatt)))
             (db:with-db dbstruct #f #f ;; reads db, does not write to it.
                         (lambda (db)
                           (sqlite3:fold-row
                            (lambda (res . r)
                              (cons (list->vector r) res))
                            '()
                            db
                            qry-str
                            runnamepatt)))))))
    (vector header res)))

;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
(define (db:get-run-info dbstruct run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((dbdat     (db:get-db dbstruct #f))
	 (db        (db:dbdat-get-db dbdat))

    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode 
       (z3:encode-buffer
	(with-output-to-string
	  (lambda ()(serialize obj)))))
	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
      #t))
    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))
    (else obj))) ;; rpc

(define (db:string->obj msg #!key (transport 'http))
  (case transport
    ;; ((fs) msg)
    ((http fs)
     (if (string? msg)
	 (with-input-from-string 
	     (z3:decode-buffer
	      (base64:base64-decode
	       (string-substitute 
		(regexp "_") "=" msg #t)))
	   (lambda ()(deserialize)))
	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received " msg " but cannot translate it.")
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg)))
    (else msg))) ;; rpc

(define (db:test-set-status-state dbstruct run-id test-id status state msg)
  (let ((dbdat  (db:get-db dbstruct run-id)))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
	(db:general-call dbdat 'set-test-start-time (list test-id)))
    (if msg
	(db:general-call dbdat 'state-status-msg (list state status msg test-id))

		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval
;; return the sqlite3 db handle if possible
;; 
(define (db:delay-if-busy dbdat #!key (count 6))
  (if (not (configf:lookup *configdat* "server" "delay-on-busy")) ;;RADT => two conditions in a if block?? also understand what config looked up
  (if (not (configf:lookup *configdat* "server" "delay-on-busy")) 
      (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")))
	    (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))) 
		 (file-exists? dbfj))
		(case count
		  ((6)
		   (thread-sleep! 0.2)
		   (db:delay-if-busy count: 5))
		  ((5)
		   (thread-sleep! 0.4)

		   (db:delay-if-busy count: 1))
		  ((1)
		   (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) ;; RADT => why does it need to return db, not #t
	    db) 
	  "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
     dbstruct
     run-id