Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -117,16 +117,29 @@ (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 run-id) - (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->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 @@ -141,16 +154,16 @@ ;; 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 run-id) +(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 run-id)) - (newdbdat (db:open-dbdat run-id db:initialize-db))) + (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 ;; @@ -157,19 +170,19 @@ (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 run-id) - (dbr:dbdat-db (db:get-dbdat dbstruct run-id))) +(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 run-id dbinit-proc) - (let* ((dbfile (db:run-id->path run-id)) +(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 @@ -216,11 +229,11 @@ ;; 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 run-id) + (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 @@ -228,12 +241,12 @@ ;; 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 run-id) - (let* ((dbh (db:get-ddb dbstruct run-id)) +(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))) Index: http-transportmod.scm ================================================================== --- http-transportmod.scm +++ http-transportmod.scm @@ -469,18 +469,20 @@ ;; ya, fake it for now ;; (define (register-server-in-db db-file) #t) -(define (get-pkts-dir) - (assert *toppath* "ERROR: get-pkts-dir called without *toppath* set. Exiting.") - (let* ((pdir (conc *toppath* "/.meta/srvpkts"))) - (if (file-exists? pdir) - pdir - (begin - (create-directory pdir #t) - pdir)))) +(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) @@ -574,11 +576,11 @@ (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 run-id)) + (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)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -2453,74 +2453,75 @@ (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) - #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)))) + (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 ;;====================================================================== Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -147,18 +147,101 @@ 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)) - ;; start attemptnum at 1 so the modulo below works as expected - #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) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -23,10 +23,17 @@ (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)