Megatest

(define (db:run-id->first-num run-id)
  (let* ((s (number->string run-id))
	 (l (string-length s)))
    (substring s (- l 1) l)))

;; 1234 => 4/1234.db
;;   #f => 0/main.db
;;   (abandoned the idea of num/db)
;; 
(define (db:run-id->path apath run-id)
  (conc apath"/"(db:run-id->dbname run-id)))

(define (db:dbname->path apath dbname)
  (conc apath"/"dbname))

;;  (let ((firstnum (if run-id
;; 		      (db:run-id->first-num run-id)
;; 		      "0")))
;;    (conc *toppath* "/.dbs/" ;; firstnum"/"
;; 	  (or run-id "main")".db")))

(define (db:run-id->dbname run-id)
  (if (number? run-id)
      (conc ".db/" (modulo run-id 100) ".db")
      (conc ".db/main.db")))
  

;; record for keeping state,status and count for doing roll-ups in
;; 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)))

;; 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)))
    (db:get-dbdat dbstruct *toppath* run-id)
    (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
;;       The lockname is the filename (can have many to one, run-id to fname 
;;======================================================================

(define (db:get-iam-server-lock dbstruct apath run-id)
  (let* ((dbh     (db:get-ddb apath dbstruct run-id))
	 (dbfname (db:run-id->path run-id)))
    (sqlite3:with-transaction
     dbh
     (lambda ()
       (let* ((locked (db:get-locker dbh dbfname)))
	 (if (not locked)
	     (db:take-lock dbh dbfname)))))))

     ptype: 'server)))

;; ya, fake it for now
;;
(define (register-server-in-db db-file)
  #t)

(define (get-pkts-dir #!optional (apath #f))
  (let* ((effective-toppath (or *toppath* apath)))
    (assert effective-toppath
	    "ERROR: get-pkts-dir called without *toppath* set. Exiting.")
    (let* ((pdir (conc effective-toppath "/.meta/srvpkts")))
      (if (file-exists? pdir)
	  pdir
	  (begin
	    (create-directory pdir #t)
	    pdir)))))

;; given a pkts dir read 
;;
(define (get-all-server-pkts pktsdir-in pktspec)
  (let* ((pktsdir  (if (file-exists? pktsdir-in)
		       pktsdir-in
		       (begin

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

          (args:get-arg "-diff-email"))
         (set! *didsomething* #t)
         (exit 0)))
     
     (if (or (getenv "MT_RUNSCRIPT")
     	(args:get-arg "-repl")
     	(args:get-arg "-load"))
         (let* ((toppath (launch:setup)))
		
     	        ;; (dbstruct (if (and toppath
		;; 	      #;(common:on-homehost?))
		;; 	 (db:setup #f) ;; sets up main.db
		;; 	 #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
	   (if *toppath*
	       (cond
		((getenv "MT_RUNSCRIPT")
		 ;; How to run megatest scripts
		 ;;
		 ;; #!/bin/bash
		 ;;
		 ;; export MT_RUNSCRIPT=yes
		 ;; megatest << EOF
		 ;; (print "Hello world")
		 ;; (exit)
		 ;; EOF
		 
		 (repl))
		(else
		 (begin
		   ;; (set! *db* dbstruct)
		   ;; (import extras) ;; might not be needed
		   ;; (import csi)
		   ;; (import readline)
		   (import apropos
			   archivemod
			   commonmod
			   configfmod
			   dbmod
			   debugprint
			   ezstepsmod
			   http-transportmod
			   launchmod
			   processmod
			   rmtmod
			   runsmod
			   servermod
			   tasksmod
			   testsmod)
		   
		   (set-history-length! 300)
		   
		   (load-history-from-file ".megatest_history")
		   
		   (current-input-port (make-linenoise-port))
		   ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
		   
		   ;; (if *use-new-readline*
		   ;; 	  (begin
		   ;; 	    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
		   ;; 	    (current-input-port (make-readline-port "megatest> ")))
		   ;; 	  (begin
		   ;; 	    (gnu-history-install-file-manager
		   ;; 	     (string-append
		   ;; 	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
		   ;; 	    (current-input-port (make-gnu-readline-port "megatest> "))))
		   (if (args:get-arg "-repl")
		       (repl)
		       (load (args:get-arg "-load")))
		   ;; (db:close-all dbstruct) <= taken care of by on-exit call
		   )
		 (exit)))
	       (set! *didsomething* #t))))
     
     ;;======================================================================
     ;; Wait on a run to complete
     ;;======================================================================
     
     (if (and (args:get-arg "-run-wait")
     	 (not (or (args:get-arg "-run")

			#f)))
	  (if cinfo
	      cinfo
	      (if (server:check-if-running areapath)
		  (client:setup areapath)
		  #f))))

(defstruct rmt:remote
  (conns (make-hash-table)) ;; apath/dbname => rmt:conn
  )

(defstruct rmt:conn
  (apath    #f)
  (dbname   #f)
  (fullname #f)
  (hostport #f)
  (lastmsg  0)
  (expires  0))

(define *rmt:remote* (make-rmt:remote))

;; do we have a connection to apath dbname and
;; is it not expired? then return it
;;
(define (rmt:get-existing-live-conn remote apath dbname)
  (let* ((fullname (db:dbname->path apath dbname))
	 (conn     (hash-table-ref/default (rmt:remote-conns remote) fullname #f)))
    (if (and conn
	     (> (current-seconds) (rmt:conn-expires conn)))
	conn
	#f)))

;; looks for a connection to main
;; connections for other servers happens by requesting from main
;;
(define (rmt:open-main-connection remote apath)
  (let* ((pktsdir     (get-pkts-dir apath))
	 (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
	 (viable-srvs (get-viable-servers all-srvpkts apath))
	 (the-srv     (get-the-server viable-srvs apath))
	 (dbname      (db:run-id->dbname #f))
	 (start-main-srv (lambda ()
			   ;; srv not ready, delay a little and try again
			   (system (conc "nbfake megatest -server - -area "apath" -db "dbname))
			   (thread-sleep! 1.5)
			   (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries
			   )))
    (if the-srv ;; yes, we have a server, now try connecting to it
	(let* ((srv-addr (server-address the-srv))
	       (srvready (server-ready? srv-addr))
	       (fullpath (db:dbname->path apath dbname)))
	  (if srvready
	      (hash-table-set! (rmt:remote-conns remote)
			       fullpath
			       (make-rmt:conn
				apath:   apath
				dbname:  dbname
				fullname: fullpath
				hostport: srv-addr
				lastmsg: (current-seconds)
				expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping
				))
	      (start-main-srv)))
	(start-main-srv))))

(define (rmt:general-open-connection remote apath dbname)
  (let  ((mainconn (rmt:get-existing-live-conn remote apath (db:run-id->dbname #f))))
    (if (not mainconn)(rmt:open-main-connection remote apath))
    ;; TODO - call main for connection info
    ))
    
    
;;======================================================================

;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(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:send-receive-real conns apath dbname rid 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 rid params)
  ;; do we have a connection to the needed db?
  ;; has the connection expired?
  (let connloop ((conn (rmt:get-existing-live-conn remote apath dbname)))
    (if (not conn)
	(connloop (rmt:general-open-connection remote apath dbname))
	(begin
	  #t ;; here we do the actual connection work
	  ))))
    
  
;; ;; ;; start attemptnum at 1 so the modulo below works as expected
;; ;;   #;(common:telemetry-log (conc "rmt:"(->string cmd))
;; ;;                         payload: `((rid . ,rid)
;; ;;                                    (params . ,params)))
;; ;;                           
;; ;;   (if (> attemptnum 2)
;; ;;       (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
;; ;;     

(use typed-records srfi-1)

(declare (unit vg))
(use canvas-draw iup)
(import canvas-draw-iup)

(include "vg_records.scm")

;;======================================================================
;; IDEA
;;
;;      make it possible to instantiate a vg drawing inside a vg drawing
;;
;;======================================================================

;; ;; structs
;; ;;
;; (defstruct vg:lib     comps)
;; (defstruct vg:comp    objs name file)
;; ;; extents caches extents calculated on draw
;; ;; proc is called on draw and takes the obj itself as a parameter