Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -136,10 +136,13 @@
PNGFILES = $(shell cd docs/manual;ls *png)
mtest: megatest.scm $(MOFILES) megatest-fossil-hash.scm
csc $(CSCOPTS) $(MOFILES) megatest.scm -o mtest
+
+mtserve: mtserve.scm $(MOFILES) megatest-fossil-hash.scm
+ csc $(CSCOPTS) $(MOFILES) mtserve.scm -o mtserve
# $(MOIMPFILES) removed
showmtesthash:
@echo $(MTESTHASH)
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -1942,18 +1942,17 @@
#t)))))
(define (db:get-status-from-final-status-file run-dir)
(let ((infile (conc run-dir "/.final-status")))
;; first verify we are able to write the output file
- (if (not (file-readable? infile))
+ (if (and (file-exists? infile)
+ (not (file-readable? infile)))
(begin
(debug:print 0 *default-log-port* "ERROR: cannot read " infile)
(debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
- #f
- )
- (with-input-from-file infile read-lines)
- )))
+ #f)
+ (with-input-from-file infile read-lines))))
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
ADDED mtserve.scm
Index: mtserve.scm
==================================================================
--- /dev/null
+++ mtserve.scm
@@ -0,0 +1,2685 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+
+;; (declare (uses dbi))
+(declare (uses pkts))
+;; (declare (uses stml2))
+;; (declare (uses cookie))
+;; (declare (uses csv-xml))
+;; (declare (uses hostinfo))
+
+(declare (uses adjutant))
+;; (declare (uses archivemod))
+(declare (uses apimod))
+;; (declare (uses autoload))
+;; (declare (uses bigmod))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dbmod))
+(declare (uses debugprint))
+;; (declare (uses ducttape-lib))
+;; (declare (uses ezstepsmod))
+(declare (uses launchmod))
+(declare (uses mtargs))
+(declare (uses mtver))
+;; (declare (uses mutils))
+(declare (uses processmod))
+(declare (uses rmtmod))
+;; (declare (uses runsmod))
+;; (declare (uses servermod))
+;; (declare (uses testsmod))
+(declare (uses dbmgrmod))
+
+;; needed for configf scripts, scheme etc.
+;; (declare (uses apimod.import))
+;; (declare (uses debugprint.import))
+;; (declare (uses mtargs.import))
+;; (declare (uses commonmod.import))
+;; (declare (uses configfmod.import))
+;; (declare (uses bigmod.import))
+;; (declare (uses dbmod.import))
+;; (declare (uses rmtmod.import))
+;; (declare (uses servermod.import))
+;; (declare (uses launchmod.import))
+
+;; (include "call-with-environment-variables/call-with-environment-variables.scm")
+
+(module mtserve
+ *
+
+ (import scheme
+
+;; chicken.base
+;; chicken.bitwise
+;; chicken.condition
+;; ;; chicken.csi
+;; chicken.eval
+;; chicken.file
+;; chicken.file.posix
+;; chicken.format
+;; chicken.io
+;; chicken.irregex
+;; chicken.pathname
+;; chicken.port
+;; chicken.pretty-print
+;; chicken.process
+;; chicken.process-context
+;; chicken.process-context.posix
+;; chicken.process.signal
+;; chicken.random
+;; chicken.repl
+;; chicken.sort
+;; chicken.string
+;; chicken.tcp
+;; chicken.time
+;; chicken.time.posix
+;;
+;; (prefix base64 base64:)
+;; (prefix sqlite3 sqlite3:)
+;; (prefix sxml-modifications sxml-)
+;; address-info
+;; csv-abnf
+;; directory-utils
+;; fmt
+;; format
+;; http-client
+;; intarweb
+;; json
+;; linenoise
+;; matchable
+;; md5
+;; message-digest
+;; queues
+;; regex
+;; regex-case
+;; s11n
+;; sparse-vectors
+;; spiffy
+;; spiffy-directory-listing
+;; spiffy-request-vars
+;; sql-de-lite
+;; stack
+;; sxml-modifications
+;; sxml-serializer
+;; sxml-transforms
+;; system-information
+;; typed-records
+;; uri-common
+;; z3
+;;
+;; srfi-1
+;; srfi-4
+;; srfi-18
+;; srfi-13
+;; srfi-98
+;; srfi-69
+;;
+;; ;; local modules
+;; autoload
+;; adjutant
+;; csv-xml
+;; ;; hostinfo
+;; mtver
+;; mutils
+;; cookie
+;; csv-xml
+;; ducttape-lib
+;; (prefix mtargs args:)
+;; pkts
+;; stml2
+;; (prefix dbi dbi:)
+;;
+;; apimod
+;; archivemod
+;; bigmod
+;; commonmod
+;; configfmod
+;; dbmod
+;; debugprint
+;; ezstepsmod
+;; launchmod
+;; processmod
+;; rmtmod
+;; runsmod
+;; servermod
+;; tasksmod
+;; testsmod
+;; dbmgrmod
+;;
+;; ulex
+ )
+
+;; ;; ulex parameters
+;; (work-method 'direct)
+;; (return-method 'direct)
+
+ ;; ulex parameters
+ ;; (work-method 'mailbox)
+ ;; (return-method 'mailbox)
+
+;; (my-with-lock common:with-simple-file-lock)
+;;
+;; ;; fake out readline usage of toplevel-command
+;; (define (toplevel-command . a) #f)
+;; (define *didsomething* #f)
+;; (define *db* #f) ;; this is only for the repl, do not use in general!!!!
+;;
+;; ;; (include "common_records.scm")
+;; ;; (include "key_records.scm")
+;; ;; (include "db_records.scm")
+;; (include "run_records.scm")
+;; ;; (include "test_records.scm")
+;;
+;; ;; (include "common.scm")
+;; (include "db.scm")
+;; ;; (include "server.scm")
+;; (include "tests.scm")
+;; (include "genexample.scm")
+;; (include "tdb.scm")
+;; (include "env.scm")
+;; (include "diff-report.scm")
+;; (include "ods.scm")
+;;
+
+ (define (main)
+ (let ((tl (launch:setup))
+ (dbname (args:get-arg "-db")))
+ (rmt:server-launch dbname)
+ #;(set! *didsomething* #t)))
+
+
+(thread-join!
+ (thread-start!
+ (make-thread main)))
+
+)
+
+;; (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
+;; (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
+;;
+;; ;;======================================================================
+;; ;; Test commands (i.e. for use inside tests)
+;; ;;======================================================================
+;;
+;; (define (megatest:step step state status logfile msg)
+;; (if (not (get-environment-variable "MT_CMDINFO"))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
+;; (exit 5))
+;; (let* ((cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
+;; (transport (assoc/default 'transport cmdinfo))
+;; (testpath (assoc/default 'testpath cmdinfo))
+;; (test-name (assoc/default 'test-name cmdinfo))
+;; (runscript (assoc/default 'runscript cmdinfo))
+;; (db-host (assoc/default 'db-host cmdinfo))
+;; (run-id (assoc/default 'run-id cmdinfo))
+;; (test-id (assoc/default 'test-id cmdinfo))
+;; (itemdat (assoc/default 'itemdat cmdinfo))
+;; (work-area (assoc/default 'work-area cmdinfo))
+;; (db #f))
+;; (change-directory testpath)
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; (if (and state status)
+;; (let ((comment (launch:load-logpro-dat run-id test-id step)))
+;; ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
+;; (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
+;; (exit 6))))))
+;;
+;; ;;======================================================================
+;; ;; full run
+;; ;;======================================================================
+;;
+;; (define (handle-run-requests target runname keys keyvals need-clean)
+;; (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
+;; ;; For rerun-clean do we or do we not support the testpatt?
+;; (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
+;; "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
+;; (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
+;; "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
+;; (hash-table-set! args:arg-hash "-preclean" #t)
+;; (runs:operate-on 'set-state-status
+;; target
+;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+;; ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+;; state: states
+;; ;; status: statuses
+;; new-state-status: "NOT_STARTED,n/a")
+;; (runs:clean-cache target runname *toppath*)
+;; (runs:operate-on 'set-state-status
+;; target
+;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+;; ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+;; ;; state: states
+;; status: statuses
+;; new-state-status: "NOT_STARTED,n/a")))
+;; ;; RERUN ALL
+;; (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
+;; (let* ((rconfig (full-runconfigs-read)))
+;; (hash-table-set! args:arg-hash "-preclean" #t)
+;; (runs:operate-on 'set-state-status
+;; target
+;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+;; (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
+;; state: #f
+;; ;; status: statuses
+;; new-state-status: "NOT_STARTED,n/a")
+;; (runs:clean-cache target runname *toppath*)
+;; (runs:operate-on 'set-state-status
+;; target
+;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+;; (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
+;; ;; state: states
+;; status: #f
+;; new-state-status: "NOT_STARTED,n/a")))
+;; (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
+;; (if x (string->number x) #f)))
+;; (rerun-cnt (if config-reruns
+;; config-reruns
+;; 1)))
+;;
+;; (runs:run-tests target
+;; runname
+;; #f ;; (common:args-get-testpatt #f)
+;; ;; (or (args:get-arg "-testpatt")
+;; ;; "%")
+;; (bdat-user *bdat*)
+;; args:arg-hash
+;; run-count: rerun-cnt)))
+;;
+;; ;; csv processing record
+;; (define (make-refdb:csv)
+;; (vector
+;; (make-sparse-array)
+;; (make-hash-table)
+;; (make-hash-table)
+;; 0
+;; 0))
+;; (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
+;; (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
+;; (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
+;; (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
+;; (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
+;; (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
+;; (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
+;; (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
+;; (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
+;; (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
+;;
+;; (define (get-dat results sheetname)
+;; (or (hash-table-ref/default results sheetname #f)
+;; (let ((tmp-vec (make-refdb:csv)))
+;; (hash-table-set! results sheetname tmp-vec)
+;; tmp-vec)))
+;;
+;; ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
+;; (define (open-logfile logpath-in)
+;; (condition-case
+;; (let* ((log-dir (or (pathname-directory logpath-in) "."))
+;; (fname (pathname-strip-directory logpath-in))
+;; (logpath (if (> (string-length fname) 250)
+;; (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
+;; (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
+;; newlogf)
+;; logpath-in)))
+;; (if (not (directory-exists? log-dir))
+;; (system (conc "mkdir -p " log-dir)))
+;; (open-output-file logpath))
+;; (exn ()
+;; (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
+;; (set! *didsomething* #t)
+;; (exit 1))))
+;;
+;; ;; Disabled help items
+;; ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
+;; ;; from prior runs with same keys
+;; ;; -daemonize : fork into background and disconnect from stdin/out
+;;
+;; (define help (conc "
+;; Megatest, documentation at http://www.kiatoa.com/fossils/megatest
+;; version " megatest-version "
+;; license GPL, Copyright Matt Welland 2006-2017
+;;
+;; Usage: megatest [options]
+;; -h : this help
+;; -manual : show the Megatest user manual
+;; -version : print megatest version (currently " megatest-version ")
+;;
+;; Launching and managing runs
+;; -run : run all tests or as specified by -testpatt
+;; -remove-runs : remove the data for a run, requires -runname and -testpatt
+;; Optionally use :state and :status, use -keep-records to remove only
+;; the run data. Use -kill-wait to override the 10 second
+;; per test wait after kill delay (e.g. -kill-wait 0).
+;; -kill-runs : kill existing run(s) (all incomplete tests killed)
+;; -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun)
+;; -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs
+;; -rerun FAIL,WARN... : force re-run for tests with specificed status(s)
+;; -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
+;; and then run the specified testpatt with -preclean
+;; -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean
+;; -lock : lock run specified by target and runname
+;; -unlock : unlock run specified by target and runname
+;; -set-run-status status : sets status for run to status, requires -target and -runname
+;; -get-run-status : gets status for run specified by target and runname
+;; -run-wait : wait on run specified by target and runname
+;; -preclean : remove the existing test directory before running the test
+;; -clean-cache : remove the cached megatest.config and runconfigs.config files
+;; -no-cache : do not use the cached config files.
+;; -one-pass : launch as many tests as you can but do not wait for more to be ready
+;; -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd'
+;; -age : 120d,3h,20m to apply only to runs older than the
+;; specified age. NB// M=month, m=minute
+;; -actions [,...] : actions to take; print,remove-runs,archive,kill-runs
+;; -precmd : insert a wrapper command in front of the commands run
+;;
+;; Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
+;; -target key1/key2/... : run for key1, key2, etc.
+;; -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs
+;; -testpatt patt1/patt2,patt3/... : % is wildcard
+;; -runname : required, name for this particular test run
+;; -state : Applies to runs, tests or steps depending on context
+;; -status : Applies to runs, tests or steps depending on context
+;; -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
+;; -tagexpr tag1,tag2%,.. : select tests with tags matching expression
+;;
+;;
+;; Test helpers (for use inside tests)
+;; -step stepname
+;; -test-status : set the state and status of a test (use :state and :status)
+;; -setlog logfname : set the path/filename to the final log relative to the test
+;; directory. may be used with -test-status
+;; -set-toplog logfname : set the overall log for a suite of sub-tests
+;; -summarize-items : for an itemized test create a summary html
+;; -m comment : insert a comment for this test
+;;
+;; Test data capture
+;; -set-values : update or set values in the testdata table
+;; :category : set the category field (optional)
+;; :variable : set the variable name (optional)
+;; :value : value measured (required)
+;; :expected : value expected (required)
+;; :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number)
+;; :units : name of the units for value, expected_value etc. (optional)
+;; -load-test-data : read test specific data for storage in the test_data table
+;; from standard in. Each line is comma delimited with four
+;; fields category,variable,value,comment
+;;
+;; Queries
+;; -list-runs patt : list runs matching pattern \"patt\", % is the wildcard
+;; -show-keys : show the keys used in this megatest setup
+;; -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
+;; returns list sorted by age ascending, see examples below
+;; -test-paths : get the test paths matching target, runname, item and test
+;; patterns.
+;; -list-disks : list the disks available for storing runs
+;; -list-targets : list the targets in runconfigs.config
+;; -list-db-targets : list the target combinations used in the db
+;; -show-config : dump the internal representation of the megatest.config file
+;; -show-runconfig : dump the internal representation of the runconfigs.config file
+;; -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
+;; -show-cmdinfo : dump the command info for a test (run in test environment)
+;; -section sectionName
+;; -var varName : for config and runconfig lookup value for sectionName varName
+;; -since N : get list of runs changed since time N (Unix seconds)
+;; -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
+;; -sort fieldname : in -list-runs sort tests by this field
+;; -testdata-csv [categorypatt/]varpatt : dump testdata for given category
+;;
+;; Misc
+;; -start-dir path : switch to this directory before running megatest
+;; -contour cname : add a level of hierarcy to the linktree and run paths
+;; -area-tag tagname : add a tag to an area while syncing to pgdb
+;; -run-tag tagname : add a tag to a run while syncing to pgdb
+;; -rebuild-db : bring the database schema up to date
+;; -cleanup-db : remove any orphan records, vacuum the db
+;; -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER
+;; -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db
+;; -sync-to dest : sync to new postgresql central style database
+;; -update-meta : update the tests metadata for all tests
+;; -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
+;; overwritten by values set in config files.
+;; -server -|hostname : start the server (reduces contention on megatest.db), use
+;; - to automatically figure out hostname
+;; -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig),
+;; use 0,0 to auto use full machine
+;; -transport http|rpc : use http or rpc for transport (default is http)
+;; -log logfile : send stdout and stderr to logfile
+;; -autolog logfilebase : appends pid and host to logfilebase for logfile
+;; -list-servers : list the servers
+;; -kill-servers : kill all servers
+;; -repl : start a repl (useful for extending megatest)
+;; -load file.scm : load and run file.scm
+;; -mark-incompletes : find and mark incomplete tests
+;; -ping run-id|host:port : ping server, exit with 0 if found
+;; -debug N|N,M,O... : enable debug 0-N or N and M and O ...
+;; -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
+;; -config fname : override the megatest.config file with fname
+;; -append-config fname : append fname to the megatest.config file
+;;
+;; Utilities
+;; -env2file fname : write the environment to fname.csh and fname.sh
+;; -envcap a : save current variables labeled as context 'a' in file envdat.db
+;; -envdelta a-b : output enviroment delta from context a to context b to -o fname
+;; set the output mode with -dumpmode csh, bash or ini
+;; note: ini format will use calls to use curr and minimize path
+;; -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode
+;; formats: perl, ruby, sqlite3, csv (for csv the -o param
+;; will substitute %s for the sheet name in generating
+;; multiple sheets)
+;; -o : output file for refdb2dat (defaults to stdout)
+;; -archive cmd : archive runs specified by selectors to one of disks specified
+;; in the [archive-disks] section.
+;; cmd: keep-html, restore, save, save-remove, get, replicate-db (use
+;; -dest to set destination), -include path1,path2... to get or save specific files
+;; -generate-html : create a simple html dashboard for browsing your runs
+;; -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
+;; -list-run-time : list time requered to complete runs. It supports following switches
+;; -run-patt -target-patt -dumpmode
+;; -list-test-time : list time requered to complete each test in a run. It following following arguments
+;; -runname -target -dumpmode
+;; -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and
+;; is $DISPLAY valid
+;; -list-waivers : dump waivers for specified target, runname, testpatt to stdout
+;;
+;; Diff report
+;; -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
+;; and either -diff-email or -diff-html)
+;; -src-target
+;; -src-runname
+;; -diff-email : comma separated list of email addresses to send diff report
+;; -diff-html : path to html file to generate
+;;
+;; Spreadsheet generation
+;; -extract-ods fname.ods : extract an open document spreadsheet from the database
+;; -pathmod path : insert path, i.e. path/runame/itempath/logfile.html
+;; will clear the field if no rundir/testname/itempath/logfile
+;; if it contains forward slashes the path will be converted
+;; to windows style
+;; Getting started
+;; -create-megatest-area : create a skeleton megatest area. You will be prompted for paths
+;; -create-test testname : create a skeleton megatest test. You will be prompted for info
+;;
+;; Examples
+;;
+;; # Get test path, use '.' to get a single path or a specific path/file pattern
+;; megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
+;;
+;; Called as " (string-intersperse (argv) " ") "
+;; Version " megatest-version ", built from " megatest-fossil-hash ))
+;;
+;; (define (main)
+;; (make-and-init-bigdata)
+;;
+;; ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
+;; ;;
+;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
+;; (if (common:file-exists? debugcontrolf)
+;; (load debugcontrolf)))
+;;
+;; ;; usage logging, careful with this, it is not designed to deal with all real world challenges!
+;; ;;
+;; (if (and *usage-log-file*
+;; (file-writable? *usage-log-file*))
+;; (with-output-to-file
+;; *usage-log-file*
+;; (lambda ()
+;; (print
+;; (if *usage-use-seconds*
+;; (current-seconds)
+;; (time->string
+;; (seconds->local-time (current-seconds))
+;; "%Yww%V.%w %H:%M:%S"))
+;; " "
+;; (current-user-name) " "
+;; (current-directory) " "
+;; "\"" (string-intersperse (argv) " ") "\""))
+;; #:append))
+;;
+;; ;; -gui : start a gui interface
+;; ;; -config fname : override the runconfigs file with fname
+;;
+;; ;; process args
+;; (define remargs (args:get-args
+;; (argv)
+;; (list "-runtests" ;; run a specific test
+;; "-config" ;; override the config file name
+;; "-append-config"
+;; "-execute" ;; run the command encoded in the base64 parameter
+;; "-step"
+;; "-target"
+;; "-reqtarg"
+;; ":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"
+;; "-db" ;; file name for setting up a 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"
+;; "-include"
+;; "-exclude-rx"
+;; "-exclude-rx-from"
+;;
+;; "-debug" ;; for *verbosity* > 2
+;; "-debug-noprop"
+;; "-create-test"
+;; "-override-timeout"
+;; "-test-files" ;; -test-paths is for listing all
+;; "-load" ;; load and exectute a scheme file
+;; "-section"
+;; "-var"
+;; "-dumpmode"
+;; "-run-id"
+;; "-ping"
+;; "-refdb2dat"
+;; "-o"
+;; "-log"
+;; "-autolog"
+;; "-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"
+;; "-force"
+;; "-xterm"
+;; "-showkeys"
+;; "-show-keys"
+;; "-test-status"
+;; "-set-values"
+;; "-load-test-data"
+;; "-summarize-items"
+;; "-gui"
+;; "-daemonize"
+;; "-preclean"
+;; "-rerun-clean"
+;; "-rerun-all"
+;; "-clean-cache"
+;; "-no-cache"
+;; "-cache-db"
+;; "-cp-eventtime-to-publishtime"
+;; "-use-db-cache"
+;; "-prepend-contour"
+;;
+;;
+;; ;; 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"
+;;
+;; ;; misc queries
+;; "-list-disks"
+;; "-list-targets"
+;; "-list-db-targets"
+;; "-show-runconfig"
+;; "-show-config"
+;; "-show-cmdinfo"
+;; "-get-run-status"
+;; "-list-waivers"
+;;
+;; ;; queries
+;; "-test-paths" ;; get path(s) to a test, ordered by youngest first
+;;
+;; "-runall" ;; run all tests, respects -testpatt, defaults to %
+;; "-run" ;; alias for -runall
+;; "-remove-runs"
+;; "-kill-runs"
+;; "-kill-rerun"
+;; "-keep-records" ;; use with -remove-runs to remove only the run data
+;; "-rebuild-db"
+;; "-cleanup-db"
+;; "-rollup"
+;; "-update-meta"
+;; "-create-megatest-area"
+;; "-mark-incompletes"
+;;
+;; "-convert-to-norm"
+;; "-convert-to-old"
+;; "-import-megatest.db"
+;; "-sync-to-megatest.db"
+;; "-sync-brute-force"
+;; "-logging"
+;; "-v" ;; verbose 2, more than normal (normal is 1)
+;; "-q" ;; quiet 0, errors/warnings only
+;;
+;; "-diff-rep"
+;;
+;; "-syscheck"
+;; "-obfuscate"
+;; ;; junk placeholder
+;; ;; "-:p"
+;;
+;; )
+;; args:arg-hash
+;; 0))
+;;
+;; ;; Add args that use remargs here
+;; ;;
+;; (if (and (not (null? remargs))
+;; (not (or
+;; (args:get-arg "-runstep")
+;; (args:get-arg "-envcap")
+;; (args:get-arg "-envdelta")
+;; )
+;; ))
+;; (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
+;;
+;; ;; before doing anything else change to the start-dir if provided
+;; ;;
+;; (if (args:get-arg "-start-dir")
+;; (if (common:file-exists? (args:get-arg "-start-dir"))
+;; (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
+;; (set-environment-variable! "PWD" fullpath)
+;; (change-directory fullpath))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
+;; (exit 1))))
+;;
+;; ;; immediately set MT_TARGET if -reqtarg or -target are available
+;; ;;
+;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
+;; (if targ (set-environment-variable! "MT_TARGET" targ)))
+;;
+;; ;; The watchdog is to keep an eye on things like db sync etc.
+;; ;;
+;; ;; (init-watchdog)
+;;
+;; ;; (define (debug:debug-mode n)
+;; ;; (cond
+;; ;; ((and (number? *verbosity*) ;; number number
+;; ;; (number? n))
+;; ;; (<= n *verbosity*))
+;; ;; ((and (list? *verbosity*) ;; list number
+;; ;; (number? n))
+;; ;; (member n *verbosity*))
+;; ;; ((and (list? *verbosity*) ;; list list
+;; ;; (list? n))
+;; ;; (not (null? (lset-intersection! eq? *verbosity* n))))
+;; ;; ((and (number? *verbosity*)
+;; ;; (list? n))
+;; ;; (member *verbosity* n))))
+;;
+;; ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
+;; ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
+;; ;; where (launch:setup) returns #f?
+;; ;;
+;; (if (or (args:get-arg "-log") ;;(args:get-arg "-server") ;; redirect the log always when a server
+;; (args:get-arg "-autolog"))
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+;; )
+;; (let* ((tl (or (args:get-arg "-log")
+;; (args:get-arg "-autolog") ;; autolog provides the basename .../logs/something- for the logfile
+;; (launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
+;; (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
+;; (conc tl (current-process-id)"-"(get-host-name)".log")
+;; (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
+;; (oup (open-logfile logf)))
+;; (if (not (args:get-arg "-log"))
+;; (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
+;; (debug:print-info 0 *default-log-port* "Sending log output to " logf)
+;; (set! *default-log-port* oup))))
+;;
+;; (if (or (args:get-arg "-h")
+;; (args:get-arg "-help")
+;; (args:get-arg "--help"))
+;; (begin
+;; (print help)
+;; (exit)))
+;;
+;; (if (args:get-arg "-manual")
+;; (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
+;; (common:which '("firefox" "arora"))))
+;; (install-home (common:get-install-area))
+;; (manual-html (conc install-home "/share/docs/megatest_manual.html")))
+;; (if (and install-home
+;; (common:file-exists? manual-html))
+;; (system (conc "(" htmlviewercmd " " manual-html " ) &"))
+;; (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
+;; (exit)))
+;;
+;; (if (args:get-arg "-version")
+;; (begin
+;; (print (common:version-signature)) ;; (print megatest-version)
+;; (exit)))
+;;
+;; ;; Overall exit handling setup immediately
+;; ;;
+;; (if (or (args:get-arg "-process-reap"))
+;; ;; (args:get-arg "-runtests")
+;; ;; (args:get-arg "-execute")
+;; ;; (args:get-arg "-remove-runs")
+;; ;; (args:get-arg "-runstep"))
+;; (let ((original-exit (exit-handler)))
+;; (exit-handler (lambda (#!optional (exit-code 0))
+;; (printf "Preparing to exit with exit code ~A ...\n" exit-code)
+;; (for-each
+;;
+;; (lambda (pid)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (printf "process reap failed. exn=~A\n" exn)
+;; #t)
+;; (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
+;; (if (or (eq? pid-val pid)
+;; (eq? pid-val 0))
+;; (begin
+;; (printf "Sending signal/term to ~A\n" pid)
+;; (process-signal pid signal/term))))))
+;; (process:children #f))
+;; (original-exit exit-code)))))
+;;
+;; ;; for some switches always print the command to stderr
+;; ;;
+;; (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
+;; (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
+;;
+;; ;; some switches imply homehost. Exit here if not on homehost
+;; ;;
+;; #;(let ((homehost-required (list "-cleanup-db" "-server")))
+;; (if (apply args:any-defined? homehost-required)
+;; (if (not (common:on-homehost?))
+;; (for-each
+;; (lambda (switch)
+;; (if (args:get-arg switch)
+;; (begin
+;; (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
+;; ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
+;; (exit 1))))
+;; homehost-required))))
+;;
+;; ;;======================================================================
+;; ;; Misc setup stuff
+;; ;;======================================================================
+;;
+;; (debug:setup)
+;;
+;; (if (args:get-arg "-logging")(set! *logging* #t))
+;;
+;; ;;(if (debug:debug-mode 3) ;; we are obviously debugging
+;; ;; (set! open-run-close open-run-close-no-exception-handling))
+;;
+;; (if (args:get-arg "-itempatt")
+;; (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
+;; (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
+;; (hash-table-set! args:arg-hash "-testpatt" newval)
+;; (hash-table-delete! args:arg-hash "-itempatt")))
+;;
+;; (if (args:get-arg "-runtests")
+;; (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
+;;
+;; ;; (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
+;; (on-exit std-exit-procedure)
+;;
+;; ;;======================================================================
+;; ;; Misc general calls
+;; ;;======================================================================
+;;
+;; ;; TODO: Restore this functionality
+;;
+;; #; (if (and (args:get-arg "-cache-db")
+;; (args:get-arg "-source-db"))
+;; (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
+;; (target-db (conc temp-dir "/cached.db"))
+;; (source-db (args:get-arg "-source-db")))
+;; (db:cache-for-read-only source-db target-db)
+;; (set! *didsomething* #t)))
+;;
+;; ;; handle a clean-cache request as early as possible
+;; ;;
+;; (if (args:get-arg "-clean-cache")
+;; (let ((toppath (launch:setup)))
+;; (set! *didsomething* #t) ;; suppress the help output.
+;; (runs:clean-cache (common:args-get-target)
+;; (args:get-arg "-runname")
+;; toppath)))
+;;
+;; (if (args:get-arg "-env2file")
+;; (begin
+;; (save-environment-as-files (args:get-arg "-env2file"))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-list-disks")
+;; (let ((toppath (launch:setup)))
+;; (print
+;; (string-intersperse
+;; (map (lambda (x)
+;; (string-intersperse
+;; x
+;; " => "))
+;; (common:get-disks *configdat*))
+;; "\n"))
+;; (set! *didsomething* #t)))
+;;
+;;
+;; (if (args:get-arg "-refdb2dat")
+;; (let* ((input-db (args:get-arg "-refdb2dat"))
+;; (out-file (args:get-arg "-o"))
+;; (out-fmt (or (args:get-arg "-dumpmode") "scheme"))
+;; (out-port (if (and out-file
+;; (not (member out-fmt '("sqlite3" "csv"))))
+;; (open-output-file out-file)
+;; (current-output-port)))
+;; (res-data (configf:read-refdb input-db))
+;; (data (car res-data))
+;; (msg (cadr res-data)))
+;; (if (not data)
+;; (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
+;; (with-output-to-port out-port
+;; (lambda ()
+;; (case (string->symbol out-fmt)
+;; ((scheme)(pp data))
+;; ((perl)
+;; ;; (print "%hash = (")
+;; ;; key1 => 'value1',
+;; ;; key2 => 'value2',
+;; ;; key3 => 'value3',
+;; ;; );
+;; (configf:map-all-hier-alist
+;; data
+;; (lambda (sheetname sectionname varname val)
+;; (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
+;; ((python ruby)
+;; (print "data={}")
+;; (configf:map-all-hier-alist
+;; data
+;; (lambda (sheetname sectionname varname val)
+;; (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
+;; initproc1:
+;; (lambda (sheetname)
+;; (print "data[\"" sheetname "\"] = {}"))
+;; initproc2:
+;; (lambda (sheetname sectionname)
+;; (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
+;; ((csv)
+;; (let* ((results (make-hash-table)) ;; (make-sparse-array)))
+;; (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num
+;; ;; (print "data=")
+;; ;; (pp data)
+;; (configf:map-all-hier-alist
+;; data
+;; (lambda (sheetname sectionname varname val)
+;; ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
+;; (let* ((dat (get-dat results sheetname))
+;; (vec (refdb:csv-get-svec dat))
+;; (rownames (refdb:csv-get-rows dat))
+;; (colnames (refdb:csv-get-cols dat))
+;; (currrown (hash-table-ref/default rownames varname #f))
+;; (currcoln (hash-table-ref/default colnames sectionname #f))
+;; (rown (or currrown
+;; (let* ((lastn (refdb:csv-get-maxrow dat))
+;; (newrown (+ lastn 1)))
+;; (refdb:csv-set-maxrow! dat newrown)
+;; newrown)))
+;; (coln (or currcoln
+;; (let* ((lastn (refdb:csv-get-maxcol dat))
+;; (newcoln (+ lastn 1)))
+;; (refdb:csv-set-maxcol! dat newcoln)
+;; newcoln))))
+;; (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
+;; (begin
+;; (sparse-array-set! vec 0 coln sectionname)
+;; ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
+;; ))
+;; (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
+;; (begin
+;; (sparse-array-set! vec rown 0 varname)
+;; ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
+;; ))
+;; (if (not currrown)(hash-table-set! rownames varname rown))
+;; (if (not currcoln)(hash-table-set! colnames sectionname coln))
+;; ;; (print "dat=" dat ", rown=" rown ", coln=" coln)
+;; (sparse-array-set! vec rown coln val)
+;; ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
+;; )))
+;; (for-each
+;; (lambda (sheetname)
+;; (let* ((sheetdat (get-dat results sheetname))
+;; (svec (refdb:csv-get-svec sheetdat))
+;; (maxrow (refdb:csv-get-maxrow sheetdat))
+;; (maxcol (refdb:csv-get-maxcol sheetdat))
+;; (fname (if out-file
+;; (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
+;; (conc sheetname ".csv"))))
+;; (with-output-to-file fname
+;; (lambda ()
+;; ;; (print "Sheetname: " sheetname)
+;; (let loop ((row 0)
+;; (col 0)
+;; (curr-row '())
+;; (result '()))
+;; (let* ((val (sparse-array-ref svec row col))
+;; (disp-val (if val
+;; (conc "\"" val "\"")
+;; "")))
+;; (if (> col 0)(display ","))
+;; (display disp-val)
+;; (cond
+;; ((> row maxrow)(display "\n") result)
+;; ((>= col maxcol)
+;; (display "\n")
+;; (loop (+ row 1) 0 '() (append result (list curr-row))))
+;; (else
+;; (loop row (+ col 1) (append curr-row (list val)) result)))))))))
+;; (hash-table-keys results))))
+;; ((sqlite3)
+;; (let* ((db-file (or out-file (pathname-file input-db)))
+;; (db-exists (common:file-exists? db-file))
+;; (db (sqlite3:open-database db-file)))
+;; (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
+;; (configf:map-all-hier-alist
+;; data
+;; (lambda (sheetname sectionname varname val)
+;; (sqlite3:execute db
+;; "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
+;; sheetname sectionname varname val)))
+;; (sqlite3:finalize! db)))
+;; (else
+;; (pp data))))))
+;; (if out-file (close-output-port out-port))
+;; (exit) ;; yes, bending the rules here - need to exit since this is a utility
+;; ))
+;;
+;; ;; disabled for now
+;;
+;; #;(if (args:get-arg "-ping")
+;; (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
+;; (host:port (args:get-arg "-ping")))
+;; (server-ready? (or server-id host:port) #f do-exit: #t)))
+;;
+;; ;;======================================================================
+;; ;; Capture, save and manipulate environments
+;; ;;======================================================================
+;;
+;; ;; NOTE: Keep these above the section where the server or client code is setup
+;;
+;; (let ((envcap (args:get-arg "-envcap")))
+;; (if envcap
+;; (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
+;; (env:save-env-vars db envcap)
+;; (env:close-database db)
+;; (set! *didsomething* #t))))
+;;
+;; ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b
+;; ;;
+;; (let ((envdelta (args:get-arg "-envdelta")))
+;; (if envdelta
+;; (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
+;; (if (not (null? match))
+;; (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
+;; ;; (resctx (cadr match))
+;; ;; (equn (caddr match))
+;; (parts match) ;; (string-split equn "-"))
+;; (minuend (car parts))
+;; (subtraend (cadr parts))
+;; (added (env:get-added db minuend subtraend))
+;; (removed (env:get-removed db minuend subtraend))
+;; (changed (env:get-changed db minuend subtraend)))
+;; ;; (pp (hash-table->alist added))
+;; ;; (pp (hash-table->alist removed))
+;; ;; (pp (hash-table->alist changed))
+;; (if (args:get-arg "-o")
+;; (with-output-to-file
+;; (args:get-arg "-o")
+;; (lambda ()
+;; (env:print added removed changed)))
+;; (env:print added removed changed))
+;; (env:close-database db)
+;; (set! *didsomething* #t))
+;; (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end")))))
+;;
+;; ;;======================================================================
+;; ;; 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")
+;; (if (not (args:get-arg "-db"))
+;; (debug:print 0 *default-log-port* "ERROR: -db required to start server")
+;; (let ((tl (launch:setup))
+;; (dbname (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
+;; (rmt:server-launch dbname)
+;; (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)))
+;;
+;; (if (or (args:get-arg "-list-servers")
+;; (args:get-arg "-kill-servers"))
+;; (let ((tl (launch:setup)))
+;; (if tl ;; all roads from here exit
+;; (let* ((servers (rmt:get-servers-info *toppath*))
+;; (fmtstr "~8a~22a~20a~20a~8a\n"))
+;; ;; id INTEGER PRIMARY KEY,
+;; ;; host TEXT,
+;; ;; port INTEGER,
+;; ;; servkey TEXT,
+;; ;; pid TEXT,
+;; ;; ipaddr TEXT,
+;; ;; apath TEXT,
+;; ;; dbname TEXT,
+;; ;; event_time
+;; (format #t fmtstr "pid" "Interface:port" "State" "dbname" "apath")
+;; (format #t fmtstr "===" "==============" "=====" "======" "=====")
+;; (for-each ;; ( mod-time host port start-time pid )
+;; (lambda (server)
+;; (match-let
+;; (((id host port servkey pid ipaddr apath dbname event_time) server))
+;; (format #t
+;; fmtstr
+;; pid
+;; (conc host":"port)
+;; (if (server-ready? host port servkey) "Running" "Dead")
+;; dbname ;; (seconds->hr-min-sec mod)
+;; apath
+;; )
+;; (if (args:get-arg "-kill-servers")
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid " !!needs completion!!")
+;; #;(server:kill server)))))
+;; servers)
+;; ;; (debug:print-info 1 *default-log-port* "Done with listservers")
+;; (set! *didsomething* #t)
+;; (exit))
+;; (exit))))
+;; ;; must do, would have to add checks to many/all calls below
+;;
+;; ;;======================================================================
+;; ;; Weird special calls that need to run *after* the server has started?
+;; ;;======================================================================
+;;
+;; (if (args:get-arg "-list-targets")
+;; (if (launch:setup)
+;; (let* ((rconfdat (configf:read-config (conc *toppath* "/runconfigs.config") #f #f))
+;; (targets (common:get-runconfig-targets rconfdat)))
+;; ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
+;; (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
+;; ((alist)
+;; (for-each (lambda (x)
+;; ;; (print "[" x "]"))
+;; (print x))
+;; targets))
+;; ((json)
+;; (json-write targets))
+;; (else
+;; (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
+;; (set! *didsomething* #t))))
+;;
+;;
+;; (if (args:get-arg "-show-runconfig")
+;; (let ((tl (launch:setup)))
+;; (push-directory *toppath*)
+;; (let ((data (full-runconfigs-read)))
+;; ;; keep this one local
+;; (cond
+;; ((and (args:get-arg "-section")
+;; (args:get-arg "-var"))
+;; (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
+;; (configf:lookup data "default" (args:get-arg "-var")))))
+;; (if val (print val))))
+;; ((or (not (args:get-arg "-dumpmode"))
+;; (string=? (args:get-arg "-dumpmode") "ini"))
+;; (configf:config->ini data))
+;; ((string=? (args:get-arg "-dumpmode") "sexp")
+;; (pp (hash-table->alist data)))
+;; ((string=? (args:get-arg "-dumpmode") "json")
+;; (json-write data))
+;; (else
+;; (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
+;; (set! *didsomething* #t))
+;; (pop-directory)))
+;;
+;; (if (args:get-arg "-show-config")
+;; (let ((tl (launch:setup))
+;; (data *configdat*)) ;; (configf:read-config "megatest.config" #f #t)))
+;; (push-directory *toppath*)
+;; ;; keep this one local
+;; (cond
+;; ((and (args:get-arg "-section")
+;; (args:get-arg "-var"))
+;; (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
+;; (if val (print val))))
+;;
+;; ;; print just a section if only -section
+;;
+;; ((equal? (args:get-arg "-dumpmode") "sexp")
+;; (pp (hash-table->alist data)))
+;; ((equal? (args:get-arg "-dumpmode") "json")
+;; (json-write data))
+;; ((or (not (args:get-arg "-dumpmode"))
+;; (string=? (args:get-arg "-dumpmode") "ini"))
+;; (configf:config->ini data))
+;; (else
+;; (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
+;; (set! *didsomething* #t)
+;; (pop-directory)
+;; (bdat-time-to-exit-set! *bdat* #t)))
+;;
+;; (if (args:get-arg "-show-cmdinfo")
+;; (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
+;; (let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
+;; (if (equal? (args:get-arg "-dumpmode") "json")
+;; (json-write data)
+;; (pp data))
+;; (set! *didsomething* #t))
+;; (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
+;;
+;; ;;======================================================================
+;; ;; Remove old run(s)
+;; ;;======================================================================
+;;
+;; ;; since several actions can be specified on the command line the removal
+;; ;; is done first
+;; (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
+;; (let* ((runrec (runs:runrec-make-record))
+;; (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
+;; (runname (or runname-in
+;; (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
+;; (testpatt (or (args:get-arg "-testpatt")
+;; (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
+;; (common:get-full-test-name))
+;; (and (eq? action 'kill-runs)
+;; "%/%") ;; I'm just guessing that this is correct :(
+;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
+;; ))) ;;
+;; (cond
+;; ((not target)
+;; (debug:print-error 0 *default-log-port* "Missing required parameter for "
+;; action ", you must specify -target or -reqtarg")
+;; (exit 1))
+;; ((not runname)
+;; (debug:print-error 0 *default-log-port* "Missing required parameter for "
+;; action ", you must specify the run name pattern with -runname patt")
+;; (exit 2))
+;; ((not testpatt)
+;; (debug:print-error 0 *default-log-port* "Missing required parameter for "
+;; action ", you must specify the test pattern with -testpatt")
+;; (exit 3))
+;; (else
+;; (if (not (car *configinfo*))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
+;; (exit 1))
+;; ;; put test parameters into convenient variables
+;; (begin
+;; ;; check for correct version, exit with message if not correct
+;;
+;; ;; TODO: restore this functionality
+;;
+;; ;; (common:exit-on-version-changed)
+;;
+;; (runs:operate-on action
+;; target
+;; runname
+;; testpatt
+;; state: (common:args-get-state)
+;; status: (common:args-get-status)
+;; new-state-status: (args:get-arg "-set-state-status")
+;; mode: mode)))
+;; (set! *didsomething* #t)))))
+;;
+;; (if (args:get-arg "-kill-runs")
+;; (general-run-call
+;; "-kill-runs"
+;; "kill runs"
+;; (lambda (target runname keys keyvals)
+;; (operate-on 'kill-runs mode: #f)
+;; )))
+;;
+;; (if (args:get-arg "-kill-rerun")
+;; (let* ((target-patt (common:args-get-target))
+;; (runname-patt (args:get-arg "-runname")))
+;; (cond ((not target-patt)
+;; (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ")
+;; (exit 1))
+;; ((not runname-patt)
+;; (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ")
+;; (exit 1))
+;; ((string-search "[ ,%]" target-patt)
+;; (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ")
+;; (exit 1))
+;; ((string-search "[ ,%]" runname-patt)
+;; (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ")
+;; (exit 1))
+;; (else
+;; (general-run-call
+;; "-kill-runs"
+;; "kill runs"
+;; (lambda (target runname keys keyvals)
+;; (operate-on 'kill-runs mode: #f)
+;; ))
+;;
+;; (thread-sleep! 15))
+;; ;; fall thru and let "-run" loop fire
+;; )))
+;;
+;;
+;; (if (args:get-arg "-remove-runs")
+;; (general-run-call
+;; "-remove-runs"
+;; "remove runs"
+;; (lambda (target runname keys keyvals)
+;; (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
+;; 'remove-data-only
+;; 'remove-all)))))
+;;
+;; (if (args:get-arg "-remove-keep")
+;; (general-run-call
+;; "-remove-keep"
+;; "remove keep"
+;; (lambda (target runname keys keyvals)
+;; (let ((actions (map string->symbol
+;; (string-split
+;; (or (args:get-arg "-actions")
+;; "print")
+;; ",")))) ;; default to printing the output
+;; (runs:remove-all-but-last-n-runs-per-target target runname
+;; (string->number (args:get-arg "-remove-keep"))
+;; actions: actions)))))
+;;
+;; (if (args:get-arg "-set-state-status")
+;; (general-run-call
+;; "-set-state-status"
+;; "set state and status"
+;; (lambda (target runname keys keyvals)
+;; (operate-on 'set-state-status))))
+;;
+;; (if (or (args:get-arg "-set-run-status")
+;; (args:get-arg "-get-run-status"))
+;; (general-run-call
+;; "-set-run-status"
+;; "set run status"
+;; (lambda (target runname keys keyvals)
+;; (let* ((runsdat (rmt:get-runs-by-patt keys runname
+;; (common:args-get-target)
+;; #f #f #f #f))
+;; (header (vector-ref runsdat 0))
+;; (rows (vector-ref runsdat 1)))
+;; (if (null? rows)
+;; (begin
+;; (debug:print-info 0 *default-log-port* "No matching run found.")
+;; (exit 1))
+;; (let* ((row (car (vector-ref runsdat 1)))
+;; (run-id (db:get-value-by-header row header "id")))
+;; (if (args:get-arg "-set-run-status")
+;; (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
+;; (print (rmt:get-run-status run-id))
+;; )))))))
+;;
+;; ;;======================================================================
+;; ;; Query runs
+;; ;;======================================================================
+;;
+;; ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
+;; ;;
+;; ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
+;; ;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
+;; ;;
+;; ;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
+;; ;; and so alist-ref will yield what you expect
+;; ;;
+;; (define (extract-fields-constraints fields-spec)
+;; (map (lambda (table-spec) ;; runs:id,target,runname
+;; (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
+;; (if (> (length dat) 1)
+;; (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
+;; dat)))
+;; (string-split fields-spec "+")))
+;;
+;; (define (get-value-by-fieldname datavec test-field-index fieldname)
+;; (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
+;; (if indx
+;; (if (>= indx (vector-length datavec))
+;; #f ;; index too high, should raise an error I suppose
+;; (vector-ref datavec indx))
+;; #f)))
+;;
+;;
+;;
+;;
+;;
+;; (when (args:get-arg "-testdata-csv")
+;; (if (launch:setup)
+;; (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
+;; (runpatt (or (args:get-arg "-runname") "%"))
+;; (testpatt (common:args-get-testpatt #f))
+;; (datapatt (args:get-arg "-testdata-csv"))
+;; (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
+;; (categorypatt (if match-data (list-ref match-data 1) "%"))
+;; (setvarpatt (if match-data
+;; (list-ref match-data 2)
+;; (args:get-arg "-testdata-csv")))
+;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
+;; (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+;; (header (db:get-header runsdat))
+;; (access-mode (db:get-access-mode))
+;; (testpatt (common:args-get-testpatt #f))
+;; (fields-spec (if (args:get-arg "-fields")
+;; (extract-fields-constraints (args:get-arg "-fields"))
+;; (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
+;; (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
+;; (list "steps" "id" "stepname"))))
+;; (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
+;; (if (and t (null? t)) ;; all fields
+;; db:test-record-fields
+;; t)))
+;; (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields)))
+;; (test-field-index (make-hash-table))
+;; (runs (db:get-rows runsdat))
+;; )
+;; (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
+;; (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
+;; (if (null? invalid-tests-spec)
+;; ;; generate the lookup map test-field-name => index-number
+;; (let loop ((hed (car adj-tests-spec))
+;; (tal (cdr adj-tests-spec))
+;; (idx 0))
+;; (hash-table-set! test-field-index hed idx)
+;; (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
+;; (exit)))))
+;; (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
+;; (table-rows
+;; (apply append (map
+;; (lambda (run)
+;; (let* ((target (string-intersperse (map (lambda (x)
+;; (db:get-value-by-header run header x))
+;; keys) "/"))
+;; (statuses (string-split (or (args:get-arg "-status") "") ","))
+;; (run-id (db:get-value-by-header run header "id"))
+;; (runname (db:get-value-by-header run header "runname"))
+;; (states (string-split (or (args:get-arg "-state") "") ","))
+;; (tests (if tests-spec
+;; (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
+;; ;; use qryvals if test-spec provided
+;; (if tests-spec
+;; (string-intersperse adj-tests-spec ",")
+;; ;; db:test-record-fields
+;; #f)
+;; #f
+;; 'normal)
+;; '())))
+;; (apply append
+;; (map
+;; (lambda (test)
+;; (let* (
+;; (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
+;; (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
+;; (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
+;; (fullname (conc testname
+;; (if (equal? itempath "")
+;; ""
+;; (conc "/" itempath ))))
+;; (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
+;; (testdat (filter
+;; (lambda (x)
+;; (not (equal? "logpro"
+;; (list-ref x 10))))
+;; testdat-raw)))
+;; (map
+;; (lambda (item)
+;; (receive (id test_id category
+;; variable value expected
+;; tol units comment status type)
+;; (apply values item)
+;; (list target runname testname itempath category variable value comment)))
+;; testdat)))
+;; tests))))
+;; runs))))
+;; (print (string-join table-header ","))
+;; (for-each (lambda(table-row)
+;; (print (string-join (map ->string table-row) ",")))
+;;
+;;
+;; table-rows))))
+;; (set! *didsomething* #t)
+;; (bdat-time-to-exit-set! *bdat* #t))
+;;
+;;
+;;
+;; ;; NOTE: list-runs and list-db-targets operate on local db!!!
+;; ;;
+;; ;; IDEA: megatest list -runname blah% ...
+;; ;;
+;; (if (or (args:get-arg "-list-runs")
+;; (args:get-arg "-list-db-targets"))
+;; (if (launch:setup)
+;; (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
+;; (runpatt (args:get-arg "-list-runs"))
+;; (access-mode (db:get-access-mode))
+;; (testpatt (common:args-get-testpatt #f))
+;; ;; (if (args:get-arg "-testpatt")
+;; ;; (args:get-arg "-testpatt")
+;; ;; "%"))
+;; (keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
+;; ;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
+;; ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
+;; ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
+;; (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+;; (runstmp (db:get-rows runsdat))
+;; (header (db:get-header runsdat))
+;; ;; this is "-since" support. This looks at last mod times of .db files
+;; ;; and collects those modified since the -since time.
+;; (runs runstmp)
+;; ;; (if (and (not (null? runstmp))
+;; ;; (args:get-arg "-since"))
+;; ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
+;; ;; (let loop ((hed (car runstmp))
+;; ;; (tal (cdr runstmp))
+;; ;; (res '()))
+;; ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
+;; ;; (cons hed res)
+;; ;; res)))
+;; ;; (if (null? tal)
+;; ;; (reverse new-res)
+;; ;; (loop (car tal)(cdr tal) new-res)))))
+;; ;; runstmp))
+;; (db-targets (args:get-arg "-list-db-targets"))
+;; (seen (make-hash-table))
+;; (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
+;; (if d (string->symbol d) #f)))
+;; (data (make-hash-table))
+;; (fields-spec (if (args:get-arg "-fields")
+;; (extract-fields-constraints (args:get-arg "-fields"))
+;; (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
+;; (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
+;; (list "steps" "id" "stepname"))))
+;; (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary
+;; (if (and r (not (null? r))) r (list "id" ))))
+;; (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
+;; (if (and t (null? t)) ;; all fields
+;; db:test-record-fields
+;; t)))
+;; (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
+;; (steps-spec (alist-ref "steps" fields-spec equal?))
+;; (test-field-index (make-hash-table)))
+;; (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
+;; (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
+;; (if (null? invalid-tests-spec)
+;; ;; generate the lookup map test-field-name => index-number
+;; (let loop ((hed (car adj-tests-spec))
+;; (tal (cdr adj-tests-spec))
+;; (idx 0))
+;; (hash-table-set! test-field-index hed idx)
+;; (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
+;; (exit)))))
+;; ;; Each run
+;; (for-each
+;; (lambda (run)
+;; (let ((targetstr (string-intersperse (map (lambda (x)
+;; (db:get-value-by-header run header x))
+;; keys) "/")))
+;; (if db-targets
+;; (if (not (hash-table-ref/default seen targetstr #f))
+;; (begin
+;; (hash-table-set! seen targetstr #t)
+;; ;; (print "[" targetstr "]"))))
+;; (if (not dmode)
+;; (print targetstr)
+;; (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
+;; )))
+;; (let* ((run-id (db:get-value-by-header run header "id"))
+;; (runname (db:get-value-by-header run header "runname"))
+;; (states (string-split (or (args:get-arg "-state") "") ","))
+;; (statuses (string-split (or (args:get-arg "-status") "") ","))
+;; (tests (if tests-spec
+;; (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
+;; ;; use qryvals if test-spec provided
+;; (if tests-spec
+;; (string-intersperse adj-tests-spec ",")
+;; ;; db:test-record-fields
+;; #f)
+;; #f
+;; 'normal)
+;; '())))
+;; (case dmode
+;; ((json ods sexpr)
+;; (if runs-spec
+;; (for-each
+;; (lambda (field-name)
+;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
+;; runs-spec)))
+;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" )
+;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" )
+;; ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" )
+;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
+;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
+;; ;; ;; add last entry twice - seems to be a bug in hierhash?
+;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
+;; (else
+;; (if (null? runs-spec)
+;; (print "Run: " targetstr "/" runname
+;; " status: " (db:get-value-by-header run header "state")
+;; " run-id: " run-id ", number tests: " (length tests)
+;; " event_time: " (db:get-value-by-header run header "event_time"))
+;; (begin
+;; (if (not (member "target" runs-spec))
+;; ;; (display (conc "Target: " targetstr))
+;; (display (conc "Run: " targetstr "/" runname " ")))
+;; (for-each
+;; (lambda (field-name)
+;; (if (equal? field-name "target")
+;; (display (conc "target: " targetstr " "))
+;; (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
+;; runs-spec)
+;; (newline)))))
+;;
+;; (for-each
+;; (lambda (test)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
+;; (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
+;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+;; (print-call-chain (current-error-port)))
+;; (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
+;; (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
+;; (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
+;; (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
+;; (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
+;; (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test))
+;; (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test))
+;; (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test))
+;; (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test))
+;; (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
+;; (fullname (conc testname
+;; (if (equal? itempath "")
+;; ""
+;; (conc "(" itempath ")")))))
+;; (case dmode
+;; ((json ods sexpr)
+;; (if tests-spec
+;; (for-each
+;; (lambda (field-name)
+;; (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
+;; tests-spec)))
+;; ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" )
+;; ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" )
+;; ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" )
+;; ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" )
+;; ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" )
+;; ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" )
+;; ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" )
+;; ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf")
+;; ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration")
+;; ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
+;; ;; ;; add last entry twice - seems to be a bug in hierhash?
+;; ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
+;; ;; )
+;; (else
+;; (if (and tstate tstatus event-time)
+;; (format #t
+;; " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
+;; (if fullname fullname "")
+;; (if tstate tstate "")
+;; (if tstatus tstatus "")
+;; (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "")
+;; (if event-time event-time "")
+;; (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
+;; (print " Test: " fullname
+;; (if tstate (conc " State: " tstate) "")
+;; (if tstatus (conc " Status: " tstatus) "")
+;; (if (get-value-by-fieldname test test-field-index "run_duration")
+;; (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
+;; "")
+;; (if event-time (conc " Time: " event-time) "")
+;; (if (get-value-by-fieldname test test-field-index "host")
+;; (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
+;; "")))
+;; (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
+;; (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
+;; (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED")))
+;; (begin
+;; (print (if (get-value-by-fieldname test test-field-index "cpuload")
+;; (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload"))
+;; "") ;; (db:test-get-cpuload test)
+;; (if (get-value-by-fieldname test test-field-index "diskfree")
+;; (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
+;; "")
+;; (if (get-value-by-fieldname test test-field-index "uname")
+;; (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
+;; "")
+;; (if (get-value-by-fieldname test test-field-index "rundir")
+;; (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
+;; "")
+;; ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
+;; ;; (db:test-get-rundir test) ;; )
+;; )
+;; ;; Each test
+;; ;; DO NOT remote run
+;; (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
+;; (for-each
+;; (lambda (step)
+;; (format #t
+;; " Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
+;; (tdb:step-get-stepname step)
+;; (tdb:step-get-state step)
+;; (tdb:step-get-status step)
+;; (tdb:step-get-event_time step)))
+;; steps)))))))))
+;; (if (args:get-arg "-sort")
+;; (sort tests
+;; (lambda (a-test b-test)
+;; (let* ((key (args:get-arg "-sort"))
+;; (first (get-value-by-fieldname a-test test-field-index key))
+;; (second (get-value-by-fieldname b-test test-field-index key)))
+;; ((cond
+;; ((and (number? first)(number? second)) <)
+;; ((and (string? first)(string? second)) string<=?)
+;; (else equal?))
+;; first second))))
+;; tests))))))
+;; runs)
+;; (case dmode
+;; ((json) (json-write data))
+;; ((sexpr) (pp (common:to-alist data))))
+;; (let* ((metadat-fields (delete-duplicates
+;; (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
+;; (run-fields '(
+;; "testname"
+;; "item_path"
+;; "state"
+;; "status"
+;; "comment"
+;; "event_time"
+;; "host"
+;; "run_id"
+;; "run_duration"
+;; "attemptnum"
+;; "id"
+;; "archived"
+;; "diskfree"
+;; "cpuload"
+;; "final_logf"
+;; "shortdir"
+;; "rundir"
+;; "uname"
+;; )
+;; )
+;; (newdat (common:to-alist data))
+;; (allrundat (if (null? newdat)
+;; '()
+;; (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
+;; (runs (append
+;; (list "runs" ;; sheetname
+;; metadat-fields)
+;; (map (lambda (run)
+;; ;; (print "run: " run)
+;; (let* ((runname (car run))
+;; (rundat (cdr run))
+;; (metadat (let ((tmp (assoc "meta" rundat)))
+;; (if tmp (cdr tmp) #f))))
+;; ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
+;; (if metadat
+;; (map (lambda (field)
+;; (let ((tmp (assoc field metadat)))
+;; (if tmp (cdr tmp) "")))
+;; metadat-fields)
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
+;; '()))))
+;; allrundat)))
+;; ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
+;; (run-pages (map (lambda (targdat)
+;; (let* ((target (car targdat))
+;; (runsdat (cdr targdat)))
+;; (if runsdat
+;; (map (lambda (rundat)
+;; (let* ((runname (car rundat))
+;; (rundat (cdr rundat))
+;; (testsdat (let ((tmp (assoc "data" rundat)))
+;; (if tmp (cdr tmp) #f))))
+;; (if testsdat
+;; (let ((tests (map (lambda (test)
+;; (let* ((test-id (car test))
+;; (test-dat (cdr test)))
+;; (map (lambda (field)
+;; (let ((tmp (assoc field test-dat)))
+;; (if tmp (cdr tmp) "")))
+;; run-fields)))
+;; testsdat)))
+;; ;; (print "Target: " target "/" runname " tests:")
+;; ;; (pp tests)
+;; (cons (conc target "/" runname)
+;; (cons (list (conc target "/" runname))
+;; (cons '()
+;; (cons run-fields tests)))))
+;; (begin
+;; (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
+;; ;; (pp rundat)
+;; '()))))
+;; runsdat)
+;; '())))
+;; newdat)) ;; we use newdat to get target
+;; (sheets (filter (lambda (x)
+;; (not (null? x)))
+;; (cons runs (map car run-pages)))))
+;; ;; (print "allrundat:")
+;; ;; (pp allrundat)
+;; ;; (print "runs:")
+;; ;; (pp runs)
+;; ;(print "sheets: ")
+;; ;; (pp sheets)
+;; (if (eq? dmode 'ods)
+;; (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id)))
+;; (outputfile (or (args:get-arg "-o") "out.ods"))
+;; (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
+;; outputfile
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
+;; (conc (current-directory) "/" outputfile)))))
+;; (create-directory tempdir #t)
+;; (ods:list->ods tempdir ouf sheets))))
+;; ;; (system (conc "rm -rf " tempdir))
+;; (set! *didsomething* #t)
+;; (bdat-time-to-exit-set! *bdat* #t)
+;; ) ;; end if true branch (end of a let)
+;; ) ;; end if
+;; ) ;; end if -list-runs
+;;
+;; ;; list-waivers
+;; (if (and (args:get-arg "-list-waivers")
+;; (launch:setup))
+;; (let* ((runpatt (or (args:get-arg "-runname") "%"))
+;; (testpatt (common:args-get-testpatt #f))
+;; (keys (rmt:get-keys))
+;; (runsdat (rmt:get-runs-by-patt
+;; keys runpatt
+;; (common:args-get-target) #f #f
+;; '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+;; (runs (db:get-rows runsdat))
+;; (header (db:get-header runsdat))
+;; (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... )
+;; (addtest (lambda (target testname itempath comment)
+;; (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
+;; (hash-table-ref/default results target '())))))
+;; (last-target #f))
+;; (for-each
+;; (lambda (run)
+;; (let* ((run-id (db:get-value-by-header run header "id"))
+;; (target (rmt:get-target run-id))
+;; (runname (db:get-value-by-header run header "runname"))
+;; (tests (rmt:get-tests-for-run
+;; run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided
+;; #f #f #f)))
+;; (if (not (equal? target last-target))
+;; (print "[" target "]"))
+;; (set! last-target target)
+;; (print "# " runname)
+;; (for-each
+;; (lambda (testdat)
+;; (let* ((testfullname (conc (db:test-get-testname testdat)
+;; (if (equal? "" (db:test-get-item-path testdat))
+;; ""
+;; (conc "/" (db:test-get-item-path testdat)))
+;; )))
+;; (print testfullname " " (db:test-get-comment testdat))))
+;; tests)))
+;; runs)
+;; (set! *didsomething* #t)))
+;;
+;;
+;; ;; get lock in db for full run for this directory
+;; ;; for all tests with deps
+;; ;; walk tree of tests to find head tasks
+;; ;; add head tasks to task queue
+;; ;; add dependant tasks to task queue
+;; ;; add remaining tasks to task queue
+;; ;; for each task in task queue
+;; ;; if have adequate resources
+;; ;; launch task
+;; ;; else
+;; ;; put task in deferred queue
+;; ;; if still ok to run tasks
+;; ;; process deferred tasks per above steps
+;;
+;; ;; run all tests are are Not COMPLETED and PASS or CHECK
+;; (if (or (args:get-arg "-runall")
+;; (args:get-arg "-run")
+;; (args:get-arg "-rerun-clean")
+;; (args:get-arg "-rerun-all")
+;; (args:get-arg "-runtests")
+;; (args:get-arg "-kill-rerun"))
+;; (let ((need-clean (or (args:get-arg "-rerun-clean")
+;; (args:get-arg "-rerun-all")))
+;; (orig-cmdline (string-intersperse (argv) " ")))
+;; (general-run-call
+;; "-runall"
+;; "run all tests"
+;; (lambda (target runname keys keyvals)
+;; (if (or (string-search "%" target)
+;; (string-search "%" runname)) ;; we are being asked to re-run multiple runs
+;; (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
+;; (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
+;; (length run-specs) " matches round. Running each in turn.")
+;; (if (null? run-specs)
+;; (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
+;; (for-each (lambda (spec)
+;; (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
+;; (newcmdline (conc
+;; precmd
+;; (string-substitute
+;; (conc "target " target)
+;; (conc "target " (simple-run-target spec))
+;; (string-substitute
+;; (conc "runname " runname)
+;; (conc "runname " (simple-run-runname spec))
+;; orig-cmdline)))))
+;; (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
+;; (debug:print 0 *default-log-port* "NEW: " newcmdline)
+;; (system newcmdline)))
+;; run-specs))
+;; (handle-run-requests target runname keys keyvals need-clean))))))
+;;
+;; ;;======================================================================
+;; ;; run one test
+;; ;;======================================================================
+;;
+;; ;; 1. find the config file
+;; ;; 2. change to the test directory
+;; ;; 3. update the db with "test started" status, set running host
+;; ;; 4. process launch the test
+;; ;; - monitor the process, update stats in the db every 2^n minutes
+;; ;; 5. as the test proceeds internally it calls megatest as each step is
+;; ;; started and completed
+;; ;; - step started, timestamp
+;; ;; - step completed, exit status, timestamp
+;; ;; 6. test phone home
+;; ;; - if test run time > allowed run time then kill job
+;; ;; - if cannot access db > allowed disconnect time then kill job
+;;
+;; ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
+;; ;; == duplicated == (general-run-call
+;; ;; == duplicated == "-runtests"
+;; ;; == duplicated == "run a test"
+;; ;; == duplicated == (lambda (target runname keys keyvals)
+;; ;; == duplicated == ;;
+;; ;; == duplicated == ;; May or may not implement it this way ...
+;; ;; == duplicated == ;;
+;; ;; == duplicated == ;; Insert this run into the tasks queue
+;; ;; == duplicated == ;; (open-run-close tasks:add tasks:open-db
+;; ;; == duplicated == ;; "runtests"
+;; ;; == duplicated == ;; user
+;; ;; == duplicated == ;; target
+;; ;; == duplicated == ;; runname
+;; ;; == duplicated == ;; (args:get-arg "-runtests")
+;; ;; == duplicated == ;; #f))))
+;; ;; == duplicated == (runs:run-tests target
+;; ;; == duplicated == runname
+;; ;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
+;; ;; == duplicated == user
+;; ;; == duplicated == args:arg-hash))))
+;;
+;; ;;======================================================================
+;; ;; Rollup into a run
+;; ;;======================================================================
+;;
+;; ;; (if (args:get-arg "-rollup")
+;; ;; (general-run-call
+;; ;; "-rollup"
+;; ;; "rollup tests"
+;; ;; (lambda (target runname keys keyvals)
+;; ;; (runs:rollup-run keys
+;; ;; keyvals
+;; ;; (or (args:get-arg "-runname")(args:get-arg ":runname") )
+;; ;; user))))
+;;
+;; ;;======================================================================
+;; ;; Lock or unlock a run
+;; ;;======================================================================
+;;
+;; (if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
+;; (general-run-call
+;; (if (args:get-arg "-lock") "-lock" "-unlock")
+;; "lock/unlock tests"
+;; (lambda (target runname keys keyvals)
+;; (runs:handle-locking
+;; target
+;; keys
+;; (or (args:get-arg "-runname")(args:get-arg ":runname") )
+;; (args:get-arg "-lock")
+;; (args:get-arg "-unlock")
+;; (bdat-user *bdat*)))))
+;;
+;; ;;======================================================================
+;; ;; Get paths to tests
+;; ;;======================================================================
+;; ;; Get test paths matching target, runname, and testpatt
+;; (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
+;; ;; if we are in a test use the MT_CMDINFO data
+;; (if (get-environment-variable "MT_CMDINFO")
+;; (let* ((startingdir (current-directory))
+;; (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
+;; (transport (assoc/default 'transport cmdinfo))
+;; (testpath (assoc/default 'testpath cmdinfo))
+;; (test-name (assoc/default 'test-name cmdinfo))
+;; (runscript (assoc/default 'runscript cmdinfo))
+;; (db-host (assoc/default 'db-host cmdinfo))
+;; (run-id (assoc/default 'run-id cmdinfo))
+;; (itemdat (assoc/default 'itemdat cmdinfo))
+;; (state (args:get-arg ":state"))
+;; (status (args:get-arg ":status"))
+;; ;;(target (args:get-arg "-target"))
+;; (target (common:args-get-target))
+;; (toppath (assoc/default 'toppath cmdinfo)))
+;; (change-directory toppath)
+;; (if (not target)
+;; (begin
+;; (debug:print-error 0 *default-log-port* "-target is required.")
+;; (exit 1)))
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
+;; (exit 1)))
+;; (let* ((keys (rmt:get-keys))
+;; ;; db:test-get-paths must not be run remote
+;; (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
+;; (set! *didsomething* #t)
+;; (for-each (lambda (path)
+;; (if (common:file-exists? path)
+;; (print path)))
+;; paths)))
+;; ;; else do a general-run-call
+;; (general-run-call
+;; "-test-files"
+;; "Get paths to test"
+;; (lambda (target runname keys keyvals)
+;; (let* ((db #f)
+;; ;; DO NOT run remote
+;; (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
+;; (for-each (lambda (path)
+;; (print path))
+;; paths))))))
+;;
+;; ;;======================================================================
+;; ;; Archive tests
+;; ;;======================================================================
+;; ;; Archive tests matching target, runname, and testpatt
+;; (if (equal? (args:get-arg "-archive") "replicate-db")
+;; (begin
+;; ;; check if source
+;; ;; check if megatest.db exist
+;; (launch:setup)
+;; (if (not (args:get-arg "-source"))
+;; (begin
+;; (debug:print-info 1 *default-log-port* "Missing required argument -source ")
+;; (exit 1)))
+;; (if (common:file-exists? (conc *toppath* "/megatest.db"))
+;; (begin
+;; (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
+;; (exit 1)))
+;; (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0))
+;; (begin
+;; (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
+;; (exit 1)))
+;; ;; check if timestamp
+;; (let* ((source (args:get-arg "-source"))
+;; (src (if (not (equal? (substring source 0 1) "/"))
+;; (conc (current-directory) "/" source)
+;; source))
+;; (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest")))
+;; (if (common:directory-exists? src)
+;; (begin
+;; (archive:restore-db src ts)
+;; (set! *didsomething* #t))
+;; (begin
+;; (debug:print-error 1 *default-log-port* "Path " source " not found")
+;; (exit 1))))))
+;; ;; else do a general-run-call
+;; (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db")))
+;; (begin
+;; ;; for the archive get we need to preserve the starting dir as part of the target path
+;; (if (and (args:get-arg "-dest")
+;; (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
+;; (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest"))))
+;; (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
+;; (hash-table-set! args:arg-hash "-dest" newpath)))
+;; (general-run-call
+;; "-archive"
+;; "Archive"
+;; (lambda (target runname keys keyvals)
+;; (operate-on 'archive target-in: target runname-in: runname )))))
+;;
+;; ;;======================================================================
+;; ;; Extract a spreadsheet from the runs database
+;; ;;======================================================================
+;;
+;; ;; TODO: Reenable this functionality
+;;
+;; #;(if (args:get-arg "-extract-ods")
+;; (general-run-call
+;; "-extract-ods"
+;; "Make ods spreadsheet"
+;; (lambda (target runname keys keyvals)
+;; (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
+;; (outputfile (args:get-arg "-extract-ods"))
+;; (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname")))
+;; (pathmod (args:get-arg "-pathmod")))
+;; ;; (keyvalalist (keys->alist keys "%")))
+;; (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
+;; (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
+;; (db:close-all dbstruct)
+;; (set! *didsomething* #t)))))
+;;
+;; ;;======================================================================
+;; ;; execute the test
+;; ;; - gets called on remote host
+;; ;; - receives info from the -execute param
+;; ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
+;; ;; - gathers host info and
+;; ;;======================================================================
+;;
+;; (if (args:get-arg "-execute")
+;; (begin
+;; (launch:execute (args:get-arg "-execute"))
+;; (set! *didsomething* #t)))
+;;
+;; ;;======================================================================
+;; ;; recover from a test where the managing mtest was killed but the underlying
+;; ;; process might still be salvageable
+;; ;;======================================================================
+;;
+;; (if (args:get-arg "-recover-test")
+;; (let* ((params (string-split (args:get-arg "-recover-test") ",")))
+;; (if (> (length params) 1) ;; run-id and test-id
+;; (let ((run-id (string->number (car params)))
+;; (test-id (string->number (cadr params))))
+;; (if (and run-id test-id)
+;; (begin
+;; (launch:recover-test run-id test-id)
+;; (set! *didsomething* #t))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
+;; (exit 1)))))))
+;;
+;; (if (args:get-arg "-step")
+;; (begin
+;; (thread-sleep! 1.5)
+;; (megatest:step
+;; (args:get-arg "-step")
+;; (or (args:get-arg "-state")(args:get-arg ":state"))
+;; (or (args:get-arg "-status")(args:get-arg ":status"))
+;; (args:get-arg "-setlog")
+;; (args:get-arg "-m"))
+;; ;; (if db (sqlite3:finalize! db))
+;; (set! *didsomething* #t)
+;; (thread-sleep! 1.5)))
+;;
+;; (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status
+;; ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous
+;; ;; NEW POLICY - -setlog sets test overall log on every call.
+;; (args:get-arg "-set-toplog")
+;; (args:get-arg "-test-status")
+;; (args:get-arg "-set-values")
+;; (args:get-arg "-load-test-data")
+;; (args:get-arg "-runstep")
+;; (args:get-arg "-summarize-items"))
+;; (if (not (get-environment-variable "MT_CMDINFO"))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
+;; (exit 5))
+;; (let* ((startingdir (current-directory))
+;; (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
+;; (transport (assoc/default 'transport cmdinfo))
+;; (testpath (assoc/default 'testpath cmdinfo))
+;; (test-name (assoc/default 'test-name cmdinfo))
+;; (runscript (assoc/default 'runscript cmdinfo))
+;; (db-host (assoc/default 'db-host cmdinfo))
+;; (run-id (assoc/default 'run-id cmdinfo))
+;; (test-id (assoc/default 'test-id cmdinfo))
+;; (itemdat (assoc/default 'itemdat cmdinfo))
+;; (work-area (assoc/default 'work-area cmdinfo))
+;; (db #f) ;; (open-db))
+;; (state (args:get-arg ":state"))
+;; (status (args:get-arg ":status"))
+;; (stepname (args:get-arg "-step")))
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;;
+;; (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
+;; (change-directory work-area)
+;; ;; can setup as client for server mode now
+;; ;; (client:setup)
+;;
+;; (if (args:get-arg "-load-test-data")
+;; ;; has sub commands that are rdb:
+;; ;; DO NOT put this one into either rmt: or open-run-close
+;; (tdb:load-test-data run-id test-id))
+;; (if (args:get-arg "-setlog")
+;; (let ((logfname (args:get-arg "-setlog")))
+;; (rmt:test-set-log! run-id test-id logfname)))
+;; (if (args:get-arg "-set-toplog")
+;; ;; DO NOT run remote
+;; (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
+;; (if (args:get-arg "-summarize-items")
+;; ;; DO NOT run remote
+;; (tests:summarize-items run-id test-id test-name #t)) ;; do force here
+;; (if (args:get-arg "-runstep")
+;; (if (null? remargs)
+;; (begin
+;; (debug:print-error 0 *default-log-port* "nothing specified to run!")
+;; (if db (sqlite3:finalize! db))
+;; (exit 6))
+;; (let* ((stepname (args:get-arg "-runstep"))
+;; (logprofile (args:get-arg "-logpro"))
+;; (logfile (conc stepname ".log"))
+;; (cmd (if (null? remargs) #f (car remargs)))
+;; (params (if cmd (cdr remargs) '()))
+;; (exitstat #f)
+;; (shell (let ((sh (get-environment-variable "SHELL") ))
+;; (if sh
+;; (last (string-split sh "/"))
+;; "bash")))
+;; (redir (case (string->symbol shell)
+;; ((tcsh csh ksh) ">&")
+;; ((zsh bash sh ash) "2>&1 >")
+;; (else ">&")))
+;; (fullcmd (conc "(" (string-intersperse
+;; (cons cmd params) " ")
+;; ") " redir " " logfile)))
+;; ;; mark the start of the test
+;; (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
+;; ;; run the test step
+;; (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
+;; (change-directory startingdir)
+;; (set! exitstat (system fullcmd))
+;; (set! *globalexitstatus* exitstat)
+;; ;; (change-directory testpath)
+;; ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
+;; (if logprofile
+;; (let* ((htmllogfile (conc stepname ".html"))
+;; (oldexitstat exitstat)
+;; (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
+;; (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
+;; (change-directory startingdir)
+;; (set! exitstat (system cmd))
+;; (set! *globalexitstatus* exitstat) ;; no necessary
+;; (change-directory testpath)
+;; (rmt:test-set-log! run-id test-id htmllogfile)))
+;; (let ((msg (args:get-arg "-m")))
+;; (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
+;; )))
+;; (if (or (args:get-arg "-test-status")
+;; (args:get-arg "-set-values"))
+;; (let ((newstatus (cond
+;; ((number? status) (if (equal? status 0) "PASS" "FAIL"))
+;; ((and (string? status)
+;; (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
+;; (else status)))
+;; ;; transfer relevant keys into a hash to be passed to test-set-status!
+;; ;; could use an assoc list I guess.
+;; (otherdata (let ((res (make-hash-table)))
+;; (for-each (lambda (key)
+;; (if (args:get-arg key)
+;; (hash-table-set! res key (args:get-arg key))))
+;; (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
+;; res)))
+;; (if (and (args:get-arg "-test-status")
+;; (or (not state)
+;; (not status)))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
+;; (if (sqlite3:database? db)(sqlite3:finalize! db))
+;; (exit 6)))
+;; (let* ((msg (args:get-arg "-m"))
+;; (numoth (length (hash-table-keys otherdata))))
+;; ;; Convert to rpc inside the tests:test-set-status! call, not here
+;; (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
+;; (if (sqlite3:database? db)(sqlite3:finalize! db))
+;; (set! *didsomething* #t))))
+;;
+;; ;;======================================================================
+;; ;; Various helper commands can go below here
+;; ;;======================================================================
+;;
+;; (if (or (args:get-arg "-showkeys")
+;; (args:get-arg "-show-keys"))
+;; (let ((db #f)
+;; (keys #f))
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; (set! keys (rmt:get-keys)) ;; db))
+;; (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
+;; (if (sqlite3:database? db)(sqlite3:finalize! db))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-gui")
+;; (begin
+;; (debug:print 0 *default-log-port* "Look at the dashboard for now")
+;; ;; (megatest-gui)
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-create-megatest-area")
+;; (begin
+;; (genexample:mk-megatest.config)
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-create-test")
+;; (let ((testname (args:get-arg "-create-test")))
+;; (genexample:mk-megatest-test testname)
+;; (set! *didsomething* #t)))
+;;
+;; ;;======================================================================
+;; ;; Update the database schema, clean up the db
+;; ;;======================================================================
+;;
+;; ;; TODO: Restore this functionality
+;;
+;; #;(if (args:get-arg "-rebuild-db")
+;; (begin
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; ;; keep this one local
+;; ;; (open-run-close patch-db #f)
+;; (let ((dbstruct (db:setup #f areapath: *toppath*)))
+;; (common:cleanup-db dbstruct full: #t))
+;; (set! *didsomething* #t)))
+;;
+;; #;(if (args:get-arg "-cleanup-db")
+;; (begin
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; (let ((dbstruct (db:setup #f areapath: *toppath*)))
+;; (common:cleanup-db dbstruct))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-mark-incompletes")
+;; (begin
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; (runs:find-and-mark-incomplete-and-check-end-of-run #f)
+;; (set! *didsomething* #t)))
+;;
+;; ;;======================================================================
+;; ;; Update the tests meta data from the testconfig files
+;; ;;======================================================================
+;;
+;; (if (args:get-arg "-update-meta")
+;; (begin
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; (runs:update-all-test_meta #f)
+;; (set! *didsomething* #t)))
+;;
+;; ;;======================================================================
+;; ;; Start a repl
+;; ;;======================================================================
+;;
+;; ;; fakeout readline
+;; ;; (include "readline-fix.scm")
+;;
+;;
+;; (when (args:get-arg "-diff-rep")
+;; (when (and
+;; (not (args:get-arg "-diff-html"))
+;; (not (args:get-arg "-diff-email")))
+;; (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
+;; (set! *didsomething* 1)
+;; (exit 1))
+;;
+;; (let* ((toppath (launch:setup)))
+;; (do-diff-report
+;; (args:get-arg "-src-target")
+;; (args:get-arg "-src-runname")
+;; (args:get-arg "-target")
+;; (args:get-arg "-runname")
+;; (args:get-arg "-diff-html")
+;; (args:get-arg "-diff-email"))
+;; (set! *didsomething* #t)
+;; (exit 0)))
+;;
+;; (if (or (get-environment-variable "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
+;; ((get-environment-variable "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 chicken.csi)
+;; ;; (import readline)
+;; #;(import apropos
+;; archivemod
+;; commonmod
+;; configfmod
+;; dbmod
+;; debugprint
+;; ezstepsmod
+;; 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")
+;; (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
+;; (begin
+;; (if (not (launch:setup))
+;; (begin
+;; (debug:print 0 *default-log-port* "Failed to setup, exiting")
+;; (exit 1)))
+;; (operate-on 'run-wait)
+;; (set! *didsomething* #t)))
+;;
+;; ;; ;; ;; redo me ;; Not converted to use dbstruct yet
+;; ;; ;; ;; redo me ;;
+;; ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
+;; ;; ;; ;; redo me (let* ((toppath (setup-for-run))
+;; ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
+;; ;; ;; ;; redo me (for-each
+;; ;; ;; ;; redo me (lambda (field)
+;; ;; ;; ;; redo me (let ((dat '()))
+;; ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field)
+;; ;; ;; ;; redo me (sqlite3:for-each-row
+;; ;; ;; ;; redo me (lambda (id val)
+;; ;; ;; ;; redo me (set! dat (cons (list id val) dat)))
+;; ;; ;; ;; redo me (db:get-db db run-id)
+;; ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;"))
+;; ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
+;; ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
+;; ;; ;; ;; redo me (for-each
+;; ;; ;; ;; redo me (lambda (item)
+;; ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid
+;; ;; ;; ;; redo me (cadr item))) ;; )
+;; ;; ;; ;; redo me (if (not (equal? newval (cadr item)))
+;; ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
+;; ;; ;; ;; redo me (sqlite3:execute qry newval (car item))))
+;; ;; ;; ;; redo me dat)
+;; ;; ;; ;; redo me (sqlite3:finalize! qry))))
+;; ;; ;; ;; redo me (db:close-all dbstruct)
+;; ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
+;; ;; ;; ;; redo me (set! *didsomething* #t)))
+;;
+;; ;; TODO: restore this functionality
+;;
+;; #;(if (args:get-arg "-import-megatest.db")
+;; (begin
+;; (db:multi-db-sync
+;; (db:setup #f)
+;; 'killservers
+;; 'dejunk
+;; 'adj-testids
+;; 'old2new
+;; ;; 'new2old
+;; )
+;; (set! *didsomething* #t)))
+;;
+;; #;(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"))
+;; (locked (common:simple-file-lock lockfile))
+;; (res (if locked
+;; (db:multi-db-sync
+;; dbstruct
+;; 'new2old)
+;; #f)))
+;; (if res
+;; (begin
+;; (common:simple-file-release-lock lockfile)
+;; (print "Synced " res " records to megatest.db"))
+;; (print "Skipping sync, there is a sync in progress."))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-sync-to")
+;; (let ((toppath (launch:setup)))
+;; (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-list-test-time")
+;; (let* ((toppath (launch:setup)))
+;; (task:get-test-times)
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-list-run-time")
+;; (let* ((toppath (launch:setup)))
+;; (task:get-run-times)
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-generate-html")
+;; (let* ((toppath (launch:setup)))
+;; (if (tests:create-html-tree #f)
+;; (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
+;; (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-generate-html-structure")
+;; (let* ((toppath (launch:setup)))
+;; ;(if (tests:create-html-tree #f)
+;; (if (tests:create-html-summary #f)
+;; (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
+;; (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-syscheck")
+;; (begin
+;; (mutils:syscheck common:raw-get-remote-host-load
+;; server:get-best-guess-address
+;; configf:read-config)
+;; (set! *didsomething* #t)))
+;;
+;; (if (args:get-arg "-extract-skeleton")
+;; (let* ((toppath (launch:setup)))
+;; (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
+;; (set! *didsomething* #t)))
+;;
+;; ;;======================================================================
+;; ;; Exit and clean up
+;; ;;======================================================================
+;;
+;; (if (not *didsomething*)
+;; (debug:print 0 *default-log-port* help)
+;; (bdat-time-to-exit-set! *bdat* #t)
+;; )
+;; ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
+;;
+;; ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
+;; ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
+;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+;; #;(let* ((watchdog (bdat-watchdog *bdat*)))
+;; (if (thread? watchdog)
+;; (case (thread-state watchdog)
+;; ((ready running blocked sleeping terminated dead)
+;; (thread-join! watchdog)))))
+;;
+;; (bdat-time-to-exit-set! *bdat* #t)
+;;
+;; (if (not (eq? *globalexitstatus* 0))
+;; (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
+;; (begin
+;; (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
+;; (exit 0))
+;; (case *globalexitstatus*
+;; ((0)(exit 0))
+;; ((1)(exit 1))
+;; ((2)(exit 2))
+;; (else (exit 3)))))
+;; )
+;;
+;; ;; (import megatest-main commonmod)
+;; ;; (import srfi-18)
+
+
ADDED ulex-dual/dbmgr.scm
Index: ulex-dual/dbmgr.scm
==================================================================
--- /dev/null
+++ ulex-dual/dbmgr.scm
@@ -0,0 +1,1003 @@
+;;======================================================================
+;; Copyright 2022, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit dbmgrmod))
+
+(declare (uses ulex))
+(declare (uses apimod))
+(declare (uses pkts))
+(declare (uses commonmod))
+(declare (uses dbmod))
+(declare (uses mtargs))
+(declare (uses portloggermod))
+(declare (uses debugprint))
+
+(module dbmgrmod
+ *
+
+(import scheme
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.format
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+
+ (prefix sqlite3 sqlite3:)
+ matchable
+ md5
+ message-digest
+ regex
+ s11n
+ srfi-1
+ srfi-18
+ srfi-69
+ system-information
+ typed-records
+
+ pkts
+ ulex
+
+ commonmod
+ apimod
+ dbmod
+ debugprint
+ (prefix mtargs args:)
+ portloggermod
+ )
+
+;; Configurations for server
+;; (tcp-buffer-size 2048)
+;; (max-connections 2048)
+
+;; info about me as a listener and my connections to db servers
+;; stored (for now) in *db-serv-info*
+;;
+(defstruct servdat
+ (host #f)
+ (port #f)
+ (uuid #f)
+ (dbfile #f)
+ (uconn #f) ;; this is the listener for this process
+ (mode #f)
+ (status 'starting)
+ (trynum 0) ;; count the number of ports we've tried
+ (conns (make-hash-table)) ;; apath/dbname => conndat
+ )
+
+(define *db-serv-info* #f)
+
+(define (servdat->url sdat)
+ (conc (servdat-host sdat)":"(servdat-port sdat)))
+
+;; db servers contact info
+;;
+(defstruct conndat
+ (apath #f)
+ (dbname #f)
+ (fullname #f)
+ (hostport #f)
+ (ipaddr #f)
+ (port #f)
+ (srvpkt #f)
+ (srvkey #f)
+ (lastmsg 0)
+ (expires 0))
+
+(define *srvpktspec*
+ `((server (host . h)
+ (port . p)
+ (servkey . k)
+ (pid . i)
+ (ipaddr . a)
+ (dbpath . d))))
+
+;;======================================================================
+;; S U P P O R T F U N C T I O N S
+;;======================================================================
+
+;; set up the api proc, seems like there should be a better place for this?
+;;
+;; IS THIS NEEDED ANYMORE? TODO - REMOVE IF POSSIBLE
+;;
+;; (define api-proc (make-parameter conc))
+;; (api-proc api:execute-requests)
+
+;; do we have a connection to apath dbname and
+;; is it not expired? then return it
+;;
+;; else setup a connection
+;;
+;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception
+;;
+(define (rmt:get-conn remdat apath dbname)
+ (let* ((fullname (db:dbname->path apath dbname)))
+ (hash-table-ref/default (servdat-conns remdat) fullname #f)))
+
+(define (rmt:drop-conn remdat apath dbname)
+ (let* ((fullname (db:dbname->path apath dbname)))
+ (hash-table-delete! (servdat-conns remdat) fullname)))
+
+(define (rmt:find-main-server uconn apath dbname)
+ (let* ((pktsdir (get-pkts-dir apath))
+ (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
+ (viable-srvs (get-viable-servers all-srvpkts dbname)))
+ (get-the-server uconn apath viable-srvs)))
+
+
+(define *connstart-mutex* (make-mutex))
+(define *last-main-start* 0)
+
+;; looks for a connection to main, returns if have and not exired
+;; creates new otherwise
+;;
+;; connections for other servers happens by requesting from main
+;;
+;; TODO: This is unnecessarily re-creating the record in the hash table
+;;
+(define (rmt:open-main-connection remdat apath)
+ (let* ((fullpath (db:dbname->path apath ".db/main.db"))
+ (conns (servdat-conns remdat))
+ (conn (rmt:get-conn remdat apath ".db/main.db")) ;; (hash-table-ref/default conns fullpath #f)) ;; TODO - create call for this
+ (myconn (servdat-uconn remdat)))
+ (cond
+ ((not myconn)
+ (servdat-uconn-set! remdat (make-udat))
+ (rmt:open-main-connection remdat apath))
+ ((and conn ;; conn is NOT a socket, just saying ...
+ (< (current-seconds) (conndat-expires conn)))
+ #t) ;; we are current and good to go - we'll deal elsewhere with a server that was killed or died
+ ((and conn
+ (>= (current-seconds)(conndat-expires conn)))
+ (debug:print-info 0 *default-log-port* "connection to "fullpath" server expired. Reconnecting.")
+ (rmt:drop-conn remdat apath ".db/main.db") ;;
+ (rmt:open-main-connection remdat apath))
+ (else
+ ;; Below we will find or create and connect to main
+ (debug:print-info 0 *default-log-port* "rmt:open-main-connection - starting from scratch")
+ (let* ((dbname (db:run-id->dbname #f))
+ (the-srv (rmt:find-main-server myconn apath dbname))
+ (start-main-srv (lambda () ;; call IF there is no the-srv found
+ (mutex-lock! *connstart-mutex*)
+ (if (> (- (current-seconds) *last-main-start*) 5) ;; at least four seconds since last attempt to start main server
+ (begin
+ (api:run-server-process apath dbname)
+ (set! *last-main-start* (current-seconds))
+ (thread-sleep! 1))
+ (thread-sleep! 0.25))
+ (mutex-unlock! *connstart-mutex*)
+ (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries
+ )))
+ (if (not the-srv) ;; have server, try connecting to it
+ (start-main-srv)
+ (let* ((srv-addr (server-address the-srv)) ;; need serv
+ (ipaddr (alist-ref 'ipaddr the-srv))
+ (port (alist-ref 'port the-srv))
+ (srvkey (alist-ref 'servkey the-srv))
+ (fullpath (db:dbname->path apath dbname))
+
+ (new-the-srv (make-conndat
+ apath: apath
+ dbname: dbname
+ fullname: fullpath
+ hostport: srv-addr
+ ;; socket: (open-nn-connection srv-addr) - TODO - open ulex connection?
+ ipaddr: ipaddr
+ port: port
+ srvpkt: the-srv
+ srvkey: srvkey ;; generated by rmt:get-signature on the server side
+ lastmsg: (current-seconds)
+ expires: (+ (current-seconds)
+ (server:expiration-timeout)
+ -2) ;; this needs to be gathered during the ping
+ )))
+ (hash-table-set! conns fullpath new-the-srv)))
+ #t)))))
+
+;; NB// sinfo is a servdat struct
+;;
+(define (rmt:general-open-connection sinfo apath dbname #!key (num-tries 5))
+ (assert (not (equal? dbname ".db/main.db")) "ERROR: general-open-connection should never be called with main as the db")
+ (let* ((mdbname ".db/main.db") ;; (db:run-id->dbname #f)) TODO: put this back to the lookup when stable
+ (fullname (db:dbname->path apath dbname))
+ (conns (servdat-conns sinfo))
+ (mconn (rmt:get-conn sinfo apath ".db/main.db"))
+ (dconn (rmt:get-conn sinfo apath dbname)))
+ #;(if (and mconn
+ (not (debug:print-logger)))
+ (begin
+ (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.")
+ (debug:print-logger rmt:log-to-main)))
+ (cond
+ ((and mconn
+ dconn
+ (< (current-seconds)(conndat-expires dconn)))
+ #t) ;; good to go
+ ((not mconn) ;; no channel open to main? open it...
+ (rmt:open-main-connection sinfo apath)
+ (rmt:general-open-connection sinfo apath dbname num-tries: (- num-tries 1)))
+ ((not dconn) ;; no channel open to dbname?
+ (let* ((res (rmt:send-receive-real sinfo apath mdbname 'get-server `(,apath ,dbname))))
+ (case res
+ ((server-started)
+ (if (> num-tries 0)
+ (begin
+ (thread-sleep! 2)
+ (rmt:general-open-connection sinfo 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.
+ (begin ;; ("192.168.0.9" 53817
+ ;; "5e34239f48e8973b3813221e54701a01" "24310"
+ ;; "192.168.0.9"
+ ;; "/home/matt/data/megatest/tests/simplerun"
+ ;; ".db/1.db")
+ (match
+ res
+ ((host port servkey pid ipaddr apath dbname)
+ (debug:print-info 0 *default-log-port* "got "res)
+ (hash-table-set! conns
+ fullname
+ (make-conndat
+ apath: apath
+ dbname: dbname
+ hostport: (conc host":"port)
+ ;; socket: (open-nn-connection (conc host":"port)) ;; TODO - open ulex connection?
+ ipaddr: ipaddr
+ port: port
+ srvkey: servkey
+ lastmsg: (current-seconds)
+ expires: (+ (current-seconds)
+ (server:expiration-timeout)
+ -2))))
+ (else
+ (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res)))
+ res)
+ (begin
+ (debug:print-info 0 *default-log-port* "Unexpected result: " res)
+ res)))))))
+ #t))
+
+;;======================================================================
+
+;; FOR DEBUGGING SET TO #t
+;; (define *localmode* #t)
+(define *localmode* #f)
+(define *dbstruct* (make-dbr:dbstruct))
+
+;; Defaults to current area
+;;
+(define (rmt:send-receive-attempted-consolidation cmd rid params #!key (attemptnum 1)(area-dat #f))
+ (let* ((apath *toppath*)
+ (sinfo *db-serv-info*)
+ (dbname (db:run-id->dbname rid)))
+ (if (not *db-serv-info*)
+ (begin
+ (set! *db-serv-info* (make-servdat))
+ (set! sinfo *db-serv-info*)))
+ (rmt:open-main-connection sinfo apath)
+ (if rid (rmt:general-open-connection sinfo apath dbname))
+ ;; (if (not (member cmd '(log-to-main)))
+ ;; (debug:print-info 0 *default-log-port* "rmt:send-receive "cmd" params="params))
+ (let* ((cdat (rmt:get-conn sinfo apath dbname)))
+ (assert cdat "FATAL: rmt:send-receive-real called without the needed channels opened")
+ (let* ((uconn (servdat-uconn sinfo)) ;; get the interface to ulex
+ ;; then send-receive using the ulex layer to host-port stored in cdat
+ (res (send-receive uconn (conndat-hostport cdat) cmd params)))
+ (conndat-expires-set! cdat (+ (current-seconds)
+ (server:expiration-timeout)
+ -2)) ;; two second margin for network time misalignments etc.
+ res))))
+
+; Defaults to current area
+;;
+(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
+ (let* ((apath *toppath*)
+ (sinfo *db-serv-info*)
+ (dbname (db:run-id->dbname rid)))
+ (if (not *db-serv-info*) ;; confirm this is really needed
+ (begin
+ (set! *db-serv-info* (make-servdat))
+ (set! sinfo *db-serv-info*)))
+ (rmt:open-main-connection sinfo apath)
+ (if rid (rmt:general-open-connection sinfo apath dbname))
+ #;(if (not (member cmd '(log-to-main)))
+ (debug:print-info 0 *default-log-port* "rmt:send-receive "cmd" params="params))
+ (rmt:send-receive-real sinfo 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 sinfo apath dbname cmd params)
+ (let* ((cdat (rmt:get-conn sinfo apath dbname)))
+ (assert cdat "FATAL: rmt:send-receive-real called without the needed channels opened")
+ (let* ((uconn (servdat-uconn sinfo)) ;; get the interface to ulex
+ ;; then send-receive using the ulex layer to host-port stored in cdat
+ (res (send-receive uconn (conndat-hostport cdat) cmd params)))
+ ;; since we accessed the server we can bump the expires time up
+ (conndat-expires-set! cdat (+ (current-seconds)
+ (server:expiration-timeout)
+ -2)) ;; two second margin for network time misalignments etc.
+ res)))
+
+;
+;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
+;; sometime in the future.
+;;
+;; Purpose - call the main.db server and request a server be started
+;; for the given area path and dbname
+;;
+
+(define (rmt:print-db-stats)
+ (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
+ (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================")
+ (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
+ (for-each (lambda (cmd)
+ (let ((cmd-dat (hash-table-ref *db-stats* cmd)))
+ (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
+ (sort (hash-table-keys *db-stats*)
+ (lambda (a b)
+ (> (vector-ref (hash-table-ref *db-stats* a) 0)
+ (vector-ref (hash-table-ref *db-stats* b) 0)))))))
+
+(define (rmt:get-max-query-average run-id)
+ (mutex-lock! *db-stats-mutex*)
+ (let* ((runkey (conc "run-id=" run-id " "))
+ (cmds (filter (lambda (x)
+ (substring-index runkey x))
+ (hash-table-keys *db-stats*)))
+ (res (if (null? cmds)
+ (cons 'none 0)
+ (let loop ((cmd (car cmds))
+ (tal (cdr cmds))
+ (max-cmd (car cmds))
+ (res 0))
+ (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
+ (tot (vector-ref cmd-dat 0))
+ (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
+ (currmax (max res curravg))
+ (newmax-cmd (if (> curravg res) cmd max-cmd)))
+ (if (null? tal)
+ (if (> tot 10)
+ (cons newmax-cmd currmax)
+ (cons 'none 0))
+ (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
+ (mutex-unlock! *db-stats-mutex*)
+ res))
+
+;; host and port are used to ensure we are remove proper records
+(define (rmt:server-shutdown host port)
+ (let ((dbfile (servdat-dbfile *db-serv-info*)))
+ (debug:print-info 0 *default-log-port* "dbfile is "dbfile)
+ (if dbfile
+ (let* ((am-server (args:get-arg "-server"))
+ (dbfile (args:get-arg "-db"))
+ (apath *toppath*)
+ #;(sinfo *remotedat*)) ;; foundation for future fix
+ (if *dbstruct-db*
+ (let* ((dbdat (db:get-dbdat *dbstruct-db* apath dbfile))
+ (db (dbr:dbdat-db dbdat))
+ (inmem (dbr:dbdat-db dbdat)) ;; WRONG
+ )
+ ;; do a final sync here
+ (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds))
+ (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t)
+ ;; let's finalize here
+ (debug:print-info 0 *default-log-port* "Finalizing db and inmem")
+ (if (sqlite3:database? db)
+ (sqlite3:finalize! db)
+ (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, db is not a database, not finalizing..."))
+ (if (sqlite3:database? inmem)
+ (sqlite3:finalize! inmem)
+ (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, inmem is not a database, not finalizing..."))
+ (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete"))
+ (debug:print-info 0 *default-log-port* "Db was never opened, no cleanup to do."))
+ (if (not am-server)
+ (debug:print-info 0 *default-log-port* "I am not a server, should NOT get here!")
+ (if (string-match ".*/main.db$" dbfile)
+ (let ((pkt-file (conc (get-pkts-dir *toppath*)
+ "/" (servdat-uuid *db-serv-info*)
+ ".pkt")))
+ (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
+ (delete-file* pkt-file)
+ (debug:print-info 0 *default-log-port* "Releasing lock (if any) for "dbfile ", host "host", port "port)
+ (db:with-lock-db
+ (servdat-dbfile *db-serv-info*)
+ (lambda (dbh dbfile)
+ (db:release-lock dbh dbfile host port)))) ;; I'm not the server - should not have a lock to remove
+ (let* ((sdat *db-serv-info*) ;; we have a run-id server
+ (host (servdat-host sdat))
+ (port (servdat-port sdat))
+ (uuid (servdat-uuid sdat))
+ (res (rmt:deregister-server *db-serv-info* *toppath* host port uuid dbfile)))
+ (debug:print-info 0 *default-log-port* "deregistered-server, res="res)
+ (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid)
+ )))))))
+
+
+(define (common:run-sync?)
+ ;; (and (common:on-homehost?)
+ (args:get-arg "-server"))
+
+(define *rmt:run-mutex* (make-mutex))
+(define *rmt:run-flag* #f)
+
+(define (listener-running?)
+ (and *db-serv-info*
+ (servdat-uconn *db-serv-info*)))
+
+;; Main entry point to start a server. was start-server
+(define (rmt:run hostn)
+ (mutex-lock! *rmt:run-mutex*)
+ (if *rmt:run-flag*
+ (begin
+ (debug:print-warn 0 *default-log-port* "rmt:run already running.")
+ (mutex-unlock! *rmt:run-mutex*))
+ (begin
+ (set! *rmt:run-flag* #t)
+ (mutex-unlock! *rmt:run-mutex*)
+ ;; ;; Configurations for server
+ ;; (tcp-buffer-size 2048)
+ ;; (max-connections 2048)
+ (debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...")
+ (if (listener-running?)
+ (let* ((uconn (servdat-uconn *db-serv-info*)))
+ (wait-and-close uconn))
+ (let* ((port (portlogger:open-run-close portlogger:find-port))
+ (handler-proc (lambda (rem-host-port qrykey cmd params) ;;
+ (set! *db-last-access* (current-seconds))
+ (assert (list? params) "FATAL: handler called with non-list params")
+ (assert (args:get-arg "-server") "FATAL: handler called on non-server side. cmd="cmd", params="params)
+ (debug:print 0 *default-log-port* "handler call: "cmd", params="params)
+ (api:execute-requests *dbstruct-db* cmd params))))
+ ;; (api:process-request *dbstuct-db*
+ (if (not *db-serv-info*)
+ (set! *db-serv-info* (make-servdat host: hostn port: port)))
+ (let* ((uconn (run-listener handler-proc port))
+ (rport (udat-port uconn))) ;; the real port
+ (servdat-host-set! *db-serv-info* hostn)
+ (servdat-port-set! *db-serv-info* rport)
+ (servdat-uconn-set! *db-serv-info* uconn)
+ (wait-and-close uconn)
+ (db:print-current-query-stats)
+ )))
+ (let* ((host (servdat-host *db-serv-info*))
+ (port (servdat-port *db-serv-info*))
+ (mode (or (servdat-mode *db-serv-info*)
+ "non-db")))
+ ;; server exit stuff here
+ ;; (rmt:server-shutdown host port) - always do in on-exit
+ ;; (portlogger:open-run-close portlogger:set-port port "released") ;; moved to on-exit
+ (debug:print-info 0 *default-log-port* "Server "host":"port" mode "mode"shutdown complete. Exiting")
+ ))))
+
+;;======================================================================
+;; S E R V E R U T I L I T I E S
+;;======================================================================
+
+
+;;======================================================================
+;; NEW SERVER METHOD
+;;======================================================================
+
+;; only use for main.db - need to re-write some of this :(
+;;
+(define (get-lock-db sdat dbfile host port)
+ (assert host "FATAL: get-lock-db called with host not set.")
+ (assert port "FATAL: get-lock-db called with port not set.")
+ (let* ((dbh (db:open-run-db dbfile db:initialize-db)) ;; open-run-db creates a standard db with schema used by all situations
+ (res (db:get-iam-server-lock dbh dbfile host port))
+ (uconn (servdat-uconn sdat)))
+ ;; res => list then already locked, check server is responsive
+ ;; => #t then sucessfully got the lock
+ ;; => #f reserved for future use as to indicate something went wrong
+ (match res
+ ((owner_pid owner_host owner_port event_time)
+ (if (server-ready? uconn (conc owner_host":"owner_port) "abc")
+ #f ;; locked by someone else
+ (begin ;; locked by someone dead and gone
+ (debug:print 0 *default-log-port* "WARNING: stale lock - have to steal it. This may fail.")
+ (db:steal-lock-db dbh dbfile port))))
+ (#t #t) ;; placeholder so that we don't touch res if it is #t
+ (else (set! res #f)))
+ (sqlite3:finalize! dbh)
+ res))
+
+
+(define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath)
+ (let* ((pkt-dat `((host . ,host)
+ (port . ,port)
+ (servkey . ,servkey)
+ (pid . ,(current-process-id))
+ (ipaddr . ,ipaddr)
+ (dbpath . ,dbpath)))
+ (uuid (write-alist->pkt
+ pkts-dir
+ pkt-dat
+ pktspec: pkt-spec
+ ptype: 'server)))
+ (debug:print 0 *default-log-port* "Server on "host":"port" registered in pkt "uuid)
+ uuid))
+
+(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
+ (handle-exceptions ;; this exception handler should NOT be needed but ...
+ exn
+ pdir
+ (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
+ (create-directory pktsdir-in #t)
+ pktsdir-in)))
+ (all-pkt-files (glob (conc pktsdir "/*.pkt"))))
+ (map (lambda (pkt-file)
+ (read-pkt->alist pkt-file pktspec: pktspec))
+ all-pkt-files)))
+
+(define (server-address srv-pkt)
+ (conc (alist-ref 'host srv-pkt) ":"
+ (alist-ref 'port srv-pkt)))
+
+(define (server-ready? uconn host-port key) ;; server-address is host:port
+ (let* ((params `((cmd . ping)(key . ,key)))
+ (data `((cmd . ping)
+ (key . ,key)
+ (params . ,params))) ;; I don't get it.
+ (res (send-receive uconn host-port 'ping data)))
+ (if (eq? res 'ping-ack) ;; yep, likely it is who we want on the other end
+ res
+ #f)))
+;; (begin (debug:print-info 0 *default-log-port* "server-ready? => "res) #f))))
+
+; from the pkts return servers associated with dbpath
+;; NOTE: Only one can be alive - have to check on each
+;; in the list of pkts returned
+;;
+(define (get-viable-servers serv-pkts dbpath)
+ (let loop ((tail serv-pkts)
+ (res '()))
+ (if (null? tail)
+ res ;; NOTE: sort by age so oldest is considered first
+ (let* ((spkt (car tail)))
+ (loop (cdr tail)
+ (if (equal? dbpath (alist-ref 'dbpath spkt))
+ (cons spkt res)
+ res))))))
+
+(define (remove-pkts-if-not-alive uconn serv-pkts)
+ (filter (lambda (pkt)
+ (let* ((host (alist-ref 'host pkt))
+ (port (alist-ref 'port pkt))
+ (host-port (conc host":"port))
+ (key (alist-ref 'servkey pkt))
+ (pktz (alist-ref 'Z pkt))
+ (res (server-ready? uconn host-port key)))
+ (if res
+ res
+ (let* ((pktsdir (get-pkts-dir *toppath*))
+ (pktpath (conc pktsdir"/"pktz".pkt")))
+ (debug:print 0 *default-log-port* "WARNING: pkt with no server "pktpath)
+ (delete-file* pktpath)
+ #f))))
+ serv-pkts))
+
+;; from viable servers get one that is alive and ready
+;;
+(define (get-the-server uconn apath serv-pkts)
+ (let loop ((tail serv-pkts))
+ (if (null? tail)
+ #f
+ (let* ((spkt (car tail))
+ (host (alist-ref 'ipaddr spkt))
+ (port (alist-ref 'port spkt))
+ (host-port (conc host":"port))
+ (dbpth (alist-ref 'dbpath spkt))
+ (srvkey (alist-ref 'Z spkt)) ;; (alist-ref 'srvkey spkt))
+ (addr (server-address spkt)))
+ (if (server-ready? uconn host-port srvkey)
+ spkt
+ (loop (cdr tail)))))))
+
+;; am I the "first" in line server? I.e. my D card is smallest
+;; use Z card as tie breaker
+;;
+(define (get-best-candidate serv-pkts dbpath)
+ (if (null? serv-pkts)
+ #f
+ (let loop ((tail serv-pkts)
+ (best (car serv-pkts)))
+ (if (null? tail)
+ best
+ (let* ((candidate (car tail))
+ (candidate-bd (string->number (alist-ref 'D candidate)))
+ (best-bd (string->number (alist-ref 'D best)))
+ ;; bigger number is younger
+ (candidate-z (alist-ref 'Z candidate))
+ (best-z (alist-ref 'Z best))
+ (new-best (cond
+ ((> best-bd candidate-bd) ;; best is younger than candidate
+ candidate)
+ ((< best-bd candidate-bd) ;; candidate is younger than best
+ best)
+ (else
+ (if (string>=? best-z candidate-z)
+ best
+ candidate))))) ;; use Z card as tie breaker
+ (if (null? tail)
+ new-best
+ (loop (cdr tail) new-best)))))))
+
+;;======================================================================
+;; END NEW SERVER METHOD
+;;======================================================================
+
+;; sdat must be defined and the host and port set and the same as previous
+;;
+(define (host-port-is-stable? sdat old-host old-port)
+ (and sdat
+ (let ((new-host (servdat-host sdat))
+ (new-port (servdat-port sdat)))
+ (and new-host
+ new-port
+ (equal? new-host old-host)
+ (equal? new-port old-port)))))
+
+;; if .db/main.db check the pkts
+;;
+(define (rmt:wait-for-server pkts-dir db-file server-key)
+ (let* ((sdat *db-serv-info*))
+ (let loop ((start-time (current-milliseconds))
+ (changed #t)
+ (last-sdat "not this")
+ (last-host #f)
+ (last-port #f))
+ (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 *db-serv-info*)
+ (mutex-unlock! *heartbeat-mutex*)
+ (if (and sdat
+ (not changed)
+ (>= (- (current-milliseconds) start-time) 100))
+ (let* ((uconn (servdat-uconn sdat)))
+ (servdat-status-set! sdat 'iface-stable)
+ (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
+
+ ;; TODO:
+ ;; 1. change sdat to stuct
+ ;; 2. add uuid to struct
+ ;; 3. update uuid in sdat here
+ ;;
+ (servdat-uuid-set! sdat
+ (register-server
+ pkts-dir *srvpktspec*
+ (get-host-name)
+ (servdat-port sdat) server-key
+ (servdat-host sdat) db-file))
+ ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key
+ ;; 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))
+ (alive (remove-pkts-if-not-alive uconn viables))
+ (best-srv (get-best-candidate alive db-file))
+ (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f))
+ (i-am-srv (equal? best-srv-key server-key))
+ (delete-pkt (lambda ()
+ (let* ((pktfile (conc (get-pkts-dir *toppath*)
+ "/" (servdat-uuid *db-serv-info*)
+ ".pkt")))
+ (debug:print-info 0 *default-log-port* "Attempting to remove bogus pkt file "pktfile)
+ (delete-file* pktfile))))) ;; remove immediately instead of waiting for on-exit
+ (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key", i-am-srv: "i-am-srv)
+ ;; am I the best-srv, compare server-keys to know
+ (if i-am-srv
+ (if (get-lock-db sdat db-file (servdat-host sdat)(servdat-port sdat)) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id)
+ (begin
+ (debug:print-info 0 *default-log-port* "I'm the server!")
+ (servdat-dbfile-set! sdat db-file)
+ (servdat-status-set! sdat 'db-locked))
+ (begin
+ (debug:print-info 0 *default-log-port* "I'm not the server, exiting.")
+ (bdat-time-to-exit-set! *bdat* #t)
+ (delete-pkt)
+ (thread-sleep! 0.2)
+ (exit)))
+ (begin
+ (debug:print-info 0 *default-log-port*
+ "Keys do not match "best-srv-key", "server-key", exiting.")
+ (bdat-time-to-exit-set! *bdat* #t)
+ (delete-pkt)
+ (thread-sleep! 0.2)
+ (exit)))
+ sdat))
+ (begin ;; sdat not yet contains server info
+ (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
+ (thread-sleep! 0.1)
+ (if (> (- (current-milliseconds) start-time) 120000) ;; been waiting for two minutes
+ (begin
+ (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
+ (exit))
+ (loop start-time
+ (not (host-port-is-stable? sdat last-host last-port))
+ sdat
+ (servdat-host sdat)
+ (servdat-port sdat)))))))))
+
+(define (rmt:register-server sinfo apath iface port server-key dbname)
+ (servdat-conns sinfo) ;; just checking types
+ (rmt:open-main-connection sinfo apath) ;; we need a channel to main.db
+ (rmt:send-receive-real sinfo 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 (rmt:get-count-servers sinfo apath)
+ (servdat-conns sinfo) ;; just checking types
+ (rmt:open-main-connection sinfo apath) ;; we need a channel to main.db
+ (rmt:send-receive-real sinfo apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'get-count-servers `(,apath)))
+
+(define (rmt:get-servers-info apath)
+ (rmt:send-receive 'get-servers-info #f `(,apath)))
+
+(define (rmt:deregister-server db-serv-info apath iface port server-key dbname)
+ (rmt:open-main-connection db-serv-info apath) ;; we need a channel to main.db
+ (rmt:send-receive db-serv-info apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'deregister-server `(,iface
+ ,port
+ ,server-key
+ ,(current-process-id)
+ ,iface
+ ,apath
+ ,dbname)))
+
+(define (rmt:wait-for-stable-interface #!optional (num-tries-allowed 100))
+ ;; wait until *db-serv-info* stops changing
+ (let* ((stime (current-seconds)))
+ (let loop ((last-host #f)
+ (last-port #f)
+ (tries 0))
+ (let* ((curr-host (and *db-serv-info* (servdat-host *db-serv-info*)))
+ (curr-port (and *db-serv-info* (servdat-port *db-serv-info*))))
+ ;; first we verify port and interface, update *db-serv-info* in need be.
+ (cond
+ ((> tries num-tries-allowed)
+ (debug:print 0 *default-log-port* "rmt:keep-running, giving up after trying for several minutes.")
+ (exit 1))
+ ((not *db-serv-info*)
+ (thread-sleep! 0.25)
+ (loop curr-host curr-port (+ tries 1)))
+ ((or (not last-host)(not last-port))
+ (debug:print 0 *default-log-port* "rmt:keep-running, still no interface, tries="tries)
+ (thread-sleep! 0.25)
+ (loop curr-host curr-port (+ tries 1)))
+ ((or (not (equal? last-host curr-host))
+ (not (equal? last-port curr-port)))
+ (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
+ (thread-sleep! 0.25)
+ (loop curr-host curr-port (+ tries 1)))
+ ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed
+ (thread-sleep! 0.5)
+ (loop curr-host curr-port (+ tries 1)))
+ (else
+ (rmt:get-signature) ;; sets *my-signature* as side effect
+ (servdat-status-set! *db-serv-info* 'interface-stable)
+ (debug:print 0 *default-log-port*
+ "SERVER STARTED: " curr-host
+ ":" curr-port
+ " AT " (current-seconds) " server signature: " *my-signature*
+ " with "(servdat-trynum *db-serv-info*)" port changes")
+ (flush-output *default-log-port*)
+ #t))))))
+
+;; run rmt:keep-running in a parallel thread to monitor that the db is being
+;; used and to shutdown after sometime if it is not.
+;;
+(define (rmt:keep-running dbname)
+ ;; 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* ((sinfo *db-serv-info*)
+ (server-start-time (current-seconds))
+ (pkts-dir (get-pkts-dir))
+ (server-key (rmt:get-signature)) ;; This servers key
+ (is-main (equal? (args:get-arg "-db") ".db/main.db"))
+ (last-access 0)
+ (server-timeout (server:expiration-timeout))
+ (shutdown-server-sequence (lambda (host port)
+ (set! *unclean-shutdown* #f) ;; Should not be needed anymore
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
+ ;; (rmt:server-shutdown host port) -- called in on-exit
+ ;; (portlogger:open-run-close portlogger:set-port port "released") called in on-exit
+ (exit)))
+ (timed-out? (lambda ()
+ (<= (+ last-access server-timeout)
+ (current-seconds)))))
+ (servdat-dbfile-set! *db-serv-info* (args:get-arg "-db"))
+ ;; main and run db servers have both got wait logic (could/should merge it)
+ (if is-main
+ (rmt:wait-for-server pkts-dir dbname server-key)
+ (rmt:wait-for-stable-interface))
+ ;; this is our forever loop
+ (let* ((iface (servdat-host *db-serv-info*))
+ (port (servdat-port *db-serv-info*))
+ (uconn (servdat-uconn *db-serv-info*)))
+ (let loop ((count 0)
+ (bad-sync-count 0)
+ (start-time (current-milliseconds)))
+ (if (and (not is-main)
+ (common:low-noise-print 60 "servdat-status"))
+ (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *db-serv-info*)))
+
+ (mutex-lock! *heartbeat-mutex*)
+ ;; set up the database handle
+ (if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
+ (let ((watchdog (bdat-watchdog *bdat*)))
+ (debug:print 0 *default-log-port* "SERVER: dbprep")
+ (db:setup dbname) ;; sets *dbstruct-db* as side effect
+ (servdat-status-set! *db-serv-info* 'db-opened)
+ ;; IFF I'm not main, call into main and register self
+ (if (not is-main)
+ (let ((res (rmt:register-server sinfo
+ *toppath* iface port
+ server-key dbname)))
+ (if res ;; we are the server
+ (servdat-status-set! *db-serv-info* 'have-interface-and-db)
+ ;; now check that the db locker is alive, clear it out if not
+ (let* ((serv-info (rmt:server-info *toppath* dbname)))
+ (match serv-info
+ ((host port servkey pid ipaddr apath dbpath)
+ (if (not (server-ready? uconn (conc host":"port) servkey))
+ (begin
+ (debug:print-info 0 *default-log-port* "Server registered but not alive. Removing and trying again.")
+ (rmt:deregister-server sinfo apath host port servkey dbpath) ;; servkey pid ipaddr apath dbpath)
+ (loop (+ count 1) bad-sync-count start-time))))
+ (else
+ (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting. Server info is: "serv-info)
+ (exit)))))))
+ (debug:print 0 *default-log-port*
+ "SERVER: running, db "dbname" opened, megatest version: "
+ (common:get-full-version))
+ ))
+
+ (db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t)
+
+ (mutex-unlock! *heartbeat-mutex*)
+
+ ;; when things go wrong we don't want to be doing the various
+ ;; queries too often so we strive to run this stuff only every
+ ;; four seconds or so.
+ (let* ((sync-time (- (current-milliseconds) start-time))
+ (rem-time (quotient (- 4000 sync-time) 1000)))
+ (if (and (<= rem-time 4)
+ (> rem-time 0))
+ (thread-sleep! rem-time)))
+
+ ;; Transfer *db-last-access* to last-access to use in checking that we are still alive
+ (set! last-access *db-last-access*)
+
+ (if (< count 1) ;; 3x3 = 9 secs aprox
+ (loop (+ count 1) bad-sync-count (current-milliseconds)))
+
+ (if (common:low-noise-print 60 "dbstats")
+ (begin
+ (debug:print 0 *default-log-port* "Server stats:")
+ (db:print-current-query-stats)))
+ (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
+ (cond
+ ((not *server-run*)
+ (debug:print-info 0 *default-log-port* "*server-run* set to #f. Shutting down.")
+ (shutdown-server-sequence (get-host-name) port))
+ ((timed-out?)
+ (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
+ (shutdown-server-sequence (get-host-name) port))
+ ((and *server-run*
+ (or (not (timed-out?))
+ (if is-main ;; do not exit if there are other servers (keep main open until all others gone)
+ (> (rmt:get-count-servers sinfo *toppath*) 1)
+ #f)))
+ (if (common:low-noise-print 120 "server continuing")
+ (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
+ (loop 0 bad-sync-count (current-milliseconds)))
+ (else
+ (set! *unclean-shutdown* #f)
+ (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
+ (shutdown-server-sequence (get-host-name) port)
+ #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: "
+ (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown
+ (sexpr->string 'quit))))))))))
+
+(define (rmt:get-reasonable-hostname)
+ (let* ((inhost (or (args:get-arg "-server") "-")))
+ (if (equal? inhost "-")
+ (get-host-name)
+ inhost)))
+
+;; Call this to start the actual server
+;;
+;; all routes though here end in exit ...
+;;
+;; This is the point at which servers are started
+;;
+(define (rmt:server-launch dbname)
+ (debug:print-info 0 *default-log-port* "Entered rmt:server-launch")
+ (let* ((th2 (make-thread (lambda ()
+ (debug:print-info 0 *default-log-port* "Server run thread started")
+ (rmt:run (rmt:get-reasonable-hostname)))
+ "Server run"))
+ (th3 (make-thread (lambda ()
+ (debug:print-info 0 *default-log-port* "Server monitor thread started")
+ (if (args:get-arg "-server")
+ (rmt:keep-running dbname)
+ #;(rmt:wait-for-stable-interface)))
+ "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)
+ (thread-join! th3))
+ #f)
+
+;;======================================================================
+;; S E R V E R - D I R E C T C A L L S
+;;======================================================================
+
+(define (rmt:kill-server run-id)
+ (rmt:send-receive 'kill-server #f (list run-id)))
+
+(define (rmt:start-server run-id)
+ (rmt:send-receive 'start-server #f (list run-id)))
+
+(define (rmt:server-info apath dbname)
+ (rmt:send-receive 'get-server-info #f (list apath dbname)))
+
+
+)
ADDED ulex-dual/ulex.scm
Index: ulex-dual/ulex.scm
==================================================================
--- /dev/null
+++ ulex-dual/ulex.scm
@@ -0,0 +1,352 @@
+;; ulex: Distributed sqlite3 db
+;;;
+;; Copyright (C) 2018-2021 Matt Welland
+;; Redistribution and use in source and binary forms, with or without
+;; modification, is permitted.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;; DAMAGE.
+
+;;======================================================================
+;; ABOUT:
+;; See README in the distribution at https://www.kiatoa.com/fossils/ulex
+;; NOTES:
+;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity.
+;;
+;;======================================================================
+
+(module ulex
+ *
+ #;(
+
+ ;; NOTE: looking for the handler proc - find the run-listener :)
+
+ run-listener ;; (run-listener handler-proc [port]) => uconn
+
+ ;; NOTE: handler-proc params;
+ ;; (handler-proc rem-host-port qrykey cmd params)
+
+ send-receive ;; (send-receive uconn host-port cmd data)
+
+ ;; NOTE: cmd can be any plain text symbol except for these;
+ ;; 'ping 'ack 'goodbye 'response
+
+ set-work-handler ;; (set-work-handler proc)
+
+ wait-and-close ;; (wait-and-close uconn)
+
+ ulex-listener?
+
+ ;; needed to get the interface:port that was automatically found
+ udat-port
+ udat-host-port
+
+ ;; for testing only
+ ;; pp-uconn
+
+ ;; parameters
+ work-method ;; parameter; 'threads, 'mailbox, 'limited, 'direct
+ return-method ;; parameter; 'mailbox, 'polling, 'direct
+ )
+
+(import scheme
+ chicken.base
+ chicken.file
+ chicken.io
+ chicken.time
+ chicken.condition
+ chicken.port
+ chicken.string
+ chicken.sort
+ chicken.pretty-print
+ chicken.tcp
+
+ address-info
+ mailbox
+ matchable
+ ;; queues
+ regex
+ regex-case
+ simple-exceptions
+ s11n
+ srfi-1
+ srfi-18
+ srfi-4
+ srfi-69
+ system-information
+ ;; tcp6
+ tcp-server
+ typed-records
+
+ md5
+ message-digest
+ (prefix base64 base64:)
+ z3
+ )
+
+;; udat struct, used by both caller and callee
+;; instantiated as uconn by convention
+;;
+(defstruct udat
+ ;; the listener side
+ (port #f)
+ (host-port #f) ;; my host:port
+ (socket #f)
+ ;; the peers
+ (peers (make-hash-table)) ;; host:port->peer
+ ;; work handling
+ (work-queue (make-mailbox))
+ (work-proc #f) ;; set by user
+ (cnum 0) ;; cookie number
+ (mboxes (make-hash-table)) ;; for the replies
+ (avail-cmboxes '()) ;; list of ( . ) for re-use
+ ;; threads
+ (numthreads 10)
+ (cmd-thread #f)
+ (work-queue-thread #f)
+ (num-threads-running 0)
+ )
+
+;;======================================================================
+;; serialization
+;; NOTE: I've had problems with read/write and s11n serialize, deserialize
+;; thus the inefficient method here
+;;======================================================================
+
+(define serializing-method (make-parameter 'complex))
+
+
+;; NOTE: Can remove the regex and base64 encoding for zmq
+(define (obj->string obj)
+ (case (serializing-method)
+ ((complex)
+ (string-substitute
+ (regexp "=") "_"
+ (base64:base64-encode
+ (z3:encode-buffer
+ (with-output-to-string
+ (lambda ()(serialize obj))))) ;; BB: serialize - this is
+ ;; what causes problems
+ ;; between different builds of
+ ;; megatest communicating.
+ ;; serialize is sensitive to
+ ;; binary image of mtest.
+ #t))
+ ((write)(with-output-to-string (lambda ()(write obj))))
+ ((s11n) (with-output-to-string (lambda ()(serialize obj))))
+ (else obj))) ;; rpc
+
+(define (string->obj msg #!key (transport 'http))
+ (case (serializing-method)
+ ((complex)
+ (handle-exceptions
+ exn
+ (begin
+ (print "ULEX ERROR: cannot translate received data \""msg"\"")
+ (print-call-chain (current-error-port))
+ msg)
+ (with-input-from-string
+ (z3:decode-buffer
+ (base64:base64-decode
+ (string-substitute
+ (regexp "_") "=" msg #t)))
+ (lambda ()(deserialize)))))
+ ((write)(with-input-from-string msg (lambda ()(read))))
+ ((s11n)(with-input-from-string msg (lambda ()(deserialize))))
+ (else msg))) ;; rpc
+
+
+;;======================================================================
+;; listener
+;;======================================================================
+
+;; is uconn a ulex connector (listener)
+;;
+(define (ulex-listener? uconn)
+ (udat? uconn))
+
+;; create a tcp listener and return a populated udat struct with
+;; my port, address, hostname, pid etc.
+;; return #f if fail to find a port to allocate.
+;;
+;; if udata-in is #f create the record
+;; if there is already a serv-listener return the udata
+;;
+(define (setup-listener uconn #!optional (port 4242))
+ (handle-exceptions
+ exn
+ (if (< port 65535)
+ (setup-listener uconn (+ port 1))
+ #f)
+ (connect-listener uconn port)))
+
+(define (connect-listener uconn port)
+ ;; (tcp-listener-socket LISTENER)(socket-name so)
+ ;; sockaddr-address, sockaddr-port, sockaddr->string
+ (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
+ (addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
+ (udat-port-set! uconn port)
+ (udat-host-port-set! uconn (conc addr":"port))
+ (udat-socket-set! uconn tlsn)
+ uconn))
+
+;; run-listener does all the work of starting a listener in a thread
+;; it then returns control
+;;
+(define (run-listener handler-proc #!optional (port-suggestion 4242))
+ (let* ((uconn (make-udat)))
+ (udat-work-proc-set! uconn handler-proc)
+ (if (setup-listener uconn port-suggestion)
+ (let* ((orig-in (current-input-port))
+ (orig-out (current-output-port)))
+ ((make-tcp-server
+ (udat-socket uconn)
+ (lambda ()
+ (let* ((rdat
+ (string->obj (read))
+ ;; (read in)
+ ;; (deserialize)
+ )
+ (resp (let ((tcp-in (current-input-port))
+ (tcp-out (current-output-port)))
+ (current-input-port orig-in)
+ (current-output-port orig-out)
+ (let ((res (do-work uconn rdat)))
+ (current-input-port tcp-in)
+ (current-output-port tcp-out)
+ res))))
+ (write (obj->string resp))
+ ;; (serialize resp)
+ ;; (write resp out)
+ )))))
+ (assert #f "ERROR: run-listener called without proper setup."))))
+
+(define (wait-and-close uconn)
+ (thread-join! (udat-cmd-thread uconn))
+ (tcp-close (udat-socket uconn)))
+
+;;========================================================================
+;; peers and connections
+;;========================================================================
+
+(define *send-mutex* (make-mutex))
+
+;; send structured data to recipient
+;;
+;; NOTE: qrykey is what was called the "cookie" previously
+;;
+;; retval tells send to expect and wait for return data (one line) and return it or time out
+;; this is for ping where we don't want to necessarily have set up our own server yet.
+;;
+(define (send-receive udata host-port cmd params)
+ (let* ((host-port-lst (string-split host-port ":"))
+ (host (car host-port-lst))
+ (port (string->number (cadr host-port-lst)))
+ (my-host-port (and udata (udat-host-port udata))) ;; remote will return to this
+ (isme (equal? host-port my-host-port)) ;; calling myself?
+ ;; dat is a self-contained work block that can be sent or handled locally
+ (dat (list `(host-port . ,my-host-port)
+ `(qrykey . qrykey)
+ `(cmd . ,cmd)
+ `(params . ,params))))
+ (cond
+ (isme (do-work udata dat)) ;; no transmission needed
+ (else
+ (handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC?
+ exn
+ (begin
+ (print "ULEX send-receive: "cmd", "params", exn="exn)
+ (message exn))
+ (begin
+ ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP
+ (let-values (((inp oup)(tcp-connect host port)))
+ (let ((res (if (and inp oup)
+ (begin
+ (write (obj->string dat) oup)
+ (close-output-port oup)
+ (string->obj (read inp)))
+ (begin
+ (print "ERROR: send called but no receiver has been setup. Please call setup first!")
+ #f))))
+ (close-input-port inp)
+ ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP
+ res)))))))) ;; res will always be 'ack unless return-method is direct
+
+;;======================================================================
+;; work queues - this is all happening on the listener side
+;;======================================================================
+
+;; move the logic to return the result somewhere else?
+;;
+(define (do-work uconn rdat)
+ ;; put this following into a do-work procedure
+ (match rdat
+ ((rem-host-port qrykey cmd params)
+ (case cmd
+ ((ping) 'ping-ack) ;; bypass calling the proc
+ (else
+ (let* ((proc (udat-work-proc uconn))
+ (start-time (current-milliseconds))
+ (result (with-output-to-port (current-error-port)
+ (lambda ()
+ (proc rem-host-port qrykey cmd params))))
+ (end-time (current-milliseconds))
+ (run-time (- end-time start-time)))
+ result))))
+ (else
+ (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))
+
+;;======================================================================
+;; misc utils
+;;======================================================================
+
+(define (pp-uconn uconn)
+ (pp (udat->alist uconn)))
+
+;;======================================================================
+;; network utilities
+;;======================================================================
+
+;; NOTE: Look at address-info egg as alternative to some of this
+
+(define (rate-ip ipaddr)
+ (regex-case ipaddr
+ ( "^127\\..*" _ 0 )
+ ( "^(10\\.0|192\\.168)\\..*" _ 1 )
+ ( else 2 ) ))
+
+;; Change this to bias for addresses with a reasonable broadcast value?
+;;
+(define (ip-pref-less? a b)
+ (> (rate-ip a) (rate-ip b)))
+
+(define (get-my-best-address)
+ (let ((all-my-addresses (get-all-ips)))
+ (cond
+ ((null? all-my-addresses)
+ (get-host-name)) ;; no interfaces?
+ ((eq? (length all-my-addresses) 1)
+ (car all-my-addresses)) ;; only one to choose from, just go with it
+ (else
+ (car (sort all-my-addresses ip-pref-less?))))))
+
+(define (get-all-ips-sorted)
+ (sort (get-all-ips) ip-pref-less?))
+
+(define (get-all-ips)
+ (map address-info-host
+ (filter (lambda (x)
+ (equal? (address-info-type x) "tcp"))
+ (address-infos (get-host-name)))))
+
+)