Megatest

;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;; 
(define (db:open-dbdat apath dbfile dbinit-proc)
  (let* ((db       (db:open-run-db dbfile dbinit-proc))
	 (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (make-dbr:dbdat
		    db:     db
		    inmem:  inmem
		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
		    fname:  dbfile)))
    (assert (and (sqlite3:database? db)(sqlite3:database? inmem))
	    "FATAL: should have both inmem and on-disk db at this time.")
    ;; now sync the disk file data into the inmemory db
    (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
    ;; (sqlite3:finalize! db) ;; open and close every sync
    dbdat))













;; open the disk database file
;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
(define (db:open-run-db dbfile dbinit-proc)
  (let* ((parent-dir (pathname-directory dbfile)))

;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup db-file) ;; run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
    (db:get-dbdat dbstruct *toppath* db-file)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    (assert (db:check-setup dbstruct *toppath* db-file) "FATAL: db:setup did NOT complete properly")
    dbstruct))

(define (db:check-setup dbstruct apath dbfile)
  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (dbfullname  (conc apath "/" dbfile))
	 (db          (dbr:dbdat-db dbdat)) ;; (db:open-run-db dbfullname db:initialize-db)) ;; 
	 (inmem       (dbr:dbdat-inmem dbdat)))
    (and (sqlite3:database? db)
	 (sqlite3:database? inmem))))

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;
;;  NOTE:
;;       These operate directly on the disk file, NOT on the inmemory db
;;       The lockname is the filename (can have many to one, run-id to fname 

;; ;;     (mutex-unlock! *db-multi-sync-mutex*)
;; ;;     (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))

;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))

  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (dbfullname  (conc apath "/" dbfile))
	 (db          (dbr:dbdat-db dbdat)) ;; (db:open-run-db dbfullname db:initialize-db)) ;; 
	 (inmem       (dbr:dbdat-inmem dbdat))
	 (start-t     (current-seconds))
	 (last-update (dbr:dbdat-last-write dbdat))
	 (last-sync   (dbr:dbdat-last-sync dbdat)))
    (if (and (sqlite3:database? db)
	     (sqlite3:database? inmem))
	(begin
	  (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
	  (mutex-lock! *db-multi-sync-mutex*)
	  (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;;  "last_update"))
   		 (need-sync   (or force-sync (>= last-update last-sync))))
	    (if need-sync
		(begin
		  (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
		  (dbr:dbdat-last-sync-set! dbdat start-t))
		(debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
	  ;; (sqlite3:finalize! db)
	  (mutex-unlock! *db-multi-sync-mutex*))
	(debug:print-info 0 *default-log-port* "Skipping sync due to databases not being open."))))
    
;; TODO: Add final sync to this
;;
(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
  (if (<= try-num 0)
      #f
      (handle-exceptions
	  exn
	(begin
	  (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
	  (thread-sleep! 3)
	  (sqlite3:interrupt! db)
	  (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
	(if (sqlite3:database? db)
	    (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
	      (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
	      (sqlite3:finalize! db)
	      #t)
	    #f))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
     (print-call-chain *default-log-port*))
   ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.

	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))
	(tot-count   0))

    (for-each ;; table
     (lambda (tabledat)
       (condition-case
	   (db:sync-one-table fromdb todb tabledat last-update numrecs)
	 ;; if db is busy, take a break and try one more time
	 (exn (busy)(thread-sleep! 0.5)
	      (db:sync-one-table fromdb todb tabledat last-update numrecs))))
     tbls)

    (let* ((runtime      (- (current-milliseconds) start-time))
	   (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 

                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,
                              state        TEXT DEFAULT 'new',
                              status       TEXT DEFAULT 'n/a',
                              archive_type TEXT DEFAULT 'bup',
                              du           INTEGER,
                              archive_path TEXT);")))
    (debug:print 0 *default-log-port* "creating triggers from init")
    (db:create-triggers db)    
    db)) ;; )

;;======================================================================
;; A R C H I V E S
;;======================================================================

;; dneeded is minimum space needed, scan for existing archives that 
;; are on disks with adequate space and already have this test/itempath

       (if (and (null? incompleted)
                (null? oldlaunched)
                (null? toplevels))
           #f
           #t)))))

(define (db:get-status-from-final-status-file run-dir)
  (let* ((infile (conc run-dir "/.final-status"))
	 (found  (file-exists? infile)))
    ;; first verify we are able to write the output file
    (cond
     ((not found) #f)
     ((and (file-exists? infile)
	   (not (file-readable? infile)))

      (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
      (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
      #f)

     (else
      (let ((res (condition-case
		  (with-input-from-file infile read-lines)
		  (exn (i/o file) #f))))
	(cond
	 ((equal? res "#!eof") #f)
	 ((eof-object? res)    #f)
	 (else res)))))))
     
;;  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','LAUNCHED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((incompleted '())

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (or (null? header) (not row))
      #f
      (let loop ((hed (car header))
                 (tal (cdr header))
                 (n   0))
        (if (equal? hed field);;(condition-case (vector-ref #(1 2 3) 3)(exn (bounds)(print "out of bounds")))
            (condition-case
		(vector-ref row n)
	      (exn (bounds)

		   (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
				row " header=" header " field=" field ", exn=" exn)
		   #f))

	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))

;; Accessors for the header/data structure
;; get rows and header from 
(define (db:get-header vec)(vector-ref vec 0))
(define (db:get-rows   vec)(vector-ref vec 1))

;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
;;       this is inconsistent with get-runs but it makes some sense.
;;
(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* ((res       (make-vector 11 #f))
	 (keys      (db:get-keys dbstruct))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;;  "area_id"))
	 (header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    

         (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))

(define (db:set-run-state-status dbstruct run-id state status )
  (db:with-db
   dbstruct #f #f
   (lambda (db)
          (sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))



(define (db:get-run-status dbstruct run-id)
  (let ((res "n/a"))
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (sqlite3:for-each-row 

      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id) 


  (let* ((qry  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")) ;; )
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (let* (#;(stmth (db:get-cache-stmth dbstruct db qry)))
	 #;(sqlite3:first-result stmth run-id)
	 (sqlite3:first-result db qry run-id)
	 )))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
  (db:with-db
   dbstruct

	 (item-path    (db:test-get-item-path testdat))
         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
         (tl-test-id   (if tl-testdat
			   (db:test-get-id tl-testdat)
			   #f)))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
	(db:general-call dbstruct 'set-test-start-time run-id (list test-id)))

    (db:with-db
     dbstruct run-id #f
     (lambda (db)
       (mutex-lock! *db-transaction-mutex*)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
		  ;; this call sets the item state/status
                 (db:db-test-set-state-status db run-id test-id state status comment)

                     (conc
		      (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
		       state-status-counts))); end debug:print
		       
                       (if tl-test-id
			   (db:db-test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       ))))))
         (mutex-unlock! *db-transaction-mutex*)
         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
         tr-res)))
    ;; this was moved out of test-set-state-status
    (mt:process-triggers dbstruct run-id test-id state status)))

			  "\n--> newstatus            "newstatus
			  "\n\n")

	;; NB// Pass the db so it is part of the transaction
	(list newstate newstatus))))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)

  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (mutex-lock! *db-transaction-mutex*)
     (let ((tr-res
	    (sqlite3:with-transaction
	     db
	     (lambda ()
	       (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
		      (state-statuses       (db:roll-up-rules state-status-counts #f #f ))
		      (newstate             (car state-statuses))
		      (newstatus            (cadr state-statuses))) 
		 (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
		     (begin
		       (db:set-run-state-status dbstruct run-id newstate newstatus)
		       #t) ;; changes made
		     #f) ;; no changes
		 )))))
       (mutex-unlock! *db-transaction-mutex*)
       tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
 (let* ((test-count-recs (db:with-db
                          dbstruct #f #f
                          (lambda (db)
                            (sqlite3:map-row
                             (lambda (state status count)

			    (begin
                              (handle-exceptions
                               exn
                               (begin
                                  (debug:print 0 *default-log-port*
                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
                                 res)
                              (string-substitute patt repl res)))



			    (begin
                              (debug:print 0 *default-log-port*
                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
			      res))))
	    (if (null? tal)
		newr
		(loop (car tal)(cdr tal) newr)))))))

;; run this one in a transaction where first check if host:port is taken
(define (db:register-server dbstruct host port servkey pid ipaddr apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (mutex-lock! *db-transaction-mutex*)
     (sqlite3:with-transaction
      db
      (lambda ()
	(let* ((sinfo      (db:get-server-info dbstruct apath dbname))
	       (res 	   (if sinfo
			       (begin
				 (debug:print-info 0 *default-log-port* "Server already running at "sinfo ", while trying to register server " host":"port)
				 #f) ;; server already registered
			       (begin
				 (sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
						  host port servkey pid ipaddr apath dbname)
				 (db:get-server-info dbstruct apath dbname)))))
	  (mutex-unlock! *db-transaction-mutex*)
	  res))))))
  
;; run this one in a transaction where first check if host:port is taken
(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (mutex-lock! *db-transaction-mutex*)
     (let ((res (sqlite3:with-transaction
		 db
		 (lambda ()
		   (let* ((sinfo      (db:get-server-info dbstruct apath dbname)))
		     (if (not sinfo)
			 (begin
			   (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port)
			   #f) ;; server already deregistered
			 (begin
			   (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
					    ;; host port servkey pid ipaddr
					    apath dbname)
			   #;(db:get-server-info dbstruct apath dbname)
			   'done)))))))
       (mutex-unlock! *db-transaction-mutex*)
       res))))

(define (db:get-server-info dbstruct apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row