Megatest

;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (make-dbr:dbstruct))
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))
	 (db-file  (db:run-id->path *toppath* run-id)))
    (db:get-dbdat dbstruct *toppath* db-file)
    (set! *dbstruct-db* dbstruct)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    dbstruct))

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

;; ;;     (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 dbfile #!key (force-sync #f))
  (let* ((dbdat       (db:get-dbdat dbstruct dbfile))
	 (db          (dbr:dbdat-db dbstruct))
	 (inmem       (dbr:dbdat-inmem dbstruct))
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))
  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (db          (dbr:dbdat-db dbdat))
	 (inmem       (dbr:dbdat-inmem dbdat))
	 (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 dbfile: " dbfile)
    (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
       (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.")))
    (mutex-lock! *db-multi-sync-mutex*)
    (dbr:dbdat-last-sync-set! dbdat start-t)
    (mutex-unlock! *db-multi-sync-mutex*)))


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

		)) ;; we can safely cache megatest.config since we have a valid runconfig
	  data))))

;;======================================================================
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)
  (debug:print-info 13 *default-log-port* "common:watchdog entered.")
  (assert *toppath* "common:watchdog started before *toppath* is set")
  (let* ((start-time (current-seconds))
	 (am-server  (args:get-arg "-server"))
	 (dbfile     (args:get-arg "-db"))
	 (apath      *toppath*))
    (let loop ()
      (thread-sleep! 5) ;; add control / setting for this
  #;(if (launch:setup)
      (if (common:on-homehost?)
	  (let ((dbstruct (db:setup #t)))
	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
	    (cond
	     ((dbr:dbstruct-read-only dbstruct)
	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
	      (common:readonly-watchdog dbstruct))
	     (else
	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
              (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
                (cond
                 ((equal? syncer "brute-force-sync")
                  (server:writable-watchdog-bruteforce dbstruct))
                 ((equal? syncer "delta-sync")
                  (server:writable-watchdog-deltasync dbstruct))
                 (else
                  (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
                  (exit 1)))
                ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
                )))
	    (debug:print-info 13 *default-log-port* "watchdog done."))
	  (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
      (if am-server
	  (if (not  *dbstruct-db*)
	      (loop)
	      (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile))))))
  
;; 
;; (let ((dbstruct 
;; 	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
;; 	    (cond
;; 	     ((dbr:dbstruct-read-only dbstruct)
;; 	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
;; 	      (common:readonly-watchdog dbstruct))
;; 	     (else
;; 	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
;;             (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
;;               (cond
;;                ((equal? syncer "brute-force-sync")
;;                 (server:writable-watchdog-bruteforce dbstruct))
;;                ((equal? syncer "delta-sync")
;;                 (server:writable-watchdog-deltasync dbstruct))
;;                (else
;;                 (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
;;                 (exit 1)))
;;               ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
;;               )))
;; 	    (debug:print-info 13 *default-log-port* "watchdog done."))
;; 	  (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))

;;======================================================================
;; 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)
  #f)

			(delay-loop (+ count 1))))
		  (if (not (bdat-time-to-exit *bdat*)) (loop))))
	    ;; time to exit, close the no-sync db here
	    (db:no-sync-close-db no-sync-db stmt-cache)
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " (bdat-time-to-exit *bdat*)" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num)))))))

(define (server:writable-watchdog-bruteforce dbstruct)
#;(define (server:writable-watchdog-bruteforce dbstruct)
  (thread-sleep! 1) ;; delay for startup
  (let* ((do-a-sync  (server:get-bruteforce-syncer dbstruct))
         (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t)))
    (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync
	       (args:get-arg "-server"))
      
      (let loop ()
	(do-a-sync)
        (if (not (bdat-time-to-exit *bdat*)) (loop))) ;; keep going unless time to exit

      ;; time to exit, close the no-sync db here
      (final-sync)

      (if (common:low-noise-print 30)
	  (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = "(bdat-time-to-exit *bdat*)" pid="(current-process-id)
			    )))))

;; moving this here as it needs access to db and cannot be in common.
;;

(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
#;(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
  (let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
         (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
	 (tmp-area     (common:get-db-tmp-area))
	 (tmp-db       (conc tmp-area "/megatest.db"))
	 (staging-file (conc *toppath* "/.megatest.db"))
	 (mtdbfile     (conc *toppath* "/megatest.db"))
	 (lockfile     (common:get-sync-lock-filepath))

     			"-create-megatest-area"
     			"-mark-incompletes"
     
     			"-convert-to-norm"
     			"-convert-to-old"
     			"-import-megatest.db"
     			"-sync-to-megatest.db"
                             "-sync-brute-force"
			"-sync-brute-force"
     			"-logging"
     			"-v" ;; verbose 2, more than normal (normal is 1)
     			"-q" ;; quiet 0, errors/warnings only
     
                             "-diff-rep"
     
     			"-syscheck"

            'dejunk
            'adj-testids
            'old2new
            ;; 'new2old
            )
           (set! *didsomething* #t)))
     
     (when (args:get-arg "-sync-brute-force")
     #;(when (args:get-arg "-sync-brute-force")
       ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
       (set! *didsomething* #t))
     
     #;(if (args:get-arg "-sync-to-megatest.db")
         (let* ((dbstruct (db:setup #f))
     	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
     	   (lockfile (conc tmpdbpth ".lock"))

  (rmt:send-receive 'get-num-runs #f (list runpatt)))

(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
  (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt  targetpatt keys)))

;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user contour)
  ;; first register in main.db (thus the #f)
  (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
  (let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))))
    ;; now register in the run db itself
    (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour))
    run-id))
  
    
(define (rmt:get-run-name-from-id run-id)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))

(define (rmt:delete-run run-id)
  (rmt:send-receive 'delete-run run-id (list run-id)))

;;	(exit 1))))

(define (common:run-sync?)
    ;; (and (common:on-homehost?)
  (args:get-arg "-server"))




;; this one seems to be the general entry point
;;
(define (server:start-and-wait areapath #!key (timeout 60))
#;(define (server:start-and-wait areapath #!key (timeout 60))
  (let ((give-up-time (+ (current-seconds) timeout)))
    (let loop ((server-info (server:check-if-running areapath))
	       (try-num    0))
      (if (or server-info
	      (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
	  (server:record->url server-info)
	  (let ((num-ok (length (server:get-best (server:get-list areapath)))))

    (if res
        server-url
	#f)))

;; no longer care if multiple servers are started by accident. older
;; servers will drop off in time.
;;
;; defunct
;;
(define (server:check-if-running areapath) ;;  #!key (numservers "2"))
#;(define (server:check-if-running areapath) ;;  #!key (numservers "2"))
  (let* ((ns            (server:get-num-servers))
	 (servers       (server:get-best (server:get-list areapath))))
    (if (or (and servers
		 (null? servers))
	    (not servers)
	    (and (list? servers)
		 (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers
        #f
        (let loop ((hed (car servers))
                   (tal (cdr servers)))
          (let ((res (server:check-server hed)))
            (if res
                hed
                (if (null? tal)
                    #f
                    (loop (car tal)(cdr tal)))))))))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
;;
;; defunct
;;
(define (server:kind-run areapath)
#;(define (server:kind-run areapath)
  ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
  ;; and wait for it to be at least 3 seconds old
  ;; (server:wait-for-server-start-last-flag areapath)
  (if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
      (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun
	     (call-num     (car last-run-dat))
	     (when-run     (cadr last-run-dat))

  (http-transport:client-connect iface port)
  #;(case (server:get-transport)
    ((rpc)  (rpc:client-connect  iface port))
    ((http) (http:client-connect iface port))
    ((zmq)  (zmq:client-connect  iface port))
    (else   (rpc:client-connect  iface port))))

;;
;; defunct
;;
(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
#;(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
  (print "got here")
  ;; (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
  #;(case (server:get-transport)
    ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
    ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
    (else  (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))

 ;; with-input-from-request
 ;; rmt:get-connection
 ;; with-input-from-request
 )

(define *db* (db:setup #f))
(test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/1.db")))
(set! *dbstruct-db* #f)
(test #f 'server-started (rmt:general-open-connection *rmt:remote* *toppath* ".db/1.db"))
(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))

(test #f 1 (rmt:register-run '(("SYSTEM" "a")("RELEASE" "b")) "run1" "new" "n/a" "justme" #f))

;; (delete-file* "logs/1.log")
;; (define run-id 1)

;; (test "setup for run" #t (begin (launch:setup)
;;  				(string? (getenv "MT_RUN_AREA_HOME"))))
;;