Megatest

;; iterated tests
;;
(defstruct dbr:counts
  (state #f)
  (status #f)
  (count  0)) 

;; Retrieve a dbdat given run-id, open and setup both inmemory and
;; db file if needed
;;
;;    if run-id => get run specific db
;;    if #f     => get main.db
;;    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 (db:get-dbdat dbstruct apath run-id)
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct run-id)))
    (if dbdat
	dbdat
	(let* ((dbfile   (db:run-id->path apath run-id))
	       (newdbdat (db:open-dbdat apath run-id db:initialize-db)))
	  (dbr:dbstruct-dbdat-put! dbstruct run-id newdbdat)
	  newdbdat))))

;; get the inmem db for actual db operations
;;
(define (db:get-inmem dbstruct run-id)
  (dbr:dbdat-inmem (db:get-dbdat dbstruct run-id)))

;; get the handle for the on-disk db
;;
(define (db:get-ddb dbstruct apath run-id)
  (dbr:dbdat-db (db:get-dbdat dbstruct apath run-id)))

;; 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 run-id dbinit-proc)
  (let* ((dbfile   (db:run-id->path apath run-id))
	 (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
		    fname:  dbfile)))
    ;; now sync the disk file data into the inmemory db
    (db:sync-tables (db:sync-all-tables-list) #f db inmem)
    dbdat))

;; open the disk database file
;; NOTE: May need to add locking to file create process here

;; ;;     (set! *db-last-access* start-t)
;; ;;     (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 run-id #!key (force-sync #f))
  (let* ((dbdat       (db:get-dbdat dbstruct run-id))
	 (db          (dbr:dbdat-db dbstruct))
	 (inmem       (dbr:dbdat-inmem dbstruct))
	 (start-t     (current-seconds))
	 (last-update (dbr:dbdat-last-write dbdat))
	 (last-sync   (dbr:dbdat-last-sync dbdat)))
    (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
    (mutex-lock! *db-multi-sync-mutex*)
    (let* ((update_info (cons (if force-sync 0 last-update) "last_update"))
    	   (need-sync   (or force-sync (>= last-update last-sync))))
      (mutex-unlock! *db-multi-sync-mutex*)
      (if need-sync
	  (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
	  (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))

;;======================================================================
;; END NEW SERVER METHOD
;;======================================================================

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running) 
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
  (let* ((run-id            (let ((rid (args:get-arg "-run-id")))
			      (if rid
				  (string->number rid)
				  #f)))


	 (db-file           (db:run-id->path *toppath* run-id))
	 (sdat              #f)
	 (tmp-area          (common:get-db-tmp-area))
	 (server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (server:mk-signature))
	 (server-info (let loop ((start-time (current-seconds))
				 (changed    #t)
				 (last-sdat  "not this"))
                        (begin ;; let ((sdat #f))
			  (thread-sleep! 0.01)
			  (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if (and sdat
				   (not changed)
				   (> (- (current-seconds) start-time) 2))
			      (begin
				(debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server")
				;; create a server pkt in *toppath*/.meta/srvpkts

				(register-server pkts-dir *srvpktspec* (get-host-name)
						 (cadr sdat) server-key (car sdat) db-file)

				;; now read pkts and see if we are a contender
				(let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
				       (viables      (get-viable-servers all-pkts db-file))
				       (best-srv     (get-best-candidate viables db-file))

	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))
      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not *dbstruct-db* )
	  (let ((watchdog (bdat-watchdog *bdat*)))
	    (debug:print 0 *default-log-port* "SERVER: dbprep")

	    (db:setup run-id) ;; sets *dbstruct-db* as side effect

	    (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
	    (if watchdog
		(if (not (member (thread-state watchdog) '(ready running blocked sleeping dead)))
		    (begin
		      (debug:print-info 0 "Starting watchdog thread (in state "(thread-state watchdog)")")
		      (thread-start! watchdog)))
		(debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))))

;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch)
  (let* ((tmp-area            (common:get-db-tmp-area))
	 (server-start        (conc tmp-area "/.server-start"))
	 (server-started      (conc tmp-area "/.server-started"))
	 (start-time          (common:lazy-modification-time server-start))
	 (started-time        (common:lazy-modification-time server-started))
	 (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
	 (start-time-old      (> (- (current-seconds) start-time) 5))
         (cleanup-proc        (lambda (msg)
                                (let* ((serv-fname      (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
                                       (full-serv-fname (conc *toppath* "/logs/" serv-fname))
                                       (new-serv-fname  (conc *toppath* "/logs/" "defunct-" serv-fname)))
                                  (debug:print 0 *default-log-port* msg)
                                  (if (common:file-exists? full-serv-fname)
                                      (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname))
                                      (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
                                  (exit)))))
    (common:save-pkt `((action . start)
		       (T      . server)
		       (pid    . ,(current-process-id)))
		     *configdat* #t)
    (let* ((th2 (make-thread (lambda ()
                               (debug:print-info 0 *default-log-port* "Server run thread started")
                               (http-transport:run 
                                (if (args:get-arg "-server")
                                    (args:get-arg "-server")
                                    "-")
                                )) "Server run"))
           (th3 (make-thread (lambda ()
                               (debug:print-info 0 *default-log-port* "Server monitor thread started")
                               (http-transport:keep-running)
                               "Keep running"))))
      (thread-start! th2)
      (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
      (thread-start! th3)
      (set! *didsomething* #t)
      (thread-join! th2)
      (exit))))

;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
    (http-transport:launch))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;;

     			":runname"
     			"-runname"
     			":state"  
     			"-state"
     			":status"
     			"-status"
     			"-list-runs"
                             "-testdata-csv"
     			"-testpatt"
                             "--modepatt"
                             "-modepatt"
                             "-tagexpr"
     			"-itempatt"
     			"-setlog"
     			"-set-toplog"
     			"-runstep"
     			"-logpro"
     			"-m"
     			"-rerun"
     
     			"-days"
     			"-rename-run"
     			"-to"
     			"-dest"
                             "-source" 
                             "-time-stamp" 
     			;; values and messages
     			":category"
     			":variable"
     			":value"
     			":expected"
     			":tol"
     			":units"
     
     			;; misc
     			"-start-dir"
                             "-run-patt"
                             "-target-patt"   
     			"-contour"
                             "-area-tag"  
                             "-area"  
     			"-run-tag"
     			"-server"

     			"-adjutant"
     			"-transport"
     			"-port"
     			"-extract-ods"
     			"-pathmod"
     			"-env2file"
     			"-envcap"
     			"-envdelta"
     			"-setvars"
     			"-set-state-status"
     
                             ;; move runs stuff here
                             "-remove-keep"           
     			"-set-run-status"
     			"-age"
     
     			;; archive 
     			"-archive"
     			"-actions"
     			"-precmd"

     			"-var"
     			"-dumpmode"
     			"-run-id"
     			"-ping"
     			"-refdb2dat"
     			"-o"
     			"-log"
                             "-sync-log"
     			"-since"
     			"-fields"
     			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
     			"-sort"
     			"-target-db"
     			"-source-db"
     			"-prefix-target"
     
                             "-src-target"
                             "-src-runname"
                             "-diff-email"
     			"-sync-to"			
     			"-pgsync"
     			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)
                             "-diff-html"
     
     			;; wizards, area capture, setup new ...
     			"-extract-skeleton"
     			)
      		 (list  "-h" "-help" "--help"
     			"-manual"
     			"-version"

     
     			;; misc
     			"-repl"
     			"-lock"
     			"-unlock"
     			"-list-servers"
     			"-kill-servers"
                             "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
     			"-one-pass"      ;;
     			"-local"         ;; run some commands using local db access
     			"-generate-html"
     			"-generate-html-structure" 
     			"-list-run-time"
                             "-list-test-time"
     			

     ;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
     ;;   we start the server if not running else start the client thread
     ;;======================================================================
     
     ;; Server? Start up here.
     ;;
     (if (args:get-arg "-server")


         (let ((tl        (launch:setup))
               (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
           (server:launch 0 transport-type)
           (set! *didsomething* #t)))
     
     ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
     ;; a specific Megatest area. Detail are being hashed out and this may change.
     ;;
     (if (args:get-arg "-adjutant")
         (begin
           (adjutant-run)
           (set! *didsomething* #t)))