Megatest

;;     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/>.
;;
;;======================================================================

(use srfi-69 posix srfi-18)

(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))

    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))

(define *db-write-mutexes* (make-hash-table))
(define *api-watchdog* #f)

(define (api:watchdog dbstruct) ;; trim not-used sqlite3 db handles
  (let* ((th1 (make-thread (lambda ()
			     (let loop ()
			       (thread-sleep! 60) ;; 2x the age we close at
			       (db:close-old dbstruct)
			       (loop)))
			   "api:watchdog thread")))
    (thread-start! th1)
    (set! *api-watchdog* th1)))
    
;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
  (db:open-no-sync-db) ;; sets *no-sync-db*
  (if (not *api-watchdog*)(api:watchdog dbstruct))






  (if (> *api-process-request-count* 200)
      (begin
	(if (common:low-noise-print 30 "too many threads")
	    (debug:print 0 *default-log-port* "WARNING: "*api-process-request-count*" threads, potential overload, adding 0.5 sec delay."))
	(thread-sleep! 0.5) ;; take a nap
	))
   (cond
    ((not (vector? dat))                    ;; it is an error to not receive a vector
     (vector #f (vector #f "remote must be called with a vector")))




    (else  
     (let* ((cmd-in            (vector-ref dat 0))
            (cmd               (if (symbol? cmd-in)
				   cmd-in
				   (string->symbol cmd-in)))
            (params            (vector-ref dat 1))
	    (run-id            (if (null? params)

                                  (testpatt  (let ((tlast (rmt:tasks-get-last target runname)))
                                                (if tlast
                                                    (let ((tpatt (tasks:task-get-testpatt tlast)))
                                                      (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
                                                          "%"
                                                          tpatt))
                                                    "%")))
                                  ;(item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) ; why calling rmt:get-test-info-by-id twice??
                                  (item-path (db:test-get-item-path test-info))
                                  (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path)))
                                  (status-chars (char-set->list (string->char-set status)))
                                  (run-id       (dboard:tabdat-curr-run-id tabdat)))
                             (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
                             (cond

					      (testpatt  (let ((tlast (rmt:tasks-get-last target runname)))
							   (if tlast
							       (let ((tpatt (tasks:task-get-testpatt tlast)))
								 (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
								     "%"
								     tpatt))
							       "%")))
                                              ;(item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
                                              (item-path (db:test-get-item-path test-info))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")

		       ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
		       #t)
		      ((and changed *time-to-exit*) ;; last sync
		       #t)
		      (else
		       #f))))
          (if (or dejunk do-cp)

	     (let* ((start-time (current-milliseconds))

                    (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
                    (mtdb      (dbr:subdb-mtdbdat subdb))
                    (tmpdb     (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))


	       (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")

               (if old2new
                 (begin
                   (if dejunk (db:clean-up run-id mtdb))
		   (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb)
                 )

;; moving watch dogs here due to dependencies
;;======================================================================

;;======================================================================
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
;; (define (common:readonly-watchdog dbstruct)
;;   (thread-sleep! 0.05) ;; delay for startup
;;   (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
;;   ;; sync megatest.db to /tmp/.../megatst.db
;;   (let* ((sync-cool-off-duration   3)
;;         (golden-mtdb     (dbr:dbstruct-mtdb dbstruct))
;;         (golden-mtpath   (db:dbdat-get-path golden-mtdb))
;;         (tmp-mtdb        (dbr:dbstruct-tmpdb dbstruct))
;;         (tmp-mtpath      (db:dbdat-get-path tmp-mtdb)))
;;     (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
;;     (let loop ((last-sync-time 0))
;;       (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
;;       (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
;;         (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
;;         (if (and (not *time-to-exit*)
;;                  (< duration-since-last-sync sync-cool-off-duration))
;;             (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
;;         (if (not *time-to-exit*)
;;             (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
;;                   (tmp-mtdb-mtime    (file-modification-time tmp-mtpath)))
;; 	      (if (> golden-mtdb-mtime tmp-mtdb-mtime)
;; 		  (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
;; 		      (let ((res (db:multi-db-sync dbstruct 'old2new)))
;; 			(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
;;               (loop (current-seconds)))
;;             #t)))
;;     (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
;; 

;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f

(define (db:lock-and-sync no-sync-db from-db to-db)
  (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
  (let* ((lockdat  (db:no-sync-get-lock no-sync-db from-db))
	 (gotlock  (car lockdat))

  (dbname      #f) ;; .megatest/1.db
  (mtdbfile    #f) ;; mtrah/.megatest/1.db
  (mtdbdat     #f) ;; only need one of these for syncing
  ;; (dbdats      (make-hash-table))  ;; id => dbdat 
  (tmpdbfile   #f) ;; /tmp/.../.megatest/1.db
  ;; (refndbfile  #f) ;; /tmp/.../.megatest/1.db_ref
  (dbstack     (make-stack)) ;; stack for tmp dbr:dbdat,
  (stack-mutex (make-mutex)) ;; gate pop, push, peek and replace with this mutex (allows safe clean up of old handles)
  (homehost    #f) ;; not used yet
  (on-homehost #f) ;; not used yet
  (read-only   #f)
  (last-sync   0)
  (last-write  (current-seconds))
  )                ;; goal is to converge on one struct for an area but for now it is too confusing

;; need to keep dbhandles and cached statements together
(defstruct dbr:dbdat
  (dbfile      #f)
  (dbh         #f)    
  (stmt-cache  (make-hash-table))
  (read-only   #f)
  (birth-sec   (current-seconds))
  (last-used   (current-seconds))
  (in-use      #f))

(define *dbstruct-dbs* #f)
(define *db-open-mutex* (make-mutex))
(define *db-access-mutex* (make-mutex)) ;; used in common.scm
(define *no-sync-db*   #f)
(define *db-sync-in-progress* #f)
(define *db-with-db-mutex*    (make-mutex))

             (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db")
	     #f
            )
        ))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with non-dbstruct "dbstruct)






  (let* ((subdbs     (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
    (for-each
     (lambda (subdb)
       (mutex-lock! (dbr:subdb-stack-mutex subdb))
       (let* ((tdbs       (stack->list (dbr:subdb-dbstack subdb)))
	      (mtdbdat    (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb))))


	 (map (lambda (dbdat)
		(let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat))
		       (dbh        (dbr:dbdat-dbh        dbdat)))
		  (db:safely-close-sqlite3-db dbh stmt-cache)))
	      tdbs)
	 (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache  (dbr:subdb-mtdbdat subdb))))


       (mutex-unlock! (dbr:subdb-stack-mutex subdb)))
     subdbs)))


;; close  opened run-id dbs that haven't been used in age seconds
(define (db:close-old dbstruct #!key (age 30)) ;; close dbs older than this age
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-old called with non-dbstruct "dbstruct)
  (let* ((subdbs     (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
    (for-each
     (lambda (subdb)
       (mutex-lock! (dbr:subdb-stack-mutex subdb))
       (let* ((tdbs       (stack->list (dbr:subdb-dbstack subdb)))
	      (mtdbdat    (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb))))
	 (dbr:subdb-dbstack-set! subdb (make-stack)) ;; replace the stack with a new one
	 (map (lambda (dbdat)
		(assert (not (dbr:dbdat-in-use dbdat)) "FATAL: dbdat in stack was in use "(dbr:dbdat-dbfile dbdat) " in use" (dbr:dbdat-in-use dbdat) "Stack length " (length tdbs) "time diff " (- (current-seconds) (dbr:dbdat-last-used dbdat)))
		(if (< (- (current-seconds)
			  (dbr:dbdat-last-used dbdat))
		       age)
		    (stack-push! (dbr:subdb-dbstack subdb) dbdat)    ;; keep it
		    (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat)) ;; close and discard
			   (dbh        (dbr:dbdat-dbh        dbdat)))
		      (dbfile:print-err "INFO: closing unused dbdat for "(dbr:dbdat-dbfile dbdat))
		      (db:safely-close-sqlite3-db dbh stmt-cache))))
	      tdbs)
	 (let* ((size  (stack-count (dbr:subdb-dbstack subdb)))
		(delta (- (length tdbs) size)))
	   (if (> delta 0)
	       (dbfile:print-err "INFO: removed "delta" and "size" dbs left."))))
       (mutex-unlock! (dbr:subdb-stack-mutex subdb)))
     subdbs)))


;; ;; set up a single db (e.g. main.db, 1.db ... etc.)
;; ;;
;; (define (db:setup-db dbstruct areapath run-id)
;;   (let* ((dbname   (db:run-id->dbname run-id))
;; 	 (dbstruct (hash-table-ref/default dbstructs dbname #f)))
;;     (if dbstruct

;;    if run-id is a string treat it as a filename
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (dbfile:get-dbdat dbstruct run-id)
  (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
    (mutex-lock! (dbr:subdb-stack-mutex subdb))
    (let* ((res (if (stack-empty? (dbr:subdb-dbstack subdb))
		    #f

		    (let ((dbdat (stack-pop! (dbr:subdb-dbstack subdb))))
		      (dbr:dbdat-last-used-set! dbdat (current-seconds))
		      (dbr:dbdat-in-use-set! dbdat #t)
		      dbdat))))
      (mutex-unlock! (dbr:subdb-stack-mutex subdb))
      res)))

;; return a previously opened db handle to the stack of available handles
(define (dbfile:add-dbdat dbstruct run-id dbdat)
  (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
    (dbr:dbdat-in-use-set! dbdat #f)
    (stack-push! (dbr:subdb-dbstack subdb) dbdat)
    dbdat))

;; set up a subdb
;;
(define (dbfile:init-subdb dbstruct run-id init-proc)
  (let* ((dbname    (dbfile:run-id->dbname run-id))

	  (dbfile:open-db dbstruct run-id init-proc))
	(let* ((dbdat (dbfile:get-dbdat dbstruct run-id)))
	  (if dbdat
	      dbdat
	      (let* ((tmppath   (dbr:dbstruct-tmppath  dbstruct))
		     (tmpdbpath (dbfile:run-id->path tmppath run-id))
		     (dbdat     (dbfile:open-sqlite3-db tmpdbpath init-proc sync-mode: 0 journal-mode: "WAL")))
                (dbr:dbdat-in-use-set! dbdat #t)
		;; the following line short-circuits the "one db handle per thread" model
		;; 
		;; (dbfile:add-dbdat dbstruct run-id dbdat)
		;;
		dbdat))))))
    
;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open