Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -30,11 +30,11 @@
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm subrun.scm \
portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = ftail.scm rmtmod.scm commonmod.scm
+MSRCFILES = ftail.scm rmtmod.scm commonmod.scm apimod.scm archivemod.scm clientmod.scm configfmod.scm dbmod.scm dcommonmod.scm envmod.scm ezstepsmod.scm itemsmod.scm keysmod.scm launchmod.scm odsmod.scm processmod.scm runconfigmod.scm runsmod.scm servermod.scm subrunmod.scm tasksmod.scm testsmod.scm vgmod.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
@@ -72,11 +72,12 @@
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
-mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o
+# why were the files mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o listed on this target when MOFILES are there?
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES)
csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
@@ -109,12 +110,11 @@
megatest-version.o \
ods.o \
portlogger.o \
process.o \
rmt.o \
- mofiles/rmtmod.o \
- mofiles/commonmod.o \
+ $(MOFILES) \
rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
@@ -150,25 +150,29 @@
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \
-archive.o megatest.o : db_records.scm
+archive.o megatest.o : db_records.scm migrate-fix.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
-dcommon.o : run_records.scm
+dcommon.o : run_records.scm migrate-fix.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
# for the modularized stuff
-mofiles/rmtmod.o : mofiles/commonmod.o
+mofiles/dbmod.o : mofiles/commonmod.o
+mofiles/commonmod.o : mofiles/configfmod.o
+mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o
+
+# $(MOFILES) : mofiles/commonmod.o
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
@@ -328,10 +332,11 @@
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt ftail.import.scm readline-fix.scm serialize-env dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
rm -rf share
+ rm -f *.import.scm
#======================================================================
# Make the records files
#======================================================================
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -23,115 +23,15 @@
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses tasks))
-;; allow these queries through without starting a server
-;;
-(define api:read-only-queries
- '(get-key-val-pairs
- get-var
- get-keys
- get-key-vals
- test-toplevel-num-items
- get-test-info-by-id
- get-steps-info-by-id
- get-data-info-by-id
- test-get-rundir-from-test-id
- get-count-tests-running-for-testname
- get-count-tests-running
- get-count-tests-running-in-jobgroup
- get-previous-test-run-record
- get-matching-previous-test-run-records
- test-get-logfile-info
- test-get-records-for-index-file
- get-testinfo-state-status
- test-get-top-process-pid
- test-get-paths-matching-keynames-target-new
- get-prereqs-not-met
- get-count-tests-running-for-run-id
- get-run-info
- get-run-status
- get-run-state
- get-run-stats
- get-run-times
- get-targets
- get-target
- ;; register-run
- get-tests-tags
- get-test-times
- get-tests-for-run
- get-test-id
- get-tests-for-runs-mindata
- get-tests-for-run-mindata
- get-run-name-from-id
- get-runs
- simple-get-runs
- get-num-runs
- get-runs-cnt-by-patt
- get-all-run-ids
- get-prev-run-ids
- get-run-ids-matching-target
- get-runs-by-patt
- get-steps-data
- get-steps-for-test
- read-test-data
- read-test-data*
- login
- tasks-get-last
- testmeta-get-record
- have-incompletes?
- synchash-get
- get-changed-record-ids
- get-run-record-ids
- get-not-completed-cnt))
-
-(define api:write-queries
- '(
- get-keys-write ;; dummy "write" query to force server start
-
- ;; SERVERS
- start-server
- kill-server
-
- ;; TESTS
- test-set-state-status-by-id
- delete-test-records
- delete-old-deleted-test-records
- test-set-state-status
- test-set-top-process-pid
- set-state-status-and-roll-up-items
-
- update-pass-fail-counts
- top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
-
- ;; RUNS
- register-run
- set-tests-state-status
- delete-run
- lock/unlock-run
- update-run-event_time
- mark-incomplete
- set-state-status-and-roll-up-run
- ;; STEPS
- teststep-set-status!
- delete-steps-for-test
- ;; TEST DATA
- test-data-rollup
- csv->test-data
-
- ;; MISC
- sync-inmem->db
-
- ;; TESTMETA
- testmeta-add-record
- testmeta-update-field
-
- ;; TASKS
- tasks-add
- tasks-set-state-given-param-key
- ))
+(declare (uses apimod))
+(import apimod)
+
+;; api:read-only-queries and api:execute-requests have been moved into common_records
+
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
@@ -159,11 +59,11 @@
(params (vector-ref dat 1))
(start-t (current-milliseconds))
(readonly-mode (dbr:dbstruct-read-only dbstruct))
(readonly-command (member cmd api:read-only-queries))
(writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
- (foo (begin
+ #;(foo (begin
(common:telemetry-log (conc "api-in:"(->string cmd))
payload: `((params . ,params)))
#t))
(res
@@ -329,12 +229,12 @@
(run-id (cadr params))
(realparams (cddr params)))
(db:general-call dbstruct stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
- ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
- ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
+ ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
+ ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
ADDED apimod.scm
Index: apimod.scm
==================================================================
--- /dev/null
+++ apimod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 apimod))
+(declare (uses commonmod))
+
+(module apimod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -21,10 +21,13 @@
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
@@ -132,11 +135,11 @@
(define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex)
;; move the getting of archive space down into the below block so that a single run can
;; allocate as needed should a disk fill up
;;
(let* ((blockid-cache (make-hash-table))
- (tsname (common:get-testsuite-name))
+ (tsname (common:get-area-name *alldat*))
(min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
(arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
(disk-groups (make-hash-table)) ;;
(test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
(test-dirs (make-hash-table))
@@ -255,11 +258,11 @@
((bup) ;; Archive using bup
(let* ((bup-init-params (list "-d" archive-dir "init"))
(bup-index-params (append (list "-d" archive-dir "index") test-paths))
(bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
(conc "-" compress) ;; or (conc "--compress=" compress)
- "-n" (conc (common:get-testsuite-name) "-" run-id)
+ "-n" (conc (common:get-area-name *alldat*) "-" run-id)
(conc "--strip-path=" test-base) ;; if we push to the directory do we need this?
)
test-paths)))
(if (not (common:file-exists? (conc archive-dir "/HEAD")))
(begin
@@ -343,11 +346,11 @@
(archive-block-id (db:test-get-archived test-dat))
(archive-block-info (rmt:test-get-archive-block-info archive-block-id))
(archive-path (if (vector? archive-block-info)
(vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
#f)) ;; no archive found?
- (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
+ (archive-internal-path (conc (common:get-area-name *alldat*) "-" run-id "/latest/" test-partial-path)))
;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
;;
(if (and (not toplevel/children) ;; special handling needed for toplevel with children
prev-test-physical-path
ADDED archivemod.scm
Index: archivemod.scm
==================================================================
--- /dev/null
+++ archivemod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 archivemod))
+(declare (uses commonmod))
+
+(module archivemod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -27,10 +27,13 @@
(declare (unit client))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+(declare (uses commonmod))
+(import commonmod)
+
(include "common_records.scm")
(include "db_records.scm")
;; client:get-signature
@@ -45,21 +48,17 @@
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
(define (client:connect iface port)
- (case (server:get-transport)
- ((rpc) (rpc:client-connect iface port))
- ((http) (http:client-connect iface port))
- ((zmq) (zmq:client-connect iface port))
- (else (rpc:client-connect iface port))))
+ (http:client-connect iface port))
(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
- (case (server:get-transport)
- ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
- ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
- (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
+ (client:setup-http *alldat* areapath remaining-tries: remaining-tries failed-connects: failed-connects))
+
+(set-fn 'client:setup client:setup)
+
;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios.
@@ -67,14 +66,14 @@
;; 2. We are a run tests, list runs or other interactive process and we must figure out
;; *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
;;
-;; lookup_server, need to remove *runremote* stuff
+;; lookup_server, need to remove *runremote* stuff -> replace with *alldat* for now
;;
-(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
+(define (client:setup-http runremote areapath #!key (remaining-tries 100) (failed-connects 0)) ;; (area-dat #f))
(debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
(server:start-and-wait areapath)
(if (<= remaining-tries 0)
(begin
(debug:print-error 0 *default-log-port* "failed to start or connect to server")
@@ -81,41 +80,37 @@
(exit 1))
;;
;; Alternatively here, we can get the list of candidate servers and work our way
;; through them searching for a good one.
;;
- (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath))
- (runremote (or area-dat *runremote*)))
+ (let* ((server-dat (server:get-rand-best areapath))) ;; (server:get-first-best areapath))
(if (not server-dat) ;; no server found
- (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ (client:setup-http runremote areapath remaining-tries: (- remaining-tries 1))
(let ((host (cadr server-dat))
(port (caddr server-dat)))
(debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if (and (not area-dat)
- (not *runremote*))
- (set! *runremote* (make-remote)))
(if (and host port)
(let* ((start-res (case *transport-type*
((http)(http-transport:client-connect host port))))
(ping-res (case *transport-type*
((http)(rmt:login-no-auto-client-setup start-res)))))
(if (and start-res
ping-res)
- (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
- (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
+ (begin
+ (alldat-conndat-set! runremote start-res)
(debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
start-res)
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
(case *transport-type*
((http)(http-transport:close-connections)))
- (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
+ (alldat-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
(thread-sleep! 1)
- (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ (client:setup-http runremote areapath remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
;; (server:kind-run areapath)
(server:start-and-wait areapath)
(debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
(thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
- (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))
+ (client:setup-http runremote areapath remaining-tries: (- remaining-tries 1)))))))))
ADDED clientmod.scm
Index: clientmod.scm
==================================================================
--- /dev/null
+++ clientmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 clientmod))
+(declare (uses commonmod))
+
+(module clientmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -158,11 +158,10 @@
(define *no-sync-db* #f)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
-(define *runremote* #f) ;; if set up for server communication this will hold
;; (define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *server-id* #f)
(define *server-info* #f) ;; good candidate for easily convert to non-global
(define *time-to-exit* #f)
@@ -270,21 +269,10 @@
(else "FAIL")))
(define (common:logpro-exit-code->test-status exit-code)
(status-sym->string (common:logpro-exit-code->status-sym exit-code)))
-(defstruct remote
- (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
- (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f))
- (last-server-check 0) ;; last time we checked to see if the server was alive
- (conndat #f)
- (transport *transport-type*)
- (server-timeout (server:expiration-timeout))
- (force-server #f)
- (ro-mode #f)
- (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode
-
;; launching and hosts
(defstruct host
(reachable #f)
(last-update 0)
(last-used 0)
@@ -359,13 +347,12 @@
(define (common:api-changed?)
(not (equal? (substring (->string megatest-version) 0 4)
(substring (conc (common:get-last-run-version)) 0 4))))
-
-(define (common:get-sync-lock-filepath)
- (let* ((tmp-area (common:get-db-tmp-area))
+(define (common:get-sync-lock-filepath alldat)
+ (let* ((tmp-area (common:get-db-tmp-area alldat))
(lockfile (conc tmp-area "/megatest.db.sync-lock")))
lockfile))
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
@@ -646,20 +633,10 @@
""))))
(define (common:alist-ref/default key alist default)
(or (alist-ref key alist) default))
-(define (common:low-noise-print waitval . keys)
- (let* ((key (string-intersperse (map conc keys) "-" ))
- (lasttime (hash-table-ref/default *common:denoise* key 0))
- (currtime (current-seconds)))
- (if (> (- currtime lasttime) waitval)
- (begin
- (hash-table-set! *common:denoise* key currtime)
- #t)
- #f)))
-
(define (common:get-megatest-exe)
(or (getenv "MT_MEGATEST") "megatest"))
(define (common:read-encoded-string instr)
(handle-exceptions
@@ -857,37 +834,10 @@
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
-(define (common:get-testsuite-name)
- (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
- (configf:lookup *configdat* "setup" "testsuite" )
- (getenv "MT_TESTSUITE_NAME")
- (if (string? *toppath* )
- (pathname-file *toppath*)
- #f))) ;; (pathname-file (current-directory)))))
-
-(define common:get-area-name common:get-testsuite-name)
-
-(define (common:get-db-tmp-area . junk)
- (if *db-cache-path*
- *db-cache-path*
- (if *toppath* ;; common:get-create-writeable-dir
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
- (exit 1))
- (let ((dbpath (common:get-create-writeable-dir
- (list (conc "/tmp/" (current-user-name)
- "/megatest_localdb/"
- (common:get-testsuite-name) "/"
- (string-translate *toppath* "/" ".")))))) ;; #t))))
- (set! *db-cache-path* dbpath)
- dbpath))
- #f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
@@ -996,14 +946,10 @@
(sqlite3:interrupt! db)
(sqlite3:finalize! db #t)
;; (vector-set! *task-db* 0 #f)
(set! *task-db* #f)))))
(http-client#close-all-connections!)
- ;; (if (and *runremote*
- ;; (remote-conndat *runremote*))
- ;; (begin
- ;; (http-client#close-all-connections!))) ;; for http-client
(if (not (eq? *default-log-port* (current-error-port)))
(close-output-port *default-log-port*))
(set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
(th2 (make-thread (lambda ()
(debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
@@ -1106,33 +1052,10 @@
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
-;; return first path that can be created or already exists and is writable
-;;
-(define (common:get-create-writeable-dir dirs)
- (if (null? dirs)
- #f
- (let loop ((hed (car dirs))
- (tal (cdr dirs)))
- (let ((res (or (and (directory? hed)
- (file-write-access? hed)
- hed)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
- #f)
- (create-directory hed #t)))))
- (if (and (string? res)
- (directory? res))
- res
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal))))))))
-
;; return the youngest timestamp . filename
;;
(define (common:get-youngest glob-list)
(let ((all-files (apply append
(map (lambda (patt)
@@ -2058,24 +1981,25 @@
dirpath)))
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
-(define (common:check-db-dir-space)
+(define (common:check-db-dir-space alldat)
(let* ((required (string->number
- (or (configf:lookup *configdat* "setup" "dbdir-space-required")
+ (or (and (alldat-mtconfig alldat)
+ (configf:lookup (alldat-mtconfig alldat) "setup" "dbdir-space-required"))
"100000")))
- (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
+ (dbdir (common:get-db-tmp-area alldat)) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
- (mdbspace (common:check-space-in-dir *toppath* required)))
+ (mdbspace (common:check-space-in-dir (alldat-areapath alldat) required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
;; check available space in dbdir, exit if insufficient
;;
(define (common:check-db-dir-and-exit-if-insufficient)
- (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now
+ (let* ((spacedat (car (common:check-db-dir-space *alldat*))) ;; look only at worst for now
(is-ok (car spacedat))
(dbspace (cadr spacedat))
(required (caddr spacedat))
(dbdir (cadddr spacedat)))
(if (not is-ok)
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -17,12 +17,234 @@
;; along with Megatest. If not, see .
;;
;;======================================================================
;; (use trace)
+(use typed-records)
+
+;; globals - modules that include this need these here
+(define *verbosity-cache* (make-hash-table))
+(define *verbosity* 0)
+(define *default-log-port* (current-error-port))
+(define *logging* #f)
+(define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!!
+;; (define *toppath* #f)
+(define *transport-type* 'http)
+
+(define (exec-fn fn . params)
+ (if (hash-table-exists? *functions* fn)
+ (apply (hash-table-ref *functions* fn) params)
+ (begin
+ (debug:print-error 0 "exec-fn " fn " not found")
+ #f)))
+
+(define (set-fn fn-name fn)
+ (hash-table-set! *functions* fn-name fn))
(include "altdb.scm")
+
+;; remote connection information - moved to alldat
+;;
+#;(defstruct remote
+ (hh-dat #f) ;; (exec-fn 'common:get-homehost)) ;; homehost record ( addr . hhflag )
+ (server-url #f) ;; (if *toppath* (exec-fn 'server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f))
+ (last-server-check 0) ;; last time we checked to see if the server was alive
+ (conndat #f)
+ (transport *transport-type*)
+ (server-timeout #f) ;; (exec-fn 'server:expiration-timeout))
+ (force-server #f)
+ (ro-mode #f)
+ (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode
+ (ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector
+ )
+
+;; Pulled from http-transport.scm
+
+(define (make-http-transport:server-dat)(make-vector 6))
+(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
+(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
+(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
+(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
+(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4))
+(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5))
+(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6))
+
+(define (http-transport:server-dat-make-url vec)
+ (if (and (http-transport:server-dat-get-iface vec)
+ (http-transport:server-dat-get-port vec))
+ (conc "http://"
+ (http-transport:server-dat-get-iface vec)
+ ":"
+ (http-transport:server-dat-get-port vec))
+ #f))
+
+(define (http-transport:server-dat-update-last-access vec)
+ (if (vector? vec)
+ (vector-set! vec 5 (current-seconds))
+ (begin
+ (print-call-chain (current-error-port))
+ (debug:print-error 0 *default-log-port* "call to http-transport:server-dat-update-last-access with non-vector!!"))))
+
+;;======================================================================
+;;
+;;======================================================================
+
+
+;; allow these queries through without starting a server
+;;
+(define api:read-only-queries
+ '(get-key-val-pairs
+ get-var
+ get-keys
+ get-key-vals
+ test-toplevel-num-items
+ get-test-info-by-id
+ get-steps-info-by-id
+ get-data-info-by-id
+ test-get-rundir-from-test-id
+ get-count-tests-running-for-testname
+ get-count-tests-running
+ get-count-tests-running-in-jobgroup
+ get-previous-test-run-record
+ get-matching-previous-test-run-records
+ test-get-logfile-info
+ test-get-records-for-index-file
+ get-testinfo-state-status
+ test-get-top-process-pid
+ test-get-paths-matching-keynames-target-new
+ get-prereqs-not-met
+ get-count-tests-running-for-run-id
+ get-run-info
+ get-run-status
+ get-run-state
+ get-run-stats
+ get-run-times
+ get-targets
+ get-target
+ ;; register-run
+ get-tests-tags
+ get-test-times
+ get-tests-for-run
+ get-test-id
+ get-tests-for-runs-mindata
+ get-tests-for-run-mindata
+ get-run-name-from-id
+ get-runs
+ simple-get-runs
+ get-num-runs
+ get-runs-cnt-by-patt
+ get-all-run-ids
+ get-prev-run-ids
+ get-run-ids-matching-target
+ get-runs-by-patt
+ get-steps-data
+ get-steps-for-test
+ read-test-data
+ read-test-data*
+ login
+ tasks-get-last
+ testmeta-get-record
+ have-incompletes?
+ synchash-get
+ get-changed-record-ids
+ get-run-record-ids
+ get-not-completed-cnt))
+
+(define api:write-queries
+ '(
+ get-keys-write ;; dummy "write" query to force server start
+
+ ;; SERVERS
+ start-server
+ kill-server
+
+ ;; TESTS
+ test-set-state-status-by-id
+ delete-test-records
+ delete-old-deleted-test-records
+ test-set-state-status
+ test-set-top-process-pid
+ set-state-status-and-roll-up-items
+
+ update-pass-fail-counts
+ top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
+
+ ;; RUNS
+ register-run
+ set-tests-state-status
+ delete-run
+ lock/unlock-run
+ update-run-event_time
+ mark-incomplete
+ set-state-status-and-roll-up-run
+ ;; STEPS
+ teststep-set-status!
+ delete-steps-for-test
+ ;; TEST DATA
+ test-data-rollup
+ csv->test-data
+
+ ;; MISC
+ sync-inmem->db
+
+ ;; TESTMETA
+ testmeta-add-record
+ testmeta-update-field
+
+ ;; TASKS
+ tasks-add
+ tasks-set-state-given-param-key
+ ))
+
+;;======================================================================
+;; ALLDATA
+;;======================================================================
+;;
+;; attempt to consolidate a bunch of global information into one struct to toss around
+(defstruct alldat
+ ;; misc
+ (denoise (make-hash-table))
+ (areapath #f) ;; i.e. toppath
+ (mtconfig #f)
+ (log-port #f)
+ (areadat #f) ;; i.e. runremote
+ (rmt-mutex (make-mutex))
+ (db-sync-mutex (make-mutex))
+ (db-with-db-mutex (make-mutex))
+ (read-only-queries api:read-only-queries)
+ (write-queries api:write-queries)
+ (max-api-process-requests 0)
+ (api-process-request-count 0)
+ (db-keys #f)
+
+ ;; database related
+ (tmppath #f) ;; tmp path for dbs
+
+ ;; runremote fields
+ (hh-dat #f) ;; (exec-fn 'common:get-homehost)) ;; homehost record ( addr . hhflag )
+ (server-url #f) ;; (if *toppath* (exec-fn 'server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f))
+ (last-server-check 0) ;; last time we checked to see if the server was alive
+ (conndat #f)
+ (transport *transport-type*)
+ (server-timeout #f) ;; (exec-fn 'server:expiration-timeout))
+ (force-server #f)
+ (ro-mode #f)
+ (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode
+ (ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector
+
+ ;; dbstruct
+ (tmpdb #f)
+ (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
+ (mtdb #f)
+ (refndb #f)
+ (homehost #f) ;; not used yet
+ (on-homehost #f) ;; not used yet
+ (read-only #f)
+
+ )
+
+(define *alldat* (make-alldat))
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
@@ -80,11 +302,11 @@
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
-(define (debug:calc-verbosity vstr)
+(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
(or (hash-table-ref/default *verbosity-cache* vstr #f)
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
@@ -91,12 +313,12 @@
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
- ((args:get-arg "-v") 2)
- ((args:get-arg "-q") 0)
+ (verbose 2) ;; ((args:get-arg "-v") 2)
+ (quiet 0) ;; ((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
@@ -121,29 +343,29 @@
(not (null? (lset-intersection! eq? *verbosity* n))))
((and (number? *verbosity*)
(list? n))
(member *verbosity* n))))
-(define (debug:setup)
- (let ((debugstr (or (args:get-arg "-debug")
- (getenv "MT_DEBUG_MODE"))))
- (set! *verbosity* (debug:calc-verbosity debugstr))
+(define (debug:setup dmode verbose quiet)
+ (let ((debugstr (or dmode ;; (args:get-arg "-debug")
+ (get-environment-variable "MT_DEBUG_MODE"))))
+ (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
- (if (or (args:get-arg "-debug")
- (not (getenv "MT_DEBUG_MODE")))
+ (if (or dmode ;; (args:get-arg "-debug")
+ (not (get-environment-variable "MT_DEBUG_MODE")))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
- (db:log-event (apply conc params))
+ (exec-fn 'db:log-event (apply conc params))
(apply print params)
)))))
;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
@@ -218,11 +440,11 @@
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if *logging*
- (db:log-event (apply conc params))
+ (exec-fn 'db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))))
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
@@ -235,11 +457,11 @@
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if *logging*
(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
- (db:log-event res))
+ (exec-fn 'db:log-event res))
;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
(apply print "INFO: (" n ") " params) ;; res)
)))))
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -17,16 +17,96 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit commonmod))
+(declare (uses configfmod))
(module commonmod
*
(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 ports srfi-1 files format)
+
+(import configfmod)
+(include "common_records.scm")
+
+(define (db:dbdat-get-path dbdat)
+ (if (pair? dbdat)
+ (cdr dbdat)
+ #f))
+
+(define (common:get-area-name alldat #!optional (areapath-in #f))
+ (let* ((configdat (alldat-mtconfig alldat))
+ (areapath (or (alldat-areapath alldat)
+ (get-environment-variable "MT_RUN_AREA_HOME")
+ areapath-in)))
+ (or (configf:lookup configdat "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
+ (configf:lookup configdat "setup" "testsuite" )
+ (get-environment-variable "MT_TESTSUITENAME") ;; circulat?
+ (if (string? areapath )
+ (pathname-file areapath)
+ #f)))) ;; (pathname-file (current-directory)))))
+
+;; return first path that can be created or already exists and is writable
+;;
+(define (common:get-create-writeable-dir dirs)
+ (if (null? dirs)
+ #f
+ (let loop ((hed (car dirs))
+ (tal (cdr dirs)))
+ (let ((res (or (and (directory? hed)
+ (file-write-access? hed)
+ hed)
+ (handle-exceptions
+ exn
+ (begin
+ ;; TODO add print of exception here
+ ;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
+ #f)
+ (create-directory hed #t)))))
+ (if (and (string? res)
+ (directory? res))
+ res
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal))))))))
+
+;; (define common:get-area-name common:get-area-name)
+
+(define (common:get-db-tmp-area alldat)
+ (let* ((dbdir #f)
+ (log-port (alldat-log-port alldat)))
+ (if (alldat-tmppath alldat)
+ (alldat-tmppath alldat)
+ (if (alldat-areapath alldat) ;; common:get-create-writeable-dir
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (print ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-error 0 log-port "Couldn't create path to " dbdir)
+ (exit 1))
+ (let ((dbpath (common:get-create-writeable-dir
+ (list (conc "/tmp/" (current-user-name)
+ "/megatest_localdb/"
+ (common:get-area-name alldat) "/"
+ (string-translate (alldat-areapath alldat) "/" ".")))))) ;; #t))))
+ (set! dbdir dbpath)
+ (alldat-tmppath-set! alldat dbpath)
+ dbpath))
+ #f))))
+
+(define (common:low-noise-print alldat waitval . keys)
+ (let* ((key (string-intersperse (map conc keys) "-" ))
+ (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
+ (currtime (current-seconds)))
+ (if (> (- currtime lasttime) waitval)
+ (begin
+ (hash-table-set! (alldat-denoise alldat) key currtime)
+ #t)
+ #f)))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,48 @@
+;;======================================================================
+;; Copyright 2019, 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 configfmod))
+;; (declare (uses commonmod))
+
+(module configfmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+;; (import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+(define (configf:lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
+
+
+
+)
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -36,10 +36,13 @@
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
+(declare (uses commonmod))
+(import commonmod)
+
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(include "common_records.scm")
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -34,10 +34,13 @@
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
+(declare (uses commonmod))
+(import commonmod)
+
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -35,10 +35,13 @@
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
+(declare (uses commonmod))
+(import commonmod)
+
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(include "common_records.scm")
@@ -452,12 +455,12 @@
;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
- (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
- (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree")
+ (let* ((db-path (common:get-db-tmp-area *alldat*))
+ (dbstruct #f) ;; NOT ACTUALLY USED (db:setup))
;; local: #t))
(testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -46,10 +46,17 @@
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))
+
+(declare (uses commonmod))
+(import commonmod)
+(declare (uses rmtmod))
+(import rmtmod)
+(declare (uses dbmod))
+(import dbmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
@@ -100,10 +107,16 @@
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
)
args:arg-hash
0))
+
+;; (set! *functions* dbmod#*functions*)
+;; (set! apimod#*functions* dbmod#*functions*)
+;; (set! configfmod#*functions* dbmod#*functions*)
+
+(include "migrate-fix.scm")
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
(begin
(display "Checking for MT_ vars: ")
@@ -379,12 +392,12 @@
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
- (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
- (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
+ (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area *alldat*))
+ (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area *alldat*))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
@@ -511,11 +524,11 @@
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
-(debug:setup)
+(debug:setup (args:get-arg "-debug")(args:get-arg "-v")(args:get-arg "-q"))
;; (define uidat #f)
(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1))
@@ -604,11 +617,11 @@
(dboard:rundat-last-update run-dat)))
(last-db-time (if do-not-use-db-file-timestamps
0
(dboard:rundat-last-db-time run-dat)))
(db-path (or (dboard:rundat-db-path run-dat)
- (let* ((db-dir (common:get-db-tmp-area))
+ (let* ((db-dir (common:get-db-tmp-area *alldat*))
(db-pth (conc db-dir "/megatest.db")))
(dboard:rundat-db-path-set! run-dat db-pth)
db-pth)))
(db-mod-time (common:lazy-sqlite-db-modification-time db-path))
(db-modified (>= db-mod-time last-db-time))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -38,10 +38,17 @@
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
+
+(declare (uses rmtmod))
+(import rmtmod)
+(declare (uses dbmod))
+(import dbmod)
+(declare (uses commonmod))
+(import commonmod)
(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
@@ -50,19 +57,21 @@
;;======================================================================
;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
-(defstruct dbr:dbstruct
- (tmpdb #f)
- (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
- (mtdb #f)
- (refndb #f)
- (homehost #f) ;; not used yet
- (on-homehost #f) ;; not used yet
- (read-only #f)
- ) ;; goal is to converge on one struct for an area but for now it is too confusing
+;; MERGED INTO *alldat*
+;;
+;; (defstruct dbr:dbstruct
+;; (tmpdb #f)
+;; (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
+;; (mtdb #f)
+;; (refndb #f)
+;; (homehost #f) ;; not used yet
+;; (on-homehost #f) ;; not used yet
+;; (read-only #f)
+;; ) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
@@ -95,37 +104,10 @@
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
-;; Get/open a database
-;; if run-id => get run specific db
-;; if #f => get main db
-;; if db already open - return inmem
-;; if db not open, open inmem, rundb and sync then return inmem
-;; inuse gets set automatically for rundb's
-;;
-(define (db:get-db dbstruct) ;; run-id)
- (if (stack? (dbr:dbstruct-dbstack dbstruct))
- (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
- (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
- ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
- newdb)
- (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
- (db:open-db dbstruct)))
-
-;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
-(define (db:dbdat-get-db dbdat)
- (if (pair? dbdat)
- (car dbdat)
- dbdat))
-
-(define (db:dbdat-get-path dbdat)
- (if (pair? dbdat)
- (cdr dbdat)
- #f))
-
;; mod-read:
;; 'mod modified data
;; 'read read data
;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
;;
@@ -137,41 +119,10 @@
;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
;; (dbr:dbstruct-inuse-set! dbstruct #f)
;; (mutex-unlock! *rundb-mutex*))))
-;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
-;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
-;;
-(define (db:with-db dbstruct run-id r/w proc . params)
- (let* ((have-struct (dbr:dbstruct? dbstruct))
- (dbdat (if have-struct
- (db:get-db dbstruct)
- #f))
- (db (if have-struct
- (db:dbdat-get-db dbdat)
- dbstruct))
- (use-mutex (> *api-process-request-count* 25)))
- (if (and use-mutex
- (common:low-noise-print 120 "over-50-parallel-api-requests"))
- (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
- (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
- (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
- (handle-exceptions
- exn
- (begin
- (print-call-chain (current-error-port))
- (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
- ;; there is no recovering at this time. exit
- (exit 50))
- (if use-mutex (mutex-lock! *db-with-db-mutex*))
- (let ((res (apply proc db params)))
- (if use-mutex (mutex-unlock! *db-with-db-mutex*))
- ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
- (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
- res))))
-
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
;; (define (db:get-filedb dbstruct run-id)
@@ -197,11 +148,11 @@
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
-(define db:dbfile-path common:get-db-tmp-area)
+;; (define db:dbfile-path common:get-db-tmp-area)
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
@@ -277,105 +228,19 @@
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
-;; This routine creates the db if not already present. It is only called if the db is not already opened
-;;
-(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
- (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
- (if (stack? tmpdb-stack)
- (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
- (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
- (dbpath (db:dbfile-path )) ;; path to tmp db area
- (dbexists (common:file-exists? dbpath))
- (tmpdbfname (conc dbpath "/megatest.db"))
- (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
- (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
-
- (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
- (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
- (mtdb (db:open-megatest-db))
- (mtdbpath (db:dbdat-get-path mtdb))
- (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
- (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
- (write-access (file-write-access? mtdbpath))
- ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime
- ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
- ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
- ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))
- ;(fmt (file-modification-time tmpdbfname))
- (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
-
- (when write-access
- (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
- (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))
-
- ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
- ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
- (if (and dbexists (not write-access))
- (begin
- (set! *db-write-access* #f)
- (dbr:dbstruct-read-only-set! dbstruct #t)))
- (dbr:dbstruct-mtdb-set! dbstruct mtdb)
- (dbr:dbstruct-tmpdb-set! dbstruct tmpdb)
- (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
- (dbr:dbstruct-refndb-set! dbstruct refndb)
- ;; (mutex-unlock! *rundb-mutex*)
- (if (and (or (not dbfexists)
- (and modtimedelta
- (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
- do-sync)
- (begin
- (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
- (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
- ;touch tmp db to avoid wal mode wierdness
- (set! (file-modification-time tmpdbfname) (current-seconds))
- (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
- )
- (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
- ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
- tmpdb))))
-
(define (db:get-last-update-time db)
-; (db:with-db
-; dbstruct #f #f
-; (lambda (db)
- (let ((last-update-time #f))
- (sqlite3:for-each-row
- (lambda (lup)
- (set! last-update-time lup))
- db
- "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
- last-update-time))
-;))
-
-;; Make the dbstruct, setup up auxillary db's and call for main db at least once
-;;
-;; called in http-transport and replicated in rmt.scm for *local* access.
-;;
-(define (db:setup do-sync #!key (areapath #f))
- ;;
- (cond
- (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
- (else ;;(common:on-homehost?)
- (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
- (let* ((dbstruct (make-dbr:dbstruct)))
- (when (not *toppath*)
- (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
- (launch:setup areapath: areapath))
- (debug:print-info 13 *default-log-port* "Begin db:open-db")
- (db:open-db dbstruct areapath: areapath do-sync: do-sync)
- (debug:print-info 13 *default-log-port* "Done db:open-db")
- (set! *dbstruct-db* dbstruct)
- ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
- dbstruct))))
- ;; (else
- ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
- ;; (exit 1))))
+ (let ((last-update-time #f))
+ (sqlite3:for-each-row
+ (lambda (lup)
+ (set! last-update-time lup))
+ db
+ "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
+ last-update-time))
;; Open the classic megatest.db file (defaults to open in toppath)
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
@@ -462,93 +327,10 @@
;; (handler (make-busy-timeout 3600)))
;; (sqlite3:set-busy-handler! db handler)
;; (db:initialize-run-id-db db)
;; (cons db #f)))
-;; just tests, test_steps and test_data tables
-(define db:sync-tests-only
- (list
- ;; (list "strs"
- ;; '("id" #f)
- ;; '("str" #f))
- (list "tests"
- '("id" #f)
- '("run_id" #f)
- '("testname" #f)
- '("host" #f)
- '("cpuload" #f)
- '("diskfree" #f)
- '("uname" #f)
- '("rundir" #f)
- '("shortdir" #f)
- '("item_path" #f)
- '("state" #f)
- '("status" #f)
- '("attemptnum" #f)
- '("final_logf" #f)
- '("logdat" #f)
- '("run_duration" #f)
- '("comment" #f)
- '("event_time" #f)
- '("fail_count" #f)
- '("pass_count" #f)
- '("archived" #f)
- '("last_update" #f))
- (list "test_steps"
- '("id" #f)
- '("test_id" #f)
- '("stepname" #f)
- '("state" #f)
- '("status" #f)
- '("event_time" #f)
- '("comment" #f)
- '("logfile" #f)
- '("last_update" #f))
- (list "test_data"
- '("id" #f)
- '("test_id" #f)
- '("category" #f)
- '("variable" #f)
- '("value" #f)
- '("expected" #f)
- '("tol" #f)
- '("units" #f)
- '("comment" #f)
- '("status" #f)
- '("type" #f)
- '("last_update" #f))))
-
-;; needs db to get keys, this is for syncing all tables
-;;
-(define (db:sync-main-list dbstruct)
- (let ((keys (db:get-keys dbstruct)))
- (list
- (list "keys"
- '("id" #f)
- '("fieldname" #f)
- '("fieldtype" #f))
- (list "metadat" '("var" #f) '("val" #f))
- (append (list "runs"
- '("id" #f))
- (map (lambda (k)(list k #f))
- (append keys
- (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
- (list "test_meta"
- '("id" #f)
- '("testname" #f)
- '("owner" #f)
- '("description" #f)
- '("reviewed" #f)
- '("iterated" #f)
- '("avg_runtime" #f)
- '("avg_disk" #f)
- '("tags" #f)
- '("jobgroup" #f)))))
-
-(define (db:sync-all-tables-list dbstruct)
- (append (db:sync-main-list dbstruct)
- db:sync-tests-only))
;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
(let* ((dbpath (db:dbdat-get-path dbdat))
@@ -566,258 +348,11 @@
(system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
(system (conc "rm -f " dbdir "/" fnamejnl))))
;; attempt to recreate database
(system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
-;; return #f to indicate the dbdat should be closed/reopened
-;; else return dbdat
-;;
-(define (db:repair-db dbdat #!key (numtries 1))
- (let* ((dbpath (db:dbdat-get-path dbdat))
- (dbdir (pathname-directory dbpath))
- (fname (pathname-strip-directory dbpath)))
- (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
- (cond
- ((not (file-write-access? dbdir))
- (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
- #f)
-
- ;; handle special cases, megatest.db and monitor.db
- ;;
- ;; NOPE: apply this same approach to all db files
- ;;
- (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
- (handle-exceptions
- exn
- (begin
- ;; (db:move-and-recreate-db dbdat)
- (if (> numtries 0)
- (db:repair-db dbdat numtries: (- numtries 1))
- #f)
- (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
- (debug:print 0 *default-log-port*
- " check the following:\n"
- " 1. full directories, look in ~/ /tmp and " dbdir "\n"
- " 2. write access to " dbdir "\n\n"
- " if the automatic recovery failed you may be able to recover data by doing \""
- (if (member fname '("megatest.db" "monitor.db"))
- "megatest -cleanup-db"
- "megatest -import-megatest.db;megatest -cleanup-db")
- "\"\n")
- (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
- )
- ;; test read/write access to the database
- (let ((db (sqlite3:open-database dbpath)))
- (cond
- ((equal? fname "megatest.db")
- (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
- ((equal? fname "main.db")
- (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
- ((string-match "\\d.db" fname)
- (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
- ((equal? fname "monitor.db")
- (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
- (else
- (sqlite3:execute db "vacuum;")))
-
- (finalize! db)
- #t))))))
-
-;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
-;; db's are dbdat's
-;;
-;; if last-update specified ("field-name" . time-in-seconds)
-;; then sync only records where field-name >= time-in-seconds
-;; IFF field-name exists
-;;
-(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
- (for-each (lambda (dbdat)
- (let ((dbpath (db:dbdat-get-path dbdat)))
- (debug:print 0 *default-log-port* " dbpath: " dbpath)
- (if (not (db:repair-db dbdat))
- (begin
- (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
- (exit)))))
- (cons todb slave-dbs))
-
- 0)
- ;; this is the work to be done
- (cond
- ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
- -1)
- ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
- -2)
- ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
- (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
- -3)
- ((not (sqlite3:database? (db:dbdat-get-db todb)))
- (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
- -4)
-
- ((not (file-write-access? (db:dbdat-get-path todb)))
- (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
- -5)
- ((not (null? (let ((readonly-slave-dbs
- (filter
- (lambda (dbdat)
- (not (file-write-access? (db:dbdat-get-path todb))))
- slave-dbs)))
- (for-each
- (lambda (bad-dbdat)
- (debug:print-error
- 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
- readonly-slave-dbs)
- readonly-slave-dbs))) -6)
- (else
- (let ((stmts (make-hash-table)) ;; table-field => stmt
- (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
- (numrecs (make-hash-table))
- (start-time (current-milliseconds))
- (tot-count 0))
- (for-each ;; table
- (lambda (tabledat)
- (let* ((tablename (car tabledat))
- (fields (cdr tabledat))
- (has-last-update (member "last_update" fields))
- (use-last-update (cond
- ((and has-last-update
- (member "last_update" fields))
- #t) ;; if given a number, just use it for all fields
- ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
- ((and (pair? last-update)
- (member (car last-update) ;; last-update field name
- (map car fields))) #t)
- (last-update
- (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
- #f)
- (else
- #f)))
- (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
- (if (number? last-update)
- last-update
- (cdr last-update))
- #f))
- (last-update-field (if use-last-update
- (if (number? last-update)
- "last_update"
- (car last-update))
- #f))
- (num-fields (length fields))
- (field->num (make-hash-table))
- (num->field (apply vector (map car fields))) ;; BBHERE
- (full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
- " FROM " tablename (if use-last-update ;; apply last-update criteria
- (conc " WHERE " last-update-field " >= " last-update-value)
- "")
- ";"))
- (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
- " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
- (fromdat '())
- (fromdats '())
- (totrecords 0)
- (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
- (todat (make-hash-table))
- (count 0)
-
- (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
- )
-
- ;; set up the field->num table
- (for-each
- (lambda (field)
- (hash-table-set! field->num field count)
- (set! count (+ count 1)))
- fields)
-
- ;; read the source table
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! fromdat (cons (apply vector a b) fromdat))
- (if (> (length fromdat) batch-len)
- (begin
- (set! fromdats (cons fromdat fromdats))
- (set! fromdat '())
- (set! totrecords (+ totrecords 1)))))
- (db:dbdat-get-db fromdb)
- full-sel)
-
- ;; tack on remaining records in fromdat
- (if (not (null? fromdat))
- (set! fromdats (cons fromdat fromdats)))
-
- (if (common:low-noise-print 120 "sync-records")
- (debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
-
- ;; read the target table; BBHERE
- (sqlite3:for-each-row
- (lambda (a . b)
- (hash-table-set! todat a (apply vector a b)))
- (db:dbdat-get-db todb)
- full-sel)
-
- (when (and delay-handicap (> delay-handicap 0))
- (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
- (thread-sleep! delay-handicap)
- (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
- )
-
- ;; first pass implementation, just insert all changed rows
- (for-each
- (lambda (targdb)
- (let* ((db (db:dbdat-get-db targdb))
- (stmth (sqlite3:prepare db full-ins)))
- (db:delay-if-busy targdb) ;; NO WAITING
- (for-each
- (lambda (fromdat-lst)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each ;;
- (lambda (fromrow)
- (let* ((a (vector-ref fromrow 0))
- (curr (hash-table-ref/default todat a #f))
- (same #t))
- (let loop ((i 0))
- (if (or (not curr)
- (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
- (set! same #f))
- (if (and same
- (< i (- num-fields 1)))
- (loop (+ i 1))))
- (if (not same)
- (begin
- (apply sqlite3:execute stmth (vector->list fromrow))
- (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
- fromdat-lst))
- ))
- fromdats)
- (sqlite3:finalize! stmth)))
- (append (list todb) slave-dbs))))
- tbls)
- (let* ((runtime (- (current-milliseconds) start-time))
- (should-print (or (debug:debug-mode 12)
- (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
- (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
- (for-each
- (lambda (dat)
- (let ((tblname (car dat))
- (count (cdr dat)))
- (set! tot-count (+ tot-count count))
- (if (> count 0)
- (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
- (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
- tot-count)))))
-
+
(define (db:patch-schema-rundb frundb)
;;
;; remove this some time after September 2016 (added in version v1.6031
;;
(for-each
@@ -1022,11 +557,11 @@
(if (and host pid)
(tasks:kill-server host pid))))
servers)
;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
- (delete-file* (common:get-sync-lock-filepath))
+ (delete-file* (common:get-sync-lock-filepath *alldat*))
)
;; clear out junk records
;;
((dejunk)
@@ -1930,11 +1465,11 @@
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
(define (db:open-no-sync-db)
- (let* ((dbpath (db:dbfile-path))
+ (let* ((dbpath (common:get-db-tmp-area *alldat*))
(dbname (conc dbpath "/no-sync.db"))
(db-exists (common:file-exists? dbname))
(db (sqlite3:open-database dbname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(if (not db-exists)
@@ -2006,26 +1541,10 @@
;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change
-;; why get the keys from the db? why not get from the *configdat*
-;; using keys:config-get-fields?
-
-(define (db:get-keys dbstruct)
- (if *db-keys* *db-keys*
- (let ((res '()))
- (db:with-db dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (key)
- (set! res (cons key res)))
- db
- "SELECT fieldname FROM keys ORDER BY id DESC;")))
- (set! *db-keys* res)
- res)))
-
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(if (or (null? header) (not row))
#f
(let loop ((hed (car header))
@@ -2241,11 +1760,11 @@
res))
;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
(define (db:get-changed-run-ids since-time)
- (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
+ (let* ((dbdir (common:get-db-tmp-area *alldat*)) ;; (configf:lookup *configdat* "setup" "dbdir"))
(alldbs (glob (conc dbdir "/[0-9]*.db")))
(changed (filter (lambda (dbfile)
(> (file-modification-time dbfile) since-time))
alldbs)))
(delete-duplicates
@@ -4744,6 +4263,8 @@
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
-
+;; tiresome setup for rmtmod (and other mods) goes here
+;; (set-fn 'db:dbfile-path common:get-db-tmp-area)
+(set-fn 'db:setup dbmod#db:setup)
ADDED dbmod.scm
Index: dbmod.scm
==================================================================
--- /dev/null
+++ dbmod.scm
@@ -0,0 +1,539 @@
+;;======================================================================
+;; Copyright 2019, 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 dbmod))
+(declare (uses commonmod))
+(declare (uses configfmod))
+
+(module dbmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable stack regex)
+(import commonmod)
+(import configfmod)
+(import files)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
+(define (db:dbdat-get-db dbdat)
+ (if (pair? dbdat)
+ (car dbdat)
+ dbdat))
+
+;; Make the dbstruct, setup up auxillary db's and call for main db at least once
+;;
+;; called in http-transport and replicated in rmt.scm for *local* access.
+;;
+(define (db:setup do-sync alldat #!key (areapath #f))
+ (let* ((log-port (alldat-log-port alldat)))
+ (cond
+ ((alldat-dbstack alldat) alldat) ;; already initialized
+ ((not (alldat-areapath alldat)) ;; no top path yet? Just exit
+ (debug:print-info 13 log-port "in db:setup, area-path not set; give up and exit.")
+ (exit 1))
+ (else ;;(common:on-homehost?)
+ (debug:print-info 13 log-port "db:setup entered (first time, not cached.)")
+ (debug:print-info 13 log-port "Begin db:open-db")
+ (db:open-db alldat areapath: areapath do-sync: do-sync)
+ (debug:print-info 13 log-port "Done db:open-db")
+ ;; (set! *dbstruct-db* dbstruct)
+ alldat))))
+
+;; This routine creates the db if not already present. It is only called if the db is not already opened
+;;
+(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
+ (let ((log-port (alldat-log-port alldat))
+ (tmpdb-stack (alldat-dbstack alldat))) ;; RA => Returns the first reference in alldat
+ (if (stack? tmpdb-stack)
+ (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
+ (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
+ (dbpath (common:get-db-tmp-area alldat)) ;; path to tmp db area
+ (dbexists (common:file-exists? dbpath))
+ (tmpdbfname (conc dbpath "/megatest.db"))
+ (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
+ (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
+
+ (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+ (mtdb (db:open-megatest-db))
+ (mtdbpath (db:dbdat-get-path mtdb))
+ (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
+ (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
+ (write-access (file-write-access? mtdbpath))
+
+ ;;(mtdbmodtime (if mtdbexists
+ ;;(common:lazy-sqlite-db-modification-time mtdbpath)
+ ;;#f)) ; moving this before db:open-megatest-db is
+ ;;called. if wal mode is on -WAL and -shm file get
+ ;;created with causing the tmpdbmodtime timestamp
+ ;;always greater than mtdbmodtime (tmpdbmodtime (if
+ ;;dbfexists (common:lazy-sqlite-db-modification-time
+ ;;tmpdbfname) #f))
+
+ ;;if wal mode is on -WAL and -shm file get created when
+ ;;db:open-megatest-db is called. modtimedelta will
+ ;;always be < 10 so db in tmp not get synced
+ ;;(tmpdbmodtime (if dbfexists (db:get-last-update-time
+ ;;(car tmpdb)) #f)) (fmt (file-modification-time
+ ;;tmpdbfname))
+
+ (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
+
+ (handle-exceptions
+ exn
+ (let ((call-chain (get-call-chain))
+ (msg ((condition-property-accessor 'exn 'message) exn)))
+ (debug:print 0 log-port "ERROR: attempted to drop triggers on MTRA/megatest.db but failed. Error is " msg)
+ (set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access
+ (when write-access
+ (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
+ (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")))
+
+ ;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime "
+ ;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath*
+ ;;"/megatest.db")) (debug:print-info 13 log-port
+ ;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists"
+ ;;and write-access="write-access)
+ (if (and dbexists (not write-access))
+ (begin
+ (set! *db-write-access* #f)
+ (alldat-read-only-set! alldat #t)))
+ (alldat-mtdb-set! alldat mtdb)
+ (alldat-tmpdb-set! alldat tmpdb)
+ (alldat-dbstack-set! alldat (make-stack)) ;; why a stack?
+ (stack-push! (alldat-dbstack alldat) tmpdb) ;; olddb is already a (cons db path)
+ (alldat-refndb-set! alldat refndb)
+ ;; (mutex-unlock! *rundb-mutex*)
+ (if (and (or (not dbfexists)
+ (and modtimedelta
+ (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
+ do-sync)
+ (begin
+ (debug:print 1 log-port "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
+ (db:sync-tables (db:sync-all-tables-list alldat) #f mtdb refndb tmpdb)
+ ;touch tmp db to avoid wal mode wierdness
+ (set! (file-modification-time tmpdbfname) (current-seconds))
+ (debug:print-info 13 log-port "db:sync-all-tables-list done.")
+ )
+ (debug:print 4 log-port " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
+ ;; (db:multi-db-sync alldat 'old2new)) ;; migrate data from megatest.db automatically
+ tmpdb))))
+
+;; Get/open a database
+;; if run-id => get run specific db
+;; if #f => get main db
+;; if db already open - return inmem
+;; if db not open, open inmem, rundb and sync then return inmem
+;; inuse gets set automatically for rundb's
+;;
+(define (db:get-db alldat) ;; run-id)
+ (if (stack? (alldat-dbstack alldat))
+ (if (stack-empty? (alldat-dbstack alldat))
+ (let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area alldat))))
+ ;; (stack-push! (alldat-dbstack alldat) newdb)
+ newdb)
+ (stack-pop! (alldat-dbstack alldat)))
+ (db:open-db alldat)))
+
+(define (db:sync-all-tables-list alldat)
+ (append (db:sync-main-list alldat)
+ db:sync-tests-only))
+
+;; just tests, test_steps and test_data tables
+(define db:sync-tests-only
+ (list
+ ;; (list "strs"
+ ;; '("id" #f)
+ ;; '("str" #f))
+ (list "tests"
+ '("id" #f)
+ '("run_id" #f)
+ '("testname" #f)
+ '("host" #f)
+ '("cpuload" #f)
+ '("diskfree" #f)
+ '("uname" #f)
+ '("rundir" #f)
+ '("shortdir" #f)
+ '("item_path" #f)
+ '("state" #f)
+ '("status" #f)
+ '("attemptnum" #f)
+ '("final_logf" #f)
+ '("logdat" #f)
+ '("run_duration" #f)
+ '("comment" #f)
+ '("event_time" #f)
+ '("fail_count" #f)
+ '("pass_count" #f)
+ '("archived" #f)
+ '("last_update" #f))
+ (list "test_steps"
+ '("id" #f)
+ '("test_id" #f)
+ '("stepname" #f)
+ '("state" #f)
+ '("status" #f)
+ '("event_time" #f)
+ '("comment" #f)
+ '("logfile" #f)
+ '("last_update" #f))
+ (list "test_data"
+ '("id" #f)
+ '("test_id" #f)
+ '("category" #f)
+ '("variable" #f)
+ '("value" #f)
+ '("expected" #f)
+ '("tol" #f)
+ '("units" #f)
+ '("comment" #f)
+ '("status" #f)
+ '("type" #f)
+ '("last_update" #f))))
+
+;; needs db to get keys, this is for syncing all tables
+;;
+(define (db:sync-main-list alldat)
+ (let ((keys (db:get-keys alldat)))
+ (list
+ (list "keys"
+ '("id" #f)
+ '("fieldname" #f)
+ '("fieldtype" #f))
+ (list "metadat" '("var" #f) '("val" #f))
+ (append (list "runs"
+ '("id" #f))
+ (map (lambda (k)(list k #f))
+ (append keys
+ (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
+ (list "test_meta"
+ '("id" #f)
+ '("testname" #f)
+ '("owner" #f)
+ '("description" #f)
+ '("reviewed" #f)
+ '("iterated" #f)
+ '("avg_runtime" #f)
+ '("avg_disk" #f)
+ '("tags" #f)
+ '("jobgroup" #f)))))
+
+;; why get the keys from the db? why not get from the *configdat*
+;; using keys:config-get-fields?
+
+(define (db:get-keys alldat)
+ (if (alldat-db-keys alldat)
+ (alldat-db-keys alldat)
+ (let ((res '()))
+ (db:with-db alldat #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (key)
+ (set! res (cons key res)))
+ db
+ "SELECT fieldname FROM keys ORDER BY id DESC;")))
+ (alldat-db-keys-set! alldat res)
+ res)))
+
+;; (db:with-db alldat run-id sqlite3:exec "select blah fgrom blaz;")
+;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
+;;
+(define (db:with-db alldat run-id r/w proc . params)
+ (let* ((have-struct (alldat? alldat))
+ (dbdat (if have-struct
+ (db:get-db alldat)
+ #f))
+ (db (if have-struct
+ (db:dbdat-get-db dbdat)
+ alldat))
+ (use-mutex (> (alldat-api-process-request-count alldat) 25))
+ (db-with-db-mutex (alldat-db-with-db-mutex alldat))
+ (log-port (alldat-log-port alldat)))
+ (if (and use-mutex
+ (common:low-noise-print 120 "over-50-parallel-api-requests"))
+ (debug:print-info 0 log-port (alldat-api-process-request-count alldat) " parallel api requests being processed in process " (current-process-id) ", throttling access"))
+ (if (common:low-noise-print 600 (conc "parallel-api-requests" (alldat-max-api-process-requests alldat)))
+ (debug:print-info 2 log-port "Parallel api request count: " (alldat-api-process-request-count alldat) " max parallel requests: " (alldat-max-api-process-requests alldat)))
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain (current-error-port))
+ (debug:print-error 0 log-port "sqlite3 issue in db:with-db, alldat=" alldat ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
+ ;; there is no recovering at this time. exit
+ (exit 50))
+ (if use-mutex (mutex-lock! db-with-db-mutex))
+ (let ((res (apply proc db params)))
+ (if use-mutex (mutex-unlock! db-with-db-mutex))
+ (if dbdat (stack-push! (alldat-dbstack alldat) dbdat))
+ res))))
+
+;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
+;; db's are dbdat's
+;;
+;; if last-update specified ("field-name" . time-in-seconds)
+;; then sync only records where field-name >= time-in-seconds
+;; IFF field-name exists
+;;
+(define (db:sync-tables alldat tbls last-update fromdb todb . slave-dbs)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
+ (for-each (lambda (dbdat)
+ (let ((dbpath (db:dbdat-get-path dbdat)))
+ (debug:print 0 *default-log-port* " dbpath: " dbpath)
+ (if (not (db:repair-db dbdat))
+ (begin
+ (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
+ (exit)))))
+ (cons todb slave-dbs))
+
+ 0)
+ ;; this is the work to be done
+ (cond
+ ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
+ -1)
+ ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
+ -2)
+ ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
+ (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
+ -3)
+ ((not (sqlite3:database? (db:dbdat-get-db todb)))
+ (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
+ -4)
+
+ ((not (file-write-access? (db:dbdat-get-path todb)))
+ (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
+ -5)
+ ((not (null? (let ((readonly-slave-dbs
+ (filter
+ (lambda (dbdat)
+ (not (file-write-access? (db:dbdat-get-path todb))))
+ slave-dbs)))
+ (for-each
+ (lambda (bad-dbdat)
+ (debug:print-error
+ 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
+ readonly-slave-dbs)
+ readonly-slave-dbs))) -6)
+ (else
+ (let ((stmts (make-hash-table)) ;; table-field => stmt
+ (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
+ (numrecs (make-hash-table))
+ (start-time (current-milliseconds))
+ (tot-count 0))
+ (for-each ;; table
+ (lambda (tabledat)
+ (let* ((tablename (car tabledat))
+ (fields (cdr tabledat))
+ (has-last-update (member "last_update" fields))
+ (use-last-update (cond
+ ((and has-last-update
+ (member "last_update" fields))
+ #t) ;; if given a number, just use it for all fields
+ ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
+ ((and (pair? last-update)
+ (member (car last-update) ;; last-update field name
+ (map car fields))) #t)
+ (last-update
+ (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
+ #f)
+ (else
+ #f)))
+ (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
+ (if (number? last-update)
+ last-update
+ (cdr last-update))
+ #f))
+ (last-update-field (if use-last-update
+ (if (number? last-update)
+ "last_update"
+ (car last-update))
+ #f))
+ (num-fields (length fields))
+ (field->num (make-hash-table))
+ (num->field (apply vector (map car fields))) ;; BBHERE
+ (full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
+ " FROM " tablename (if use-last-update ;; apply last-update criteria
+ (conc " WHERE " last-update-field " >= " last-update-value)
+ "")
+ ";"))
+ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
+ " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
+ (fromdat '())
+ (fromdats '())
+ (totrecords 0)
+ (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
+ (todat (make-hash-table))
+ (count 0)
+
+ (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
+ )
+
+ ;; set up the field->num table
+ (for-each
+ (lambda (field)
+ (hash-table-set! field->num field count)
+ (set! count (+ count 1)))
+ fields)
+
+ ;; read the source table
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! fromdat (cons (apply vector a b) fromdat))
+ (if (> (length fromdat) batch-len)
+ (begin
+ (set! fromdats (cons fromdat fromdats))
+ (set! fromdat '())
+ (set! totrecords (+ totrecords 1)))))
+ (db:dbdat-get-db fromdb)
+ full-sel)
+
+ ;; tack on remaining records in fromdat
+ (if (not (null? fromdat))
+ (set! fromdats (cons fromdat fromdats)))
+
+ (if (common:low-noise-print 120 "sync-records")
+ (debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
+
+ ;; read the target table; BBHERE
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (hash-table-set! todat a (apply vector a b)))
+ (db:dbdat-get-db todb)
+ full-sel)
+
+ (when (and delay-handicap (> delay-handicap 0))
+ (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
+ (thread-sleep! delay-handicap)
+ (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
+ )
+
+ ;; first pass implementation, just insert all changed rows
+ (for-each
+ (lambda (targdb)
+ (let* ((db (db:dbdat-get-db targdb))
+ (stmth (sqlite3:prepare db full-ins)))
+ (for-each
+ (lambda (fromdat-lst)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each ;;
+ (lambda (fromrow)
+ (let* ((a (vector-ref fromrow 0))
+ (curr (hash-table-ref/default todat a #f))
+ (same #t))
+ (let loop ((i 0))
+ (if (or (not curr)
+ (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
+ (set! same #f))
+ (if (and same
+ (< i (- num-fields 1)))
+ (loop (+ i 1))))
+ (if (not same)
+ (begin
+ (apply sqlite3:execute stmth (vector->list fromrow))
+ (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
+ fromdat-lst))
+ ))
+ fromdats)
+ (sqlite3:finalize! stmth)))
+ (append (list todb) slave-dbs))))
+ tbls)
+ (let* ((runtime (- (current-milliseconds) start-time))
+ (should-print (or (debug:debug-mode 12)
+ (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
+ (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
+ (for-each
+ (lambda (dat)
+ (let ((tblname (car dat))
+ (count (cdr dat)))
+ (set! tot-count (+ tot-count count))
+ (if (> count 0)
+ (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
+ (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
+ tot-count)))))
+
+;; return #f to indicate the dbdat should be closed/reopened
+;; else return dbdat
+;;
+(define (db:repair-db dbdat #!key (numtries 1))
+ (let* ((dbpath (db:dbdat-get-path dbdat))
+ (dbdir (pathname-directory dbpath))
+ (fname (pathname-strip-directory dbpath)))
+ (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
+ (cond
+ ((not (file-write-access? dbdir))
+ (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
+ #f)
+
+ ;; handle special cases, megatest.db and monitor.db
+ ;;
+ ;; NOPE: apply this same approach to all db files
+ ;;
+ (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
+ (handle-exceptions
+ exn
+ (begin
+ ;; (db:move-and-recreate-db dbdat)
+ (if (> numtries 0)
+ (db:repair-db dbdat numtries: (- numtries 1))
+ #f)
+ (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
+ (debug:print 0 *default-log-port*
+ " check the following:\n"
+ " 1. full directories, look in ~/ /tmp and " dbdir "\n"
+ " 2. write access to " dbdir "\n\n"
+ " if the automatic recovery failed you may be able to recover data by doing \""
+ (if (member fname '("megatest.db" "monitor.db"))
+ "megatest -cleanup-db"
+ "megatest -import-megatest.db;megatest -cleanup-db")
+ "\"\n")
+ (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
+ )
+ ;; test read/write access to the database
+ (let ((db (sqlite3:open-database dbpath)))
+ (cond
+ ((equal? fname "megatest.db")
+ (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
+ ((equal? fname "main.db")
+ (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
+ ((string-match "\\d.db" fname)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
+ ((equal? fname "monitor.db")
+ (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
+ (else
+ (sqlite3:execute db "vacuum;")))
+
+ (sqlite3:finalize! db)
+ #t))))))
+
+
+)
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -28,10 +28,13 @@
(declare (unit dcommon))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
+(declare (uses commonmod))
+(import commonmod)
+
;; (declare (uses synchash))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
ADDED dcommonmod.scm
Index: dcommonmod.scm
==================================================================
--- /dev/null
+++ dcommonmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 dcommonmod))
+(declare (uses commonmod))
+
+(module dcommonmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
ADDED envmod.scm
Index: envmod.scm
==================================================================
--- /dev/null
+++ envmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 envmod))
+(declare (uses commonmod))
+
+(module envmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -24,10 +24,13 @@
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
+(declare (uses commonmod))
+(import commonmod)
+
;; (declare (uses sdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
ADDED ezstepsmod.scm
Index: ezstepsmod.scm
==================================================================
--- /dev/null
+++ ezstepsmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 ezstepsmod))
+(declare (uses commonmod))
+
+(module ezstepsmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
ADDED fixpath.sh
Index: fixpath.sh
==================================================================
--- /dev/null
+++ fixpath.sh
@@ -0,0 +1,1 @@
+export PATH=$(readlink -f ./bin):$PATH
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-
-;; Copyright 2006-2012, 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 .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -32,13 +32,15 @@
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
-;; (declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
@@ -68,11 +70,11 @@
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (common:get-linktree))
- (tmp-area (common:get-db-tmp-area))
+ (tmp-area (common:get-db-tmp-area *alldat*))
(start-file (conc tmp-area "/.server-start")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
;; set some parameters for the server
(root-path (if link-tree-path
link-tree-path
@@ -240,11 +242,11 @@
(debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
(exit 1))))
(res (vector #f "uninitialized"))
(success #t)
(sparams (db:obj->string params transport: 'http))
- (runremote (or area-dat *runremote*)))
+ (areadat (or area-dat *areadat*)))
(debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
;; set up the http-client here
(max-retry-attempts 1)
;; consider all requests indempotent
(retry-request? (lambda (request)
@@ -269,12 +271,12 @@
(begin
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " msg)
(debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
(debug:print 0 *default-log-port* " call-chain: " call-chain)))
- (if runremote
- (remote-conndat-set! runremote #f))
+ (if areadat
+ (areadat-conndat-set! areadat #f))
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
;;; (signal (make-composite-condition
;;; (make-property-condition 'commfail 'message "failed to connect to server")))
@@ -316,17 +318,17 @@
(signal (make-composite-condition
(make-property-condition
'timeout
'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
-;; careful closing of connections stored in *runremote*
+;; careful closing of connections stored in *alldat*
;;
-(define (http-transport:close-connections #!key (area-dat #f))
- (let* ((runremote (or area-dat *runremote*))
- (server-dat (if runremote
- (remote-conndat runremote)
- #f))) ;; (hash-table-ref/default *runremote* run-id #f)))
+(define (http-transport:close-connections #!key (all-dat #f))
+ (let* ((alldat (or all-dat *alldat*))
+ (server-dat (if alldat
+ (alldat-conndat alldat)
+ #f))) ;; (hash-table-ref/default *areadat* run-id #f)))
(if (vector? server-dat)
(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
(handle-exceptions
exn
(begin
@@ -335,35 +337,11 @@
(close-connection! api-dat)
;;(close-idle-connections!)
#t))
#f)))
-
-(define (make-http-transport:server-dat)(make-vector 6))
-(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
-(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
-(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
-(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
-(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4))
-(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5))
-(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6))
-
-(define (http-transport:server-dat-make-url vec)
- (if (and (http-transport:server-dat-get-iface vec)
- (http-transport:server-dat-get-port vec))
- (conc "http://"
- (http-transport:server-dat-get-iface vec)
- ":"
- (http-transport:server-dat-get-port vec))
- #f))
-
-(define (http-transport:server-dat-update-last-access vec)
- (if (vector? vec)
- (vector-set! vec 5 (current-seconds))
- (begin
- (print-call-chain (current-error-port))
- (debug:print-error 0 *default-log-port* "call to http-transport:server-dat-update-last-access with non-vector!!"))))
+;; http-transport:server-dat definition moved to common_records.scm
;;
;; connect
;;
(define (http-transport:client-connect iface port)
@@ -379,11 +357,11 @@
(define (http-transport:keep-running)
;; 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* ((tmp-area (common:get-db-tmp-area))
+ (let* ((tmp-area (common:get-db-tmp-area *alldat*))
(started-file (conc tmp-area "/.server-started"))
(server-start-time (current-seconds))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
(last-sdat "not this"))
@@ -539,11 +517,11 @@
;;
;; start_server?
;;
(define (http-transport:launch)
;; check that a server start is in progress, pause or exit if so
- (let* ((tmp-area (common:get-db-tmp-area))
+ (let* ((tmp-area (common:get-db-tmp-area *alldat*))
(server-start (conc tmp-area "/.server-start"))
(server-started (conc tmp-area "/.server-started"))
(start-time (common:lazy-modification-time server-start))
(started-time (common:lazy-modification-time server-started))
(server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -21,10 +21,13 @@
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
+(declare (uses commonmod))
+(import commonmod)
+
(include "common_records.scm")
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
ADDED itemsmod.scm
Index: itemsmod.scm
==================================================================
--- /dev/null
+++ itemsmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 itemsmod))
+(declare (uses commonmod))
+
+(module itemsmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -24,10 +24,13 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit keys))
(declare (uses common))
+(declare (uses commonmod))
+(import commonmod)
+
(include "key_records.scm")
(include "common_records.scm")
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
ADDED keysmod.scm
Index: keysmod.scm
==================================================================
--- /dev/null
+++ keysmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 keysmod))
+(declare (uses commonmod))
+
+(module keysmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -30,10 +30,13 @@
(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
@@ -498,14 +501,10 @@
(work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(ezsteps (assoc/default 'ezsteps cmdinfo))
(subrun (assoc/default 'subrun cmdinfo))
- ;; (runremote (assoc/default 'runremote cmdinfo))
- ;; (transport (assoc/default 'transport cmdinfo)) ;; not used
- ;; (serverinf (assoc/default 'serverinf cmdinfo))
- ;; (port (assoc/default 'port cmdinfo))
(serverurl (assoc/default 'serverurl cmdinfo))
(homehost (assoc/default 'homehost cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target cmdinfo))
@@ -735,11 +734,11 @@
(list "MT_ITEMPATH" item-path)
(list "MT_RUNNAME" runname)
(list "MT_MEGATEST" megatest)
(list "MT_TARGET" target)
(list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
- (list "MT_TESTSUITENAME" (common:get-testsuite-name))))
+ (list "MT_TESTSUITENAME" (common:get-area-name *alldat*))))
;;(bb-check-path msg: "launch:execute post block 3")
(if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
@@ -1024,28 +1023,54 @@
(define (launch:setup-body #!key (force-reread #f) (areapath #f))
(if (and (eq? *configstatus* 'fulldata)
*toppath*
(not force-reread)) ;; no need to reprocess
*toppath* ;; return toppath
- (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here.
+ (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks
+ ;; *configdat* for
+ ;; use-cache setting.
+ ;; We do not have
+ ;; *configdat*.
+ ;; Bootstrapping problem
+ ;; here.
(toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
(target (common:args-get-target))
(sections (if target (list "default" target) #f)) ;; for runconfigs
(mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
- ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ...
+ ;; checking for null cachefiles should not be necessary,
+ ;; I was seeing error car of '(), might be a chicken bug
+ ;; or a red herring ...
(mtcachef (if (null? cachefiles)
#f
- (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
+ (car cachefiles))) ;; (and cachedir (conc
+ ;; cachedir "/"
+ ;; ".megatest.cfg-"
+ ;; megatest-version
+ ;; "-"
+ ;; megatest-fossil-hash)))
(rccachef (if (null? cachefiles)
#f
- (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
- ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
- (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
- ;;(BB> "launch:setup-body -- cachefiles="cachefiles)
+ (cdr cachefiles)))) ;; (and cachedir
+ ;; (conc cachedir "/"
+ ;; ".runconfigs.cfg-"
+ ;; megatest-version
+ ;; "-"
+ ;; megatest-fossil-hash)))
+ ;; (cancreate (and
+ ;; cachedir
+ ;; (common:file-exists?
+ ;; cachedir)(file-write-access?
+ ;; cachedir) (not
+ ;; (common:in-running-test?)))))
+ (set! *toppath* toppath) ;; This is needed when we are running
+ ;; as a test using CMDINFO as a
+ ;; datasource (BB> "launch:setup-body
+ ;; -- cachefiles="cachefiles)
(cond
- ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
+ ;; if mtcachef exists just read it, however we need to assume
+ ;; toppath is available in $MT_RUN_AREA_HOME
((and (not force-reread)
mtcachef rccachef
use-cache
(get-environment-variable "MT_RUN_AREA_HOME")
(common:file-exists? mtcachef)
@@ -1056,12 +1081,13 @@
(set! *runconfigdat* (configf:read-alist rccachef))
(set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
(set! *configstatus* 'fulldata)
(set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
*toppath*)
- ;; there are no existing cached configs, do full reads of the configs and cache them
- ;; we have all the info needed to fully process runconfigs and megatest.config
+ ;; there are no existing cached configs, do full reads of the
+ ;; configs and cache them we have all the info needed to
+ ;; fully process runconfigs and megatest.config
((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it?
mtcachef
rccachef) ;; BB- why are we doing this without asking if caching is desired?
;;(BB> "launch:setup-body -- cond branch 2")
(let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
@@ -1150,11 +1176,17 @@
"/runconfigs.config") *runconfigdat* #t sections: sections)))
(set! *configinfo* cfgdat)
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* toppath)
- (set! *configstatus* 'partial))
+ (set! *configstatus* 'partial)
+ ;; set up as many vars in *alldat* as possible here
+ (alldat-areapath-set! *alldat* toppath)
+ (alldat-log-port-set! *alldat* *default-log-port*)
+ (alldat-mtconfig-set! *alldat* *configdat*)
+
+ )
(begin
(debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
(exit 2))))))
;; COND ends here.
@@ -1185,11 +1217,11 @@
)))
(if (and *toppath*
(directory-exists? *toppath*))
(begin
(setenv "MT_RUN_AREA_HOME" *toppath*)
- (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
+ (setenv "MT_TESTSUITENAME" (common:get-area-name *alldat*)))
(begin
(debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
(set! *toppath* #f) ;; force it to be false so we return #f
#f))
@@ -1540,11 +1572,11 @@
((dboard) "../megatest")
((mtest) "../megatest")
((dashboard) "megatest")
(else exe)))))
(launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
- (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
+ (test-sig (conc (common:get-area-name *alldat*) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
(work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
@@ -1590,14 +1622,14 @@
;; (list 'serverinf *server-info*)
(list 'homehost (let* ((hhdat (common:get-homehost)))
(if hhdat
(car hhdat)
#f)))
- (list 'serverurl (if *runremote*
- (remote-server-url *runremote*)
+ (list 'serverurl (if *alldat*
+ (alldat-server-url *alldat*)
#f)) ;;
- (list 'areaname (common:get-testsuite-name))
+ (list 'areaname (common:get-area-name *alldat*))
(list 'toppath *toppath*)
(list 'work-area work-area)
(list 'test-name test-name)
(list 'runscript runscript)
(list 'run-id run-id )
ADDED launchmod.scm
Index: launchmod.scm
==================================================================
--- /dev/null
+++ launchmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 launchmod))
+(declare (uses commonmod))
+
+(module launchmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -19,10 +19,13 @@
(use (prefix sqlite3 sqlite3:) srfi-18)
(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))
+(declare (uses commonmod))
+(import commonmod)
+
;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -44,10 +44,17 @@
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
+
+(declare (uses commonmod))
+(import commonmod)
+(declare (uses rmtmod))
+(import rmtmod)
+(declare (uses dbmod))
+(import dbmod)
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
@@ -515,10 +522,16 @@
(open-output-file logpath))
(exn ()
(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
(define *didsomething* #t)
(exit 1))))
+
+;; (set! *functions* dbmod#*functions*)
+;; (set! apimod#*functions* dbmod#*functions*)
+;; (set! configfmod#*functions* dbmod#*functions*)
+
+(include "migrate-fix.scm")
;; 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?
;;
@@ -608,11 +621,11 @@
;;======================================================================
;; Misc setup stuff
;;======================================================================
-(debug:setup)
+(debug:setup (args:get-arg "-debug")(args:get-arg "-v")(args:get-arg "-q"))
(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))
@@ -2226,10 +2239,13 @@
(set! *db* dbstruct)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
+ (import dbmod)
+ (import rmtmod)
+ (import commonmod)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
ADDED migrate-fix.scm
Index: migrate-fix.scm
==================================================================
--- /dev/null
+++ migrate-fix.scm
@@ -0,0 +1,18 @@
+;; this is a good place to populate the *functions* hash with
+;; functions needed during the transition to modules
+;;
+;; NOTE: the definition in dbmod seems to "win" - make it available everywhere
+;;
+(set-fn 'client:setup client:setup)
+;; (set-fn 'db:setup db:setup)
+(set-fn 'server:expiration-timeout server:expiration-timeout)
+(set-fn 'common:get-homehost common:get-homehost)
+(set-fn 'server:check-if-running server:check-if-running)
+(set-fn 'api:execute-requests api:execute-requests)
+(set-fn 'http-transport:close-connections http-transport:close-connections )
+(set-fn 'http-transport:client-api-send-receive http-transport:client-api-send-receive)
+(set-fn 'server:kind-run server:kind-run)
+(set-fn 'server:start-and-wait server:start-and-wait)
+(set-fn 'server:check-if-running server:check-if-running)
+(set-fn 'server:ping server:ping )
+(set-fn 'common:force-server? common:force-server? )
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -28,10 +28,13 @@
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))
+(declare (uses commonmod))
+(import commonmod)
+
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -29,10 +29,13 @@
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
+(declare (uses commonmod))
+(import commonmod)
+
;; (declare (uses rmt))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
Index: ods.scm
==================================================================
--- ods.scm
+++ ods.scm
@@ -17,10 +17,13 @@
;;
(use csv-xml regex)
(declare (unit ods))
(declare (uses common))
+(declare (uses commonmod))
+(import commonmod)
+
(define ods:dirs
'("Configurations2"
"Configurations2/toolpanel"
"Configurations2/menubar"
ADDED odsmod.scm
Index: odsmod.scm
==================================================================
--- /dev/null
+++ odsmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 odsmod))
+(declare (uses commonmod))
+
+(module odsmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
ADDED oldsrc/rpc-transport.scm
Index: oldsrc/rpc-transport.scm
==================================================================
--- /dev/null
+++ oldsrc/rpc-transport.scm
@@ -0,0 +1,237 @@
+
+;; Copyright 2006-2012, 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 .
+;;
+
+(require-extension (srfi 18) extras tcp s11n rpc)
+(import (prefix rpc rpc:))
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit rpc-transport))
+
+(declare (uses common))
+(declare (uses db))
+(declare (uses tests))
+(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+;; procstr is the name of the procedure to be called as a string
+(define (rpc-transport:autoremote procstr params)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 1 *default-log-port* "Remote failed for " proc " " params)
+ (apply (eval (string->symbol procstr)) params))
+ ;; (if *runremote*
+ ;; (apply (eval (string->symbol (conc "remote:" procstr))) params)
+ (apply (eval (string->symbol procstr)) params)))
+
+;; all routes though here end in exit ...
+;;
+;; start_server?
+;;
+(define (rpc-transport:launch run-id)
+ (let* ((tdbdat (tasks:open-db)))
+ (BB> "rpc-transport:launch fired for run-id="run-id)
+ (set! *run-id* run-id)
+ (if (args:get-arg "-daemonize")
+ (daemon:ize))
+ (if (server:check-if-running run-id)
+ (begin
+ (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
+ (exit 0)))
+ (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
+ (remtries 4))
+ (if (not server-id)
+ (if (> remtries 0)
+ (begin
+ (thread-sleep! 2)
+ (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
+ (- remtries 1)))
+ (begin
+ ;; since we didn't get the server lock we are going to clean up and bail out
+ (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+ (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " rpc-transport:launch")))
+ (begin
+ (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
+ (exit))))))
+
+(define (rpc-transport:run hostn run-id server-id)
+ (debug:print 2 *default-log-port* "Attempting to start the rpc server ...")
+ ;; (trace rpc:publish-procedure!)
+
+ (rpc:publish-procedure! 'server:login server:login)
+ (rpc:publish-procedure! 'testing (lambda () "Just testing"))
+
+ (let* ((db #f)
+ (hostname (get-host-name))
+ (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
+ ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
+ (server:get-best-guess-address hostname)
+ #f)))
+ (if ipstr ipstr hostn))) ;; hostname)))
+ (start-port (open-run-close tasks:server-get-next-port tasks:open-db))
+ (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
+ (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
+ (th1 (make-thread
+ (lambda ()
+ ((rpc:make-server rpc:listener) #t))
+ "rpc:server"))
+ ;; (cute (rpc:make-server rpc:listener) "rpc:server")
+ ;; 'rpc:server))
+ (hostname (if (string=? "-" hostn)
+ (get-host-name)
+ hostn))
+ (ipaddrstr (if (string=? "-" hostn)
+ (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
+ #f))
+ (portnum (rpc:default-server-port))
+ (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
+ (tdb (tasks:open-db)))
+ (thread-start! th1)
+ (set! db *dbstruct-db*)
+ (open-run-close tasks:server-set-interface-port
+ tasks:open-db
+ server-id
+ ipaddrstr portnum)
+ (debug:print 0 *default-log-port* "Server started on " host:port)
+
+ ;; (trace rpc:publish-procedure!)
+ ;; (rpc:publish-procedure! 'server:login server:login)
+ ;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))
+
+ ;;======================================================================
+ ;; ;; end of publish-procedure section
+ ;;======================================================================
+ ;;
+ (on-exit (lambda ()
+ (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped")))
+
+ (set! *rpc:listener* rpc:listener)
+ (tasks:server-set-state! tdb server-id "running")
+ (set! *dbstruct-db* (db:setup run-id))
+ ;; if none running or if > 20 seconds since
+ ;; server last used then start shutdown
+ (let loop ((count 0))
+ (thread-sleep! 5) ;; no need to do this very often
+ (let ((numrunning -1)) ;; (db:get-count-tests-running db)))
+ (if (or (> numrunning 0)
+ (> (+ *db-last-access* 60)(current-seconds)))
+ (begin
+ (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *db-last-access*))
+ (loop (+ 1 count)))
+ (begin
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server side")
+ (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
+ (thread-sleep! 10)
+ (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+ (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
+ ))))))
+
+(define (rpc-transport:find-free-port-and-open port)
+ (handle-exceptions
+ exn
+ (begin
+ (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
+ (rpc-transport:find-free-port-and-open (+ port 1)))
+ (rpc:default-server-port port)
+ (tcp-read-timeout 240000)
+ (tcp-listen (rpc:default-server-port) 10000)))
+
+(define (rpc-transport:ping run-id host port)
+ (handle-exceptions
+ exn
+ (begin
+ (print "SERVER_NOT_FOUND")
+ (exit 1))
+ (let ((login-res ((rpc:procedure 'server:login host port) *toppath*)))
+ (if (and (list? login-res)
+ (car login-res))
+ (begin
+ (print "LOGIN_OK")
+ (exit 0))
+ (begin
+ (print "LOGIN_FAILED")
+ (exit 1))))))
+
+(define (rpc-transport:client-setup run-id #!key (remtries 10))
+ (if *runremote*
+ (begin
+ (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected")
+ #f)
+ (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
+ (if host-info
+ (let ((iface (car host-info))
+ (port (cadr host-info))
+ (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
+ (if ping-res
+ (let ((server-dat (list iface port #f #f #f)))
+ (hash-table-set! *runremote* run-id server-dat)
+ server-dat)
+ (begin
+ (server:try-running *toppath*)
+ (thread-sleep! 2)
+ (rpc-transport:client-setup run-id (- remtries 1)))))
+ (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
+ (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+ (if server-db-info
+ (let* ((iface (tasks:hostinfo-get-interface server-db-info))
+ (port (tasks:hostinfo-get-port server-db-info))
+ (server-dat (list iface port #f #f #f))
+ (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
+ (if start-res
+ (begin
+ (hash-table-set! *runremote* run-id server-dat)
+ server-dat)
+ (begin
+ (server:try-running *toppath*)
+ (thread-sleep! 2)
+ (rpc-transport:client-setup run-id (- remtries 1)))))
+ (begin
+ (server:try-running *toppath*)
+ (thread-sleep! 2)
+ (rpc-transport:client-setup run-id (- remtries 1)))))))))
+;;
+;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
+;; (if (and port
+;; (string->number port))
+;; (let ((portn (string->number port)))
+;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print-error 0 *default-log-port* "Failed to open a connection to the server at host: " host " port: " port)
+;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+;; ;; (open-run-close
+;; ;; (lambda (db . param)
+;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
+;; ;; #f)
+;; (set! *runremote* #f))
+;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
+;; ((rpc:procedure 'server:login host portn) *toppath*))
+;; (begin
+;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port)
+;; (set! *runremote* (vector host portn)))
+;; (begin
+;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port)
+;; (set! *runremote* #f)))))
+;; (debug:print-info 2 *default-log-port* "no server available")))))
+
ADDED processmod.scm
Index: processmod.scm
==================================================================
--- /dev/null
+++ processmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 processmod))
+(declare (uses commonmod))
+
+(module processmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -22,13 +22,27 @@
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(include "common_records.scm")
+
(declare (uses rmtmod))
-
(import rmtmod)
+(declare (uses commonmod))
+(import commonmod)
+
+(set-fn 'server:expiration-timeout server:expiration-timeout)
+(set-fn 'common:get-homehost common:get-homehost)
+(set-fn 'server:check-if-running server:check-if-running)
+(set-fn 'api:execute-requests api:execute-requests)
+(set-fn 'http-transport:close-connections http-transport:close-connections )
+(set-fn 'http-transport:client-api-send-receive http-transport:client-api-send-receive)
+(set-fn 'server:kind-run server:kind-run)
+(set-fn 'server:start-and-wait server:start-and-wait)
+(set-fn 'server:check-if-running server:check-if-running)
+(set-fn 'server:ping server:ping )
+(set-fn 'common:force-server? common:force-server? )
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;
@@ -38,247 +52,50 @@
;;======================================================================
;; S U P P O R T F U N C T I O N S
;;======================================================================
-;; if a server is either running or in the process of starting call client:setup
-;; else return #f to let the calling proc know that there is no server available
-;;
-(define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down.
- (let* ((runremote (or area-dat *runremote*))
- (cinfo (if (remote? runremote)
- (remote-conndat runremote)
- #f)))
- (if cinfo
- cinfo
- (if (server:check-if-running areapath)
- (client:setup areapath)
- #f))))
-
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
-;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
-;;
-(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-
- (common:telemetry-log (conc "rmt:"(->string cmd))
- payload: `((rid . ,rid)
- (params . ,params)))
-
-
- ;;DOT digraph megatest_state_status {
- ;;DOT ranksep=0;
- ;;DOT // rankdir=LR;
- ;;DOT node [shape="box"];
- ;;DOT "rmt:send-receive" -> MUTEXLOCK;
- ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
- ;; do all the prep locked under the rmt-mutex
- (mutex-lock! *rmt-mutex*)
-
- ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
- ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
- ;; 3. do the query, if on homehost use local access
- ;;
- (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
- (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
- (runremote (or area-dat
- *runremote*))
- (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
-
- ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
- ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
+;; (define *runremote* (make-remote))
+
+;; this entry point can decide based on cmd whether to dispatch to old api calls via remote or via ulex
+;;
+(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
+ (let* ((areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
+ (alldat (or area-dat
+ *alldat*)))
;; ensure we have a record for our connection for given area
- (if (not runremote) ;; can remove this one. should never get here.
+ (if (not (alldat-hh-dat alldat))
+ (begin
+ (alldat-server-timeout-set! alldat (server:expiration-timeout))
+ (alldat-hh-dat-set! alldat (common:get-homehost))
+ )) ;; new alldat will come from this on next iteration
+
+ ;; ensure we have a homehost record and mtconfig, do this here instead of in -orig
+ (if (or (not (alldat-mtconfig *alldat*))
+ (not (alldat-hh-dat alldat))
+ (not (pair? (alldat-hh-dat alldat)))) ;; not on homehost
+ (begin
+ (alldat-hh-dat-set! alldat (common:get-homehost))
+ (alldat-mtconfig-set! *alldat* *configdat*)
+ (alldat-areapath-set! *alldat* *toppath*)
+ (alldat-areadat-set! *alldat* alldat) ;; TODO: converge usage of alldat and area-dat
+ ))
+
+ (if (member cmd '(blah))
(begin
- (set! *runremote* (make-remote))
- (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
-
- ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
- ;; DOT SET_HOMEHOST -> MUTEXLOCK;
- ;; ensure we have a homehost record
- (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
- (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
- (remote-hh-dat-set! runremote (common:get-homehost)))
-
- ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
- (cond
- ;;DOT EXIT;
- ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
- ;; give up if more than 15 attempts
- ((> attemptnum 15)
- (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
- (exit 1))
-
- ;;DOT CASE2 [label="local\nreadonly\nquery"];
- ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
- ;;DOT CASE2 -> "rmt:open-qry-close-locally";
- ;; readonly mode, read request- handle it - case 2
- ((and readonly-mode
- (member cmd api:read-only-queries))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
- (rmt:open-qry-close-locally cmd 0 params)
- )
-
- ;;DOT CASE3 [label="write in\nread-only mode"];
- ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
- ;;DOT CASE3 -> "#f";
- ;; readonly mode, write request. Do nothing, return #f
- (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
-
- ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
- ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
- ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
- ;;
- ;;DOT CASE4 [label="reset\nconnection"];
- ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
- ;;DOT CASE4 -> "rmt:send-receive";
- ;; reset the connection if it has been unused too long
- ((and runremote
- (remote-conndat runremote)
- (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
- (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
- (remote-server-timeout runremote))))
- (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
- (http-transport:close-connections area-dat: runremote)
- (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
- (mutex-unlock! *rmt-mutex*)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE5 [label="local\nread"];
- ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
- ;;DOT CASE5 -> "rmt:open-qry-close-locally";
-
- ;; on homehost and this is a read
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (member cmd api:read-only-queries)) ;; this is a read
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE6 [label="init\nremote"];
- ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
- ;;DOT CASE6 -> "rmt:send-receive";
- ;; on homehost and this is a write, we already have a server, but server has died
- ((and (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote) ;; have a server
- (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- (set! *runremote* (make-remote))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE7 [label="homehost\nwrite"];
- ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
- ;;DOT CASE7 -> "rmt:open-qry-close-locally";
- ;; on homehost and this is a write, we already have a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote)) ;; have a server
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE8 [label="force\nserver"];
- ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
- ;;DOT CASE8 -> "rmt:open-qry-close-locally";
- ;; on homehost, no server contact made and this is a write, passively start a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; have homehost
- (not (remote-server-url runremote)) ;; no connection yet
- (not (member cmd api:read-only-queries))) ;; not a read-only query
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
- (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
- (if server-url
- (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
- (if (common:force-server?)
- (server:start-and-wait *toppath*)
- (server:kind-run *toppath*))))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE9 [label="force server\nnot on homehost"];
- ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
- ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
- ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
- (not (remote-conndat runremote)))
- (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
- (not (remote-conndat runremote)))) ;; and no connection
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
- (mutex-unlock! *rmt-mutex*)
- (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
- (server:start-and-wait *toppath*))
- (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
- (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
-
- ;;DOT CASE10 [label="on homehost"];
- ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
- ;;DOT CASE10 -> "rmt:open-qry-close-locally";
- ;; all set up if get this far, dispatch the query
- ((and (not (remote-force-server runremote))
- (cdr (remote-hh-dat runremote))) ;; we are on homehost
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
- (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
- ;;DOT CASE11 [label="send_receive"];
- ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
- ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
- ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
- ;; not on homehost, do server query
- (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
- ;;DOT }
+ (mutex-lock! *send-receive-mutex*)
+ (let ((ulex:conn (alldat-ulex:conn alldat)))
+ (if (not ulex:conn)(alldat-ulex:conn-set! alldat (rmtmod:setup-ulex areapath)))
+ (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat)))
+ (rmt:send-receive-orig *default-log-port* alldat *rmt-mutex* areapath *db-multi-sync-mutex*
+ cmd rid params *alldat* attemptnum: attemptnum area-dat: area-dat))))
;; bunch of small functions factored out of send-receive to make debug easier
;;
-(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
- ;; (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
- ;; (mutex-lock! *rmt-mutex*)
- (let* ((conninfo (remote-conndat runremote))
- (dat (case (remote-transport runremote)
- ((http) (condition-case ;; handling here has
- ;; caused a lot of
- ;; problems. However it
- ;; is needed to deal with
- ;; attemtped
- ;; communication to
- ;; servers that have gone
- ;; away
- (http-transport:client-api-send-receive 0 conninfo cmd params)
- ((commfail)(vector #f "communications fail"))
- ((exn)(vector #f "other fail" (print-call-chain)))))
- (else
- (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
- (exit))))
- (success (if (vector? dat) (vector-ref dat 0) #f))
- (res (if (vector? dat) (vector-ref dat 1) #f)))
- (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
- (http-transport:server-dat-update-last-access conninfo) ;; refresh access time
- (begin
- (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
- (set! conninfo #f)
- (remote-conndat-set! *runremote* #f) ;; NOTE: *runremote* is global copy of runremote. Purpose: factor out global.
- (http-transport:close-connections area-dat: runremote)))
- (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
- (mutex-unlock! *rmt-mutex*)
- (if success ;; success only tells us that the transport was
- ;; successful, have to examine the data to see if
- ;; there was a detected issue at the other end
- (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
- (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
- )))
-
;; (define (rmt:update-db-stats run-id rawcmd params duration)
;; (mutex-lock! *db-stats-mutex*)
;; (handle-exceptions
;; exn
;; (begin
@@ -331,53 +148,10 @@
(cons 'none 0))
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
-(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
- (let* ((qry-is-write (not (member cmd api:read-only-queries)))
- (db-file-path (db:dbfile-path)) ;; 0))
- (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
- (read-only (not (file-write-access? db-file-path)))
- (start (current-milliseconds))
- (resdat (if (not (and read-only qry-is-write))
- (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
- (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
- exn ;; This is an attempt to detect that situation and recover gracefully
- (begin
- (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn))
- (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
- (if (and (vector? v)
- (> (vector-length v) 1))
- (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
- newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
- (vector #t '())))) ;; we could also check that the returned types are valid
- (vector #t '())))
- (success (vector-ref resdat 0))
- (res (vector-ref resdat 1))
- (duration (- (current-milliseconds) start)))
- (if (and read-only qry-is-write)
- (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
- (if (not success)
- (if (> remretries 0)
- (begin
- (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
- (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
- (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
- (begin
- (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
- #f))
- (begin
- ;; (rmt:update-db-stats run-id cmd params duration)
- ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
- (if qry-is-write
- (let ((start-time (current-seconds)))
- (mutex-lock! *db-multi-sync-mutex*)
-/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
- (mutex-unlock! *db-multi-sync-mutex*)))))
- res))
-
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
(res (handle-exceptions
exn
#f
@@ -931,10 +705,16 @@
(rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
(define (rmt:test-get-archive-block-info archive-block-id)
(rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
-(set-functions rmt:send-receive remote-server-url-set!
- http-transport:close-connections remote-conndat-set!
- debug:print debug:print-info
- remote-ro-mode remote-ro-mode-set!
- remote-ro-mode-checked-set! remote-ro-mode-checked)
+#;(set-functions http-transport:client-api-send-receive ;; a
+ http-transport:close-connections ;; b
+ api:execute-requests ;; c
+ #f
+ client:setup ;; e
+ server:kind-run ;; f
+ server:start-and-wait ;; g
+ server:check-if-running ;; h
+ server:ping ;; i
+ common:force-server? ;; j
+ )
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -1,7 +1,7 @@
;;======================================================================
-;; Copyright 2017, Matthew Welland.
+;; Copyright 2019, 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
@@ -18,78 +18,100 @@
;;======================================================================
(declare (unit rmtmod))
(declare (uses commonmod))
+(declare (uses dbmod))
(module rmtmod
*
(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import commonmod)
-
-;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time.
-(define (rmt:send-receive . params) #f)
-(define (http-transport:close-connections . params) #f)
-;; from remote defstruct in common.scm
-(define (remote-conndat-set! . params) #f)
-(define (remote-server-url-set! . params) #f)
-(define (remote-ro-mode . params) #f)
-(define (remote-ro-mode-set! . params) #f)
-(define (remote-ro-mode-checked-set! . params) #f)
-(define (remote-ro-mode-checked . params) #f)
-(define (debug:print . params) #f)
-(define (debug:print-info . params) #f)
-
-(define (set-functions send-receive rsus
- close-connections rcs
- dbgp dbgpinfo
- ro-mode ro-mode-set
- ro-mode-checked-set ro-mode-checked
- )
- (set! rmt:send-receive send-receive)
- (set! remote-server-url-set! rsus)
- (set! http-transport:close-connections close-connections)
- (set! remote-conndat-set! rcs)
- (set! debug:print dbgp)
- (set! debug:print-info dbgpinfo)
- (set! remote-ro-mode ro-mode)
- (set! remote-ro-mode-set! ro-mode-set)
- (set! remote-ro-mode-checked-set! ro-mode-checked-set)
- (set! remote-ro-mode-checked ro-mode-checked))
-
-(define (rmtmod:calc-ro-mode runremote *toppath*)
- (if (and runremote
- (remote-ro-mode-checked runremote))
- (remote-ro-mode runremote)
- (let* ((dbfile (conc *toppath* "/megatest.db"))
- (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
- (if runremote
+(import dbmod)
+
+(use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params alldat #!key (remretries 5))
+ (let* ((ro-queries (alldat-read-only-queries alldat))
+ (qry-is-write (not (member cmd ro-queries)))
+ (db-file-path (common:get-db-tmp-area alldat)) ;; 0))
+ (dbstruct-local (exec-fn 'db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
+ (read-only (not (file-write-access? db-file-path)))
+ (start (current-milliseconds))
+ (resdat (if (not (and read-only qry-is-write))
+ (let ((v (exec-fn 'api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
+ (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
+ exn ;; This is an attempt to detect that situation and recover gracefully
+ (begin
+ (debug:print 0 log-port "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn))
+ (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
+ (if (and (vector? v)
+ (> (vector-length v) 1))
+ (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
+ newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
+ (vector #t '())))) ;; we could also check that the returned types are valid
+ (vector #t '())))
+ (success (vector-ref resdat 0))
+ (res (vector-ref resdat 1))
+ (duration (- (current-milliseconds) start)))
+ (if (and read-only qry-is-write)
+ (debug:print 0 log-port "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
+ (if (not success)
+ (if (> remretries 0)
+ (begin
+ (debug:print-error 0 log-port "local query failed. Trying again.")
+ (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
+ (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params alldat remretries: (- remretries 1)))
+ (begin
+ (debug:print-error 0 log-port "too many retries in rmt:open-qry-close-locally, giving up")
+ #f))
+ (begin
+ ;; (rmt:update-db-stats run-id cmd params duration)
+ ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
+ #;(if qry-is-write
+ (let ((start-time (current-seconds)))
+ (mutex-lock! multi-sync-mutex)
+ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
+ (mutex-unlock! multi-sync-mutex)))))
+ res))
+
+
+
+(define (rmtmod:calc-ro-mode areadat toppath)
+ (if (and areadat
+ (alldat-ro-mode-checked areadat))
+ (alldat-ro-mode areadat)
+ (let* ((dbfile (conc toppath "/megatest.db"))
+ (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or areadat to figure this out in future
+ (if areadat
(begin
- (remote-ro-mode-set! runremote ro-mode)
- (remote-ro-mode-checked-set! runremote #t)
+ (alldat-ro-mode-set! areadat ro-mode)
+ (alldat-ro-mode-checked-set! areadat #t)
ro-mode)
ro-mode))))
(define (extras-readonly-mode rmt-mutex log-port cmd params)
- (mutex-unlock! rmt-mutex)
+ ;;(mutex-unlock! rmt-mutex)
(debug:print-info 12 log-port "rmt:send-receive, case 3")
(debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
#f)
-(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
- (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
- (mutex-lock! *rmt-mutex*)
- (remote-conndat-set! runremote #f)
- (http-transport:close-connections area-dat: runremote)
- (remote-server-url-set! runremote #f)
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
- (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
-
-(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
+(define (extras-transport-failed log-port rmt-mutex attemptnum areadat areapath cmd rid params alldat)
+ (debug:print 0 log-port "WARNING: communication failed. Trying again, try num: " attemptnum)
+ ;;(mutex-lock! rmt-mutex)
+ (alldat-conndat-set! areadat #f)
+ (exec-fn 'http-transport:close-connections area-dat: areadat)
+ (alldat-server-url-set! areadat #f)
+ ;;(mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 9.1")
+ (rmt:send-receive-orig log-port areadat rmt-mutex areapath cmd rid params alldat attemptnum: (+ attemptnum 1)))
+
+(define (extras-transport-succeded log-port rmt-mutex attemptnum areadat areapath res params rid cmd alldat)
(if (and (vector? res)
(eq? (vector-length res) 2)
(eq? (vector-ref res 1) 'overloaded)) ;; since we are
;; looking at the
;; data to carry the
@@ -105,15 +127,214 @@
;; server is
;; overloaded and we
;; want to ease off
;; the queries
(let ((wait-delay (+ attemptnum (* attemptnum 10))))
- (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
- (mutex-lock! *rmt-mutex*)
- (http-transport:close-connections area-dat: runremote)
- (set! *runremote* #f) ;; force starting over
- (mutex-unlock! *rmt-mutex*)
+ (debug:print 0 log-port "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
+ ;;(mutex-lock! rmt-mutex)
+ (exec-fn 'http-transport:close-connections area-dat: areadat)
+ ;; (set! *areadat* #f) ;; force starting over
+ (alldat-server-url-set! areadat #f) ;; I am hoping this will force a redo on server connection. NOT TESTED
+ ;;(mutex-unlock! rmt-mutex)
(thread-sleep! wait-delay)
- (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
+ (rmt:send-receive-orig log-port areadat rmt-mutex areapath cmd rid params alldat attemptnum: (+ attemptnum 1)))
res)) ;; All good, return res
+
+;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
+;;
+;; add multi-sync-mutex
+;;
+(define (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
+
+ #;(common:telemetry-log (conc "rmt:"(->string cmd))
+ payload: `((rid . ,rid)
+ (params . ,params)))
+
+
+ ;; do all the prep locked under the rmt-mutex
+ ;;(mutex-lock! rmt-mutex)
+
+ ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in areadat
+ ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
+ ;; 3. do the query, if on homehost use local access
+ ;;
+ (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
+
+ (readonly-mode (rmtmod:calc-ro-mode areadat toppath)))
+
+ ;; (assert (not (pair? (alldat-hh-dat areadat))))
+
+ ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
+ (cond
+ ;; give up if more than 15 attempts
+ ((> attemptnum 15)
+ (debug:print 0 log-port "ERROR: 15 tries to start/connect to server. Giving up.")
+ (exit 1))
+
+ ;; readonly mode, read request- handle it - case 2
+ ((and readonly-mode
+ (member cmd api:read-only-queries))
+ ;; (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 2")
+ (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)
+ )
+
+ ;; readonly mode, write request. Do nothing, return #f
+ (readonly-mode (extras-readonly-mode rmt-mutex log-port cmd params))
+
+ ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+ ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+ ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+ ;;
+ ;; reset the connection if it has been unused too long
+ ((and areadat
+ (alldat-conndat areadat)
+ (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+ (+ (http-transport:server-dat-get-last-access (alldat-conndat areadat))
+ (alldat-server-timeout areadat))))
+ (debug:print-info 0 log-port "Connection to " (alldat-server-url areadat) " expired due to no accesses, forcing new connection.")
+ (exec-fn 'http-transport:close-connections area-dat: areadat)
+ (alldat-conndat-set! areadat #f) ;; invalidate the connection, thus forcing a new connection.
+ ;; (mutex-unlock! rmt-mutex)
+ (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum))
+
+
+ ;; on homehost and this is a read
+ ((and (not (alldat-force-server areadat)) ;; honor forced use of server, i.e. server NOT required
+ (pair? (alldat-hh-dat areadat))
+ (cdr (alldat-hh-dat areadat)) ;; on homehost
+ (member cmd api:read-only-queries)) ;; this is a read
+ ;; (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 5")
+ (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat))
+
+ ;; on homehost and this is a write, we already have a server, but server has died
+ ((and (cdr (alldat-hh-dat areadat)) ;; on homehost
+ (not (member cmd api:read-only-queries)) ;; this is a write
+ (alldat-server-url areadat) ;; have a server
+ (not (exec-fn 'server:ping (alldat-server-url areadat)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
+ ;; (set! *areadat* (make-remote)) ;; WARNING - broken this.
+ (alldat-force-server-set! areadat (exec-fn 'common:force-server?))
+ ;; (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 6")
+ (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum))
+
+ ;; on homehost and this is a write, we already have a server
+ ((and (not (alldat-force-server areadat)) ;; honor forced use of server, i.e. server NOT required
+ (cdr (alldat-hh-dat areadat)) ;; on homehost
+ (not (member cmd api:read-only-queries)) ;; this is a write
+ (alldat-server-url areadat)) ;; have a server
+ ;;(mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 4.1")
+ (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat))
+
+ ;; on homehost, no server contact made and this is a write, passively start a server
+ ((and (not (alldat-force-server areadat)) ;; honor forced use of server, i.e. server NOT required
+ (cdr (alldat-hh-dat areadat)) ;; have homehost
+ (not (alldat-server-url areadat)) ;; no connection yet
+ (not (member cmd api:read-only-queries))) ;; not a read-only query
+ (debug:print-info 12 log-port "rmt:send-receive, case 8")
+ (let ((server-url (exec-fn 'server:check-if-running toppath))) ;; (server:read-dotserver->url toppath))) ;; (server:check-if-running toppath))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+ (if server-url
+ (alldat-server-url-set! areadat server-url) ;; the string can be consumed by the client setup if needed
+ (if (exec-fn 'common:force-server?)
+ (exec-fn 'server:start-and-wait toppath)
+ (exec-fn 'server:kind-run toppath))))
+ (alldat-force-server-set! areadat (exec-fn 'common:force-server?))
+ ;; (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 8.1")
+ (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat))
+
+ ((or (and (alldat-force-server areadat) ;; we are forcing a server and don't yet have a connection to one
+ (not (alldat-conndat areadat)))
+ (and (not (cdr (alldat-hh-dat areadat))) ;; not on a homehost
+ (not (alldat-conndat areadat)))) ;; and no connection
+ (debug:print-info 12 log-port "rmt:send-receive, case 9, hh-dat: " (alldat-hh-dat areadat) " conndat: " (alldat-conndat areadat))
+ ;;(mutex-unlock! rmt-mutex)
+ (if (not (exec-fn 'server:check-if-running toppath)) ;; who knows, maybe one has started up?
+ (exec-fn 'server:start-and-wait toppath))
+ (alldat-conndat-set! areadat (rmt:get-connection-info areadat toppath)) ;; calls client:setup which calls client:setup-http
+ (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) ;; TODO: add back-off timeout as
+
+ ;; all set up if get this far, dispatch the query
+ ((and (not (alldat-force-server areadat))
+ (cdr (alldat-hh-dat areadat))) ;; we are on homehost
+ ;;(mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 10")
+ (rmt:open-qry-close-locally log-port multi-sync-mutex cmd (if rid rid 0) params alldat))
+
+ ;; not on homehost, do server query
+ (else (extras-case-11 log-port rmt-mutex areadat toppath cmd params attemptnum rid alldat)))))
+
+(define (extras-case-11 log-port rmt-mutex areadat areapath cmd params attemptnum rid alldat)
+ ;; (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 9")
+ ;; (mutex-lock! rmt-mutex)
+ (let* ((conninfo (alldat-conndat areadat))
+ (dat (case (alldat-transport areadat)
+ ((http) (condition-case ;; handling here has
+ ;; caused a lot of
+ ;; problems. However it
+ ;; is needed to deal with
+ ;; attemtped
+ ;; communication to
+ ;; servers that have gone
+ ;; away
+ (exec-fn 'http-transport:client-api-send-receive 0 conninfo cmd params)
+ ((commfail)(vector #f "communications fail"))
+ ((exn)(vector #f "other fail" (print-call-chain)))))
+ (else
+ (debug:print 0 log-port "ERROR: transport " (alldat-transport areadat) " not supported")
+ (exit))))
+ (success (if (vector? dat) (vector-ref dat 0) #f))
+ (res (if (vector? dat) (vector-ref dat 1) #f)))
+ (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
+ (http-transport:server-dat-update-last-access conninfo) ;; refresh access time
+ (begin
+ (debug:print 0 log-port "INFO: Should not get here! conninfo=" conninfo)
+ (set! conninfo #f)
+ (alldat-conndat-set! areadat #f) ;; NOTE: *areadat* is global copy of areadat. Purpose: factor out global.
+ (exec-fn 'http-transport:close-connections area-dat: areadat)))
+ (debug:print-info 13 log-port "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " areadat = " areadat)
+ ;; (mutex-unlock! rmt-mutex)
+ (if success ;; success only tells us that the transport was
+ ;; successful, have to examine the data to see if
+ ;; there was a detected issue at the other end
+ (extras-transport-succeded log-port rmt-mutex attemptnum areadat areapath res params rid cmd alldat)
+ (extras-transport-failed log-port rmt-mutex attemptnum areadat areapath cmd rid params alldat)
+ )))
+
+;; if a server is either running or in the process of starting call client:setup
+;; else return #f to let the calling proc know that there is no server available
+;;
+(define (rmt:get-connection-info areadat areapath #!key (area-dat #f)) ;; TODO: push areapath down.
+ (let* (;; (areadat (or area-dat areadat))
+ (cinfo (if (alldat? areadat)
+ (alldat-conndat areadat)
+ #f)))
+ (if cinfo
+ cinfo
+ (if (exec-fn 'server:check-if-running areapath)
+ (exec-fn 'client:setup areadat areapath)
+ #f))))
+
+
+
+;;======================================================================
+;; ulex and steps stuff
+;;======================================================================
+
+(define (rmtmod:setup-ulex toppath)
+ (ulex:make-area
+ dbdir: (conc toppath "/ulexdb")
+ pktsdir: (conc toppath "/pkts")
+ ))
+
+
+
+(define (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat)
+ #f)
+
+(use trace)(trace-call-sites #t)
+;; (trace member rmtmod:calc-ro-mode rmt:open-qry-close-locally)
)
DELETED rpc-transport.scm
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ /dev/null
@@ -1,237 +0,0 @@
-
-;; Copyright 2006-2012, 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 .
-;;
-
-(require-extension (srfi 18) extras tcp s11n rpc)
-(import (prefix rpc rpc:))
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit rpc-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-;; procstr is the name of the procedure to be called as a string
-(define (rpc-transport:autoremote procstr params)
- (handle-exceptions
- exn
- (begin
- (debug:print 1 *default-log-port* "Remote failed for " proc " " params)
- (apply (eval (string->symbol procstr)) params))
- ;; (if *runremote*
- ;; (apply (eval (string->symbol (conc "remote:" procstr))) params)
- (apply (eval (string->symbol procstr)) params)))
-
-;; all routes though here end in exit ...
-;;
-;; start_server?
-;;
-(define (rpc-transport:launch run-id)
- (let* ((tdbdat (tasks:open-db)))
- (BB> "rpc-transport:launch fired for run-id="run-id)
- (set! *run-id* run-id)
- (if (args:get-arg "-daemonize")
- (daemon:ize))
- (if (server:check-if-running run-id)
- (begin
- (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
- (exit 0)))
- (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
- (remtries 4))
- (if (not server-id)
- (if (> remtries 0)
- (begin
- (thread-sleep! 2)
- (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
- (- remtries 1)))
- (begin
- ;; since we didn't get the server lock we are going to clean up and bail out
- (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
- (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " rpc-transport:launch")))
- (begin
- (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
- (exit))))))
-
-(define (rpc-transport:run hostn run-id server-id)
- (debug:print 2 *default-log-port* "Attempting to start the rpc server ...")
- ;; (trace rpc:publish-procedure!)
-
- (rpc:publish-procedure! 'server:login server:login)
- (rpc:publish-procedure! 'testing (lambda () "Just testing"))
-
- (let* ((db #f)
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- (server:get-best-guess-address hostname)
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (open-run-close tasks:server-get-next-port tasks:open-db))
- (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
- (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
- (th1 (make-thread
- (lambda ()
- ((rpc:make-server rpc:listener) #t))
- "rpc:server"))
- ;; (cute (rpc:make-server rpc:listener) "rpc:server")
- ;; 'rpc:server))
- (hostname (if (string=? "-" hostn)
- (get-host-name)
- hostn))
- (ipaddrstr (if (string=? "-" hostn)
- (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- #f))
- (portnum (rpc:default-server-port))
- (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
- (tdb (tasks:open-db)))
- (thread-start! th1)
- (set! db *dbstruct-db*)
- (open-run-close tasks:server-set-interface-port
- tasks:open-db
- server-id
- ipaddrstr portnum)
- (debug:print 0 *default-log-port* "Server started on " host:port)
-
- ;; (trace rpc:publish-procedure!)
- ;; (rpc:publish-procedure! 'server:login server:login)
- ;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))
-
- ;;======================================================================
- ;; ;; end of publish-procedure section
- ;;======================================================================
- ;;
- (on-exit (lambda ()
- (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped")))
-
- (set! *rpc:listener* rpc:listener)
- (tasks:server-set-state! tdb server-id "running")
- (set! *dbstruct-db* (db:setup run-id))
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- (let loop ((count 0))
- (thread-sleep! 5) ;; no need to do this very often
- (let ((numrunning -1)) ;; (db:get-count-tests-running db)))
- (if (or (> numrunning 0)
- (> (+ *db-last-access* 60)(current-seconds)))
- (begin
- (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *db-last-access*))
- (loop (+ 1 count)))
- (begin
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server side")
- (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
- (thread-sleep! 10)
- (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- ))))))
-
-(define (rpc-transport:find-free-port-and-open port)
- (handle-exceptions
- exn
- (begin
- (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
- (rpc-transport:find-free-port-and-open (+ port 1)))
- (rpc:default-server-port port)
- (tcp-read-timeout 240000)
- (tcp-listen (rpc:default-server-port) 10000)))
-
-(define (rpc-transport:ping run-id host port)
- (handle-exceptions
- exn
- (begin
- (print "SERVER_NOT_FOUND")
- (exit 1))
- (let ((login-res ((rpc:procedure 'server:login host port) *toppath*)))
- (if (and (list? login-res)
- (car login-res))
- (begin
- (print "LOGIN_OK")
- (exit 0))
- (begin
- (print "LOGIN_FAILED")
- (exit 1))))))
-
-(define (rpc-transport:client-setup run-id #!key (remtries 10))
- (if *runremote*
- (begin
- (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected")
- #f)
- (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
- (if host-info
- (let ((iface (car host-info))
- (port (cadr host-info))
- (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
- (if ping-res
- (let ((server-dat (list iface port #f #f #f)))
- (hash-table-set! *runremote* run-id server-dat)
- server-dat)
- (begin
- (server:try-running *toppath*)
- (thread-sleep! 2)
- (rpc-transport:client-setup run-id (- remtries 1)))))
- (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
- (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if server-db-info
- (let* ((iface (tasks:hostinfo-get-interface server-db-info))
- (port (tasks:hostinfo-get-port server-db-info))
- (server-dat (list iface port #f #f #f))
- (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
- (if start-res
- (begin
- (hash-table-set! *runremote* run-id server-dat)
- server-dat)
- (begin
- (server:try-running *toppath*)
- (thread-sleep! 2)
- (rpc-transport:client-setup run-id (- remtries 1)))))
- (begin
- (server:try-running *toppath*)
- (thread-sleep! 2)
- (rpc-transport:client-setup run-id (- remtries 1)))))))))
-;;
-;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
-;; (if (and port
-;; (string->number port))
-;; (let ((portn (string->number port)))
-;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-error 0 *default-log-port* "Failed to open a connection to the server at host: " host " port: " port)
-;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
-;; ;; (open-run-close
-;; ;; (lambda (db . param)
-;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
-;; ;; #f)
-;; (set! *runremote* #f))
-;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
-;; ((rpc:procedure 'server:login host portn) *toppath*))
-;; (begin
-;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port)
-;; (set! *runremote* (vector host portn)))
-;; (begin
-;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port)
-;; (set! *runremote* #f)))))
-;; (debug:print-info 2 *default-log-port* "no server available")))))
-
ADDED runconfigmod.scm
Index: runconfigmod.scm
==================================================================
--- /dev/null
+++ runconfigmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 runconfigmod))
+(declare (uses commonmod))
+
+(module runconfigmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -28,10 +28,13 @@
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -1465,19 +1468,10 @@
itemmaps: itemmaps
;; prereqs-not-met: prereqs-not-met
)))
(runs:dat-regfull-set! runsdat regfull)
- ;; -- removed BB 17ww28 - no longer needed.
- ;; every 15 minutes verify the server is there for this run
- ;; (if (and (common:low-noise-print 240 "try start server" run-id)
- ;; (not (or (and *runremote*
- ;; (remote-server-url *runremote*)
- ;; (server:ping (remote-server-url *runremote*)))
- ;; (server:check-if-running *toppath*))))
- ;; (server:kind-run *toppath*))
-
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
ADDED runsmod.scm
Index: runsmod.scm
==================================================================
--- /dev/null
+++ runsmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 runsmod))
+(declare (uses commonmod))
+
+(module runsmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -27,15 +27,15 @@
(declare (unit server))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;; (declare (uses synchash))
(declare (uses http-transport))
-;;(declare (uses rpc-transport))
(declare (uses launch))
-;; (declare (uses daemon))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
@@ -67,30 +67,18 @@
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
- (case transport-type
- ((http)(http-transport:launch))
- ;;((nmsg)(nmsg-transport:launch run-id))
- ;;((rpc) (rpc-transport:launch run-id))
- (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
+ (http-transport:launch))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Get the transport
-(define (server:get-transport)
- (if *transport-type*
- *transport-type*
- (let ((ttype (string->symbol
- (or (args:get-arg "-transport")
- (configf:lookup *configdat* "server" "transport")
- "rpc"))))
- (set! *transport-type* ttype)
- ttype)))
+(define (server:get-transport) 'http)
;; Generate a unique signature for this server
(define (server:mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
@@ -101,19 +89,11 @@
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result)
(debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (case (server:get-transport)
- ((rpc) (db:obj->string (vector success/fail query-sig result)))
- ((http) (db:obj->string (vector success/fail query-sig result)))
- ((fs) result)
- (else
- (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
- result)))
+ (db:obj->string (vector success/fail query-sig result))) ;; (send-message pubsock target send-more: #t)
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
@@ -124,11 +104,11 @@
;; (dot-server-url (server:check-if-running areapath))
(curr-ip (server:get-best-guess-address curr-host))
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
- (testsuite (common:get-testsuite-name))
+ (testsuite (common:get-area-name *alldat*))
(logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
" -daemonize "
"")
@@ -451,11 +431,12 @@
((NOREPLY) #f)
((LOGIN_OK) #t)
(else #f))
(loop (read-line) inl))))))
-;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
+;; NOT USED (well, ok, was referenced in rpc-transport but otherwise
+;; not used).
;;
(define (server:login toppath)
(lambda (toppath)
(set! *db-last-access* (current-seconds)) ;; might not be needed.
(if (equal? *toppath* toppath)
@@ -504,15 +485,15 @@
;;
(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
(sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
- (tmp-area (common:get-db-tmp-area))
+ (tmp-area (common:get-db-tmp-area *alldat*))
(tmp-db (conc tmp-area "/megatest.db"))
(staging-file (conc *toppath* "/.megatest.db"))
(mtdbfile (conc *toppath* "/megatest.db"))
- (lockfile (common:get-sync-lock-filepath))
+ (lockfile (common:get-sync-lock-filepath *alldat*))
(sync-cmd-core (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
(sync-cmd (if fork-to-background
(conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
sync-cmd-core))
(default-min-intersync-delay 2)
@@ -628,11 +609,11 @@
(debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num)
(if (and legacy-sync (not *time-to-exit*))
(let* (;;(dbstruct (db:setup))
(mtdb (dbr:dbstruct-mtdb dbstruct))
(mtpath (db:dbdat-get-path mtdb))
- (tmp-area (common:get-db-tmp-area))
+ (tmp-area (common:get-db-tmp-area *alldat*))
(start-file (conc tmp-area "/.start-sync"))
(end-file (conc tmp-area "/.end-sync")))
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
;; sync for filesystem local db writes
ADDED servermod.scm
Index: servermod.scm
==================================================================
--- /dev/null
+++ servermod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 servermod))
+(declare (uses commonmod))
+
+(module servermod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -23,10 +23,13 @@
call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
+(declare (uses commonmod))
+(import commonmod)
+
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
ADDED subrunmod.scm
Index: subrunmod.scm
==================================================================
--- /dev/null
+++ subrunmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 subrunmod))
+(declare (uses commonmod))
+
+(module subrunmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -26,10 +26,12 @@
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))
;; (import pgdb) ;; pgdb is a module
+(declare (uses commonmod))
+(import commonmod)
(include "task_records.scm")
(include "db_records.scm")
;;======================================================================
@@ -103,11 +105,11 @@
(tasks:open-db numretries (- numretries 1)))
(begin
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* " exn=" (condition->list exn))))
- (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path))
+ (let* ((dbpath (common:get-db-tmp-area *alldat*)) ;; (tasks:get-task-db-path))
(dbfile (conc dbpath "/monitor.db"))
(avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
(exists (common:file-exists? dbpath))
(write-access (file-write-access? dbpath))
(mdb (cond ;; what the hek is *toppath* doing here?
@@ -283,11 +285,11 @@
;;
(define (tasks:start-monitor db mdb)
(if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
(debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
(let* ((megatestdb (conc *toppath* "/megatest.db"))
- (monitordbf (conc (db:dbfile-path #f) "/monitor.db"))
+ (monitordbf (conc (common:get-db-tmp-area *alldat*) "/monitor.db"))
(last-db-update 0)) ;; (file-modification-time megatestdb)))
(task:register-monitor mdb)
(let loop ((count 0)
(next-touch 0)) ;; next-touch is the time where we need to update last_update
;; if the db has been modified we'd best look at the task queue
@@ -613,11 +615,11 @@
;; attempt to automatically set up an area. call only if get area by path
;; returns naught of interest
;;
(define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated?
(let loop ((area-name (or (configf:lookup configdat "setup" "area-name")
- (common:get-area-name)))
+ (common:get-area-name *alldat*)))
(modifier 'none))
(let ((success (handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn))
@@ -769,11 +771,11 @@
""))
(last-update (db:get-value-by-header row header "last_update"))
(keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
(target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
- (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu
+ (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name *alldat*) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu
(spec-id (pgdb:get-ttype dbh keytarg))
(publish-time (if (args:get-arg "-cp-eventtime-to-publishtime")
event-time
(current-seconds)))
(new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id)))
ADDED tasksmod.scm
Index: tasksmod.scm
==================================================================
--- /dev/null
+++ tasksmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 tasksmod))
+(declare (uses commonmod))
+
+(module tasksmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -30,10 +30,13 @@
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
(declare (uses megatest-version))
+
+(declare (uses commonmod))
+(import commonmod)
(include "megatest-fossil-hash.scm")
(include "db_records.scm")
(define origargs (cdr (argv)))
@@ -291,11 +294,11 @@
(tdelay (string->number (or (args:get-arg "-delay") "15"))))
(if (and target runname)
(begin
(launch:setup)
(set! keys (rmt:get-keys))))
- (set! tsname (common:get-testsuite-name))
+ (set! tsname (common:get-area-name *alldat*))
(print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.")
(let loop ()
;;;;;; (handle-exceptions
;;;;;; exn
;;;;;; ;; (print "Process done.")
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -32,10 +32,13 @@
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(declare (uses db))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -29,15 +29,16 @@
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
-;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
-;; (declare (uses sdb))
(declare (uses server))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -855,11 +856,11 @@
;;
(define (tests:create-html-tree outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '())
(linktree (common:get-linktree))
- (area-name (common:get-testsuite-name))
+ (area-name (common:get-area-name *alldat*))
(keys (rmt:get-keys))
(numkeys (length keys))
(run-patt (or (args:get-arg "-run-patt")
(args:get-arg "-runname")
"%"))
@@ -948,11 +949,11 @@
(define (tests:dynamic-dboard page)
;(define (tests:create-html-tree o)
(let* (
;(page "1")
(linktree (common:get-linktree))
- (area-name (common:get-testsuite-name))
+ (area-name (common:get-area-name *alldat*))
(keys (rmt:get-keys))
(numkeys (length keys))
(targtweaked (make-list numkeys "%"))
(target-patt (string-join targtweaked "/"))
(total-runs (rmt:get-num-runs "%"))
@@ -979,11 +980,11 @@
(define (tests:create-html-summary outf)
(let* ((lockfile (conc outf ".lock"))
(linktree (common:get-linktree))
(keys (rmt:get-keys))
- (area-name (common:get-testsuite-name))
+ (area-name (common:get-area-name *alldat*))
(run-patt (or (args:get-arg "-run-patt")
(args:get-arg "-runname")
"%"))
(target (or (args:get-arg "-target-patt")
(args:get-arg "-target")
@@ -1174,11 +1175,11 @@
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '()))
(if (common:simple-file-lock lockfile)
(let* ((linktree (common:get-linktree))
(oup (open-output-file (or outf (conc linktree "/runs-index.html"))))
- (area-name (common:get-testsuite-name))
+ (area-name (common:get-area-name *alldat*))
(keys (rmt:get-keys))
(numkeys (length keys))
(runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys)))
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
@@ -1770,11 +1771,11 @@
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (rmt:get-test-id run-id test-name item-path))
- (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (tdat (rmt:get-testinfo-state-status run-id test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (and (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
@@ -1787,11 +1788,11 @@
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
(let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
- (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (wtdat (rmt:get-testinfo-state-status run-id test-id)))
(if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
(member (db:test-get-status wtdat) '("FAIL" "ABORT")))
(member (db:test-get-status wtdat) '("KILLED"))
(member (db:test-get-state wtdat) '("INCOMPETE")))
;; (if (or (member (db:test-get-status wtdat)
Index: tests/unittests/all-rmt.scm
==================================================================
--- tests/unittests/all-rmt.scm
+++ tests/unittests/all-rmt.scm
@@ -68,11 +68,11 @@
(thread-sleep! 2)
;; (test #f #t (string? (server:start-and-wait *toppath*)))
(test "setup for run" #t (begin (launch:setup)
(string? (getenv "MT_RUN_AREA_HOME"))))
-(test #f #t (client:setup-http toppath))
+(test #f #t (client:setup-http *alldat* toppath))
(test #f #t (vector? (client:setup toppath)))
(test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down.
(test #f #t (string? (server:check-if-running ".")))
;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '()))
ADDED testsmod.scm
Index: testsmod.scm
==================================================================
--- /dev/null
+++ testsmod.scm
@@ -0,0 +1,35 @@
+;;======================================================================
+;; Copyright 2019, 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 testsmod))
+(declare (uses commonmod))
+
+(module testsmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)
ADDED utils/fslrept
Index: utils/fslrept
==================================================================
--- /dev/null
+++ utils/fslrept
cannot compute difference between binary files
ADDED vgmod.scm
Index: vgmod.scm
==================================================================
--- /dev/null
+++ vgmod.scm
@@ -0,0 +1,36 @@
+;;======================================================================
+;; Copyright 2019, 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 vgmod))
+(declare (uses commonmod))
+(import commonmod)
+
+(module vgmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import commonmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+
+)