Megatest

(define (db:with-db dbstruct run-id r/w proc . params)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:with-db called with bad dbstruct")
  (let* ((dbpath    (db:run-id->dbname run-id))
	 (dbdat     (db:get-dbdat dbstruct *toppath* dbpath))
	 (db        (dbr:dbdat-inmem dbdat))
	 (fname     (dbr:dbdat-fname dbdat))
	 (use-mutex (> *api-process-request-count* 25))) ;; was 25
    #;(if (and use-mutex
	     (common:low-noise-print 120 "over-50-parallel-api-requests"))
	(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
    #;(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
	(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
     (apply proc db params)
    #;(condition-case
     (begin
       (if use-mutex (mutex-lock! *db-with-db-mutex*))
       (let ((res (apply proc db params)))
	 (if use-mutex (mutex-unlock! *db-with-db-mutex*))
	 ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
	 res))
     (exn (io-error)

       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS servers
                                   (id INTEGER PRIMARY KEY,
                                    host TEXT,
                                    port INTEGER,
                                    servkey TEXT,
                                    pid TEXT,
                                    ipaddr TEXT,
                                    apath TEXT,
                                    dbname TEXT,
                                    event_time TIMESTAMP DEFAULT (strftime('%s','now')),
                               CONSTRAINT servers_constraint UNIQUE (apath,dbname));")

       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys
                                    (id INTEGER PRIMARY KEY,
                                     fieldname TEXT,
                                     fieldtype TEXT,
                                CONSTRAINT keyconstraint UNIQUE (fieldname));")
       

;;======================================================================
;; S E R V E R   R E C O R D S
;;======================================================================

;; these are all intended to be run against main.db

;; 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)
     (sqlite3:with-transaction
      db
      (lambda ()
	(let* ((sinfo      (db:get-server-info dbstruct apath dbname)))
	  (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)))))))))
  
(define (db:get-server-info dbstruct apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row
      (lambda (res host port servkey pid ipaddr apath dbpath)
	(list host port servkey pid ipaddr apath dbpath))
      #f
      db
      "SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;"
      apath dbname))))

)

#!/bin/bash

(killall mtest -v;sleep 1;killall mtest -v -9;rm -f tests/simplerun/.db/* tests/simplerun/logs/* tests/basicserver.log) &
ck5 make -j install &&
wait  &&
ck5 make unit

		#t)
	      (start-main-srv)))
	(start-main-srv))))

;; NB// remote is a rmt:remote struct
;;
(define (rmt:general-open-connection remote apath dbname #!key (num-tries 5))
  (let ((mdbname (db:run-id->dbname #f)))
    (cond
     ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main? 
      (rmt:open-main-connection remote apath)
      (thread-sleep! 2)
      (rmt:general-open-connection remote apath mdbname))
     ((not (rmt:get-conn remote apath dbname))                 ;; no channel open to dbname?     
      (let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname))))
	(case res
	  ((server-started)
	   (if (> num-tries 0)
	       (begin
		 (thread-sleep! 2)
		 (rmt:general-open-connection remote apath dbname num-tries: (- num-tries 1)))

	       (begin
		 (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname)
		 (exit 1))))
	  (else
	   (if (list? res) ;; server has been registered and the info was returned. pass it on.
	       res
	       (begin
		 (debug:print-info 0 *default-log-port* "Unexpected result: " res)
		 res)))))))))

;;======================================================================

;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
  (let* ((apath *toppath*)
	 (conns *rmt:remote*)
	 (dbname (db:run-id->dbname rid)))
    (rmt:general-open-connection conns apath dbname)
    (rmt:send-receive-real conns apath dbname cmd params)))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
  (let* ((conn (rmt:get-conn remote apath dbname)))
    (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
    (let* ((payload (sexpr->string params))
	   (res      (with-input-from-request
		      (rmt:conn->uri conn "api")
		      `((params . ,payload)
			(cmd    . ,cmd)

  (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)
  (let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))))
    ;; now register in the run db itself

    ;; NEED A RECORD INSERT INCLUDING SETTING id
    (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)))

					      (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
					      (db:with-lock-db (servdat-dbfile *server-info*)
							       (lambda (dbh dbfile)
								 (db:release-lock dbh dbfile))))
					    (let* ((sdat *server-info*)) ;; we have a run-id server
					      (rmt:send-receive-real *rmt:remote* *toppath*
								     (db:run-id->dbname #f)
								     'register-server
								     `(,(servdat-uuid sdat)
								       ,(current-process-id)
								       ,(servdat-host sdat)   ;; iface
								       ,(servdat-port sdat))))))))
			      (if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
				  (let ((db (cdr (bdat-task-db *bdat*))))
				    (if (sqlite3:database? db)

		  (begin
		    (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
		    (exit))
		  (loop start-time
			(equal? sdat last-sdat)
			sdat))))))))

(define (rmt:register-server remote apath iface port server-key dbname)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f) 'register-server `(,iface
								   ,port
								   ,server-key
								   ,(current-process-id)
								   ,iface
								   ,apath
								   ,dbname)))

(define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100))
  ;; wait until *server-info* stops changing
  (let loop ((sdat  #f) ;; this is our copy of the *last* *server-info*
	     (tries 0))
    ;; first we verify port and interface, update *server-info* in need be.
    (cond

		'(a "b" 123 1.23 )))
(test #f #t (number? (rmt:send-receive 'ping #f 'hello)))

(define *db* (db:setup #f))

;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
(define keyvals  '(("SYSTEM" "a")("RELEASE" "b")))

(test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/2.db")))
(set! *dbstruct-db* #f)
(test #f #t (rmt:open-main-connection remote apath))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname)))

(thread-sleep! 2)
(test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db")))

(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
(test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f)))
(test #t 1 (rmt:send-receive 'register-run run-id (list keyvals "run1" "new" "n/a" "justme" #f)))

(test #f 1 (rmt:register-run keyvals "run2" "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"))))
;;