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,30 @@
# $(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/keysmod.o mofiles/tasksmod.o
+mofiles/commonmod.o : mofiles/configfmod.o
+mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o mofiles/apimod.o
+mofiles/apimod.o : mofiles/dbmod.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 +333,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
@@ -19,373 +19,15 @@
;;======================================================================
(use srfi-69 posix)
(declare (unit api))
-(declare (uses rmt))
+;; (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
- ))
-
-;; 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 )
-;;
-(define (api:execute-requests dbstruct dat)
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain)))
- (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
- (cond
- ((not (vector? dat)) ;; it is an error to not receive a vector
- (vector #f (vector #f "remote must be called with a vector")))
- ((> *api-process-request-count* 20) ;; 20)
- (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
- (set! *server-overloaded* #t)
- (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
- (else
- (let* ((cmd-in (vector-ref dat 0))
- (cmd (if (symbol? cmd-in)
- cmd-in
- (string->symbol cmd-in)))
- (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
- (common:telemetry-log (conc "api-in:"(->string cmd))
- payload: `((params . ,params)))
-
- #t))
- (res
- (if writecmd-in-readonly-mode
- (conc "attempt to run write command "cmd" on a read-only database")
- (case cmd
- ;;===============================================
- ;; READ/WRITE QUERIES
- ;;===============================================
-
- ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
-
- ;; SERVERS
- ((start-server) (apply server:kind-run params))
- ((kill-server) (set! *server-run* #f))
-
- ;; TESTS
-
- ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
- ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
- ((test-set-state-status-by-id)
-
- ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
- (db:set-state-status-and-roll-up-items
- dbstruct
- (list-ref params 0) ; run-id
- (list-ref params 1) ; test-name
- #f ; item-path
- (list-ref params 2) ; state
- (list-ref params 3) ; status
- (list-ref params 4) ; comment
- ))
-
- ((delete-test-records) (apply db:delete-test-records dbstruct params))
- ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
- ((test-set-state-status) (apply db:test-set-state-status dbstruct params))
- ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
- ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
- ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params))
- ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
- ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
-
- ;; RUNS
- ((register-run) (apply db:register-run dbstruct params))
- ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
- ((delete-run) (apply db:delete-run dbstruct params))
- ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
- ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
- ((update-run-stats) (apply db:update-run-stats dbstruct params))
- ((set-var) (apply db:set-var dbstruct params))
- ((del-var) (apply db:del-var dbstruct params))
-
- ;; STEPS
- ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
- ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
-
- ;; TEST DATA
- ((test-data-rollup) (apply db:test-data-rollup dbstruct params))
- ((csv->test-data) (apply db:csv->test-data dbstruct params))
-
- ;; MISC
- ((sync-inmem->db) (let ((run-id (car params)))
- (db:sync-touched dbstruct run-id force-sync: #t)))
- ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
-
- ;; TESTMETA
- ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
- ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
- ((get-tests-tags) (db:get-tests-tags dbstruct))
-
- ;; TASKS
- ((tasks-add) (apply tasks:add dbstruct params))
- ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
- ((tasks-get-last) (apply tasks:get-last dbstruct params))
-
- ;; NO SYNC DB
- ((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
- ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
- ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
- ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params))
-
- ;; ARCHIVES
- ;; ((archive-get-allocations)
- ((archive-register-disk) (apply db:archive-register-disk dbstruct params))
- ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
- ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
-
- ;;======================================================================
- ;; READ ONLY QUERIES
- ;;======================================================================
-
- ;; KEYS
- ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
- ((get-keys) (db:get-keys dbstruct))
- ((get-key-vals) (apply db:get-key-vals dbstruct params))
- ((get-target) (apply db:get-target dbstruct params))
- ((get-targets) (db:get-targets dbstruct))
-
- ;; ARCHIVES
- ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
-
- ;; TESTS
- ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
- ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
- ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
- ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
- ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
- ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
- ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
- ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
- ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
- ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
- ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
- ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
- ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
- ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
- ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
- ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
- ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params))
- ((synchash-get) (apply synchash:server-get dbstruct params))
- ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
- ((get-test-times) (apply db:get-test-times dbstruct params))
-
- ;; RUNS
- ((get-run-info) (apply db:get-run-info dbstruct params))
- ((get-run-status) (apply db:get-run-status dbstruct params))
- ((get-run-state) (apply db:get-run-state dbstruct params))
- ((set-run-status) (apply db:set-run-status dbstruct params))
- ((set-run-state-status) (apply db:set-run-state-status dbstruct params))
- ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
- ((get-test-id) (apply db:get-test-id dbstruct params))
- ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
- ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
- ((get-runs) (apply db:get-runs dbstruct params))
- ((simple-get-runs) (apply db:simple-get-runs dbstruct params))
- ((get-num-runs) (apply db:get-num-runs dbstruct params))
- ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params))
- ((get-all-run-ids) (db:get-all-run-ids dbstruct))
- ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
- ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
- ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
- ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
- ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
- ((get-var) (apply db:get-var dbstruct params))
- ((get-run-stats) (apply db:get-run-stats dbstruct params))
- ((get-run-times) (apply db:get-run-times dbstruct params))
-
- ;; STEPS
- ((get-steps-data) (apply db:get-steps-data dbstruct params))
- ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
- ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params))
-
- ;; TEST DATA
- ((read-test-data) (apply db:read-test-data dbstruct params))
- ((read-test-data*) (apply db:read-test-data* dbstruct params))
- ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params))
-
- ;; MISC
- ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params))
- ((have-incompletes?) (apply db:have-incompletes? dbstruct params))
- ((login) (apply db:login dbstruct params))
- ((general-call) (let ((stmtname (car params))
- (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))
- ;; TESTMETA
- ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
-
- ;; TASKS
- ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
- (else
- (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
- (conc "ERROR: BAD api call " cmd))))))
-
-
- ;; save all stats
- (let ((delta-t (- (current-milliseconds)
- start-t)))
- (hash-table-set! *db-api-call-time* cmd
- (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
- (if writecmd-in-readonly-mode
- (begin
- (common:telemetry-log (conc "api-out:"(->string cmd))
- payload: `((params . ,params)
- (ok-res . #t)))
- (vector #f res))
- (begin
- (common:telemetry-log (conc "api-out:"(->string cmd))
- payload: `((params . ,params)
- (ok-res . #f)))
- (vector #t res))))))))
-
-;; http-server send-response
-;; api:process-request
-;; db:*
-;;
-;; NB// Runs on the server as part of the server loop
-;;
-(define (api:process-request dbstruct $) ;; the $ is the request vars proc
- (set! *api-process-request-count* (+ *api-process-request-count* 1))
- (let* ((cmd ($ 'cmd))
- (paramsj ($ 'params))
- (params (db:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?)
- (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
- (success (vector-ref resdat 0))
- (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
- (if (not success)
- (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
- (if (> *api-process-request-count* *max-api-process-requests*)
- (set! *max-api-process-requests* *api-process-request-count*))
- (set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
- ;; (rmt:dat->json-str
- ;; (if (or (string? res)
- ;; (list? res)
- ;; (number? res)
- ;; (boolean? res))
- ;; res
- ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
- (db:obj->string res transport: 'http)))
+(declare (uses apimod))
+(import apimod)
+
+;; api:read-only-queries and api:execute-requests have been moved into common_records
+
ADDED apimod.scm
Index: apimod.scm
==================================================================
--- /dev/null
+++ apimod.scm
@@ -0,0 +1,335 @@
+;;======================================================================
+;; 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))
+(declare (uses dbmod))
+
+(module apimod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
+ s11n z3 (prefix base64 base64:) regex)
+(import commonmod)
+(import dbmod)
+;; (use (prefix ulex ulex:))
+
+(include "common_records.scm")
+
+(define *api-process-request-count* 0)
+(define *max-api-process-requests* 0)
+(define *db-api-call-time* (make-hash-table))
+
+;; NOTE: Can remove the regex and base64 encoding for zmq
+(define (api:obj->string obj #!key (transport 'http))
+ (case transport
+ ;; ((fs) obj)
+ ((http fs)
+ (string-substitute
+ (regexp "=") "_"
+ (base64:base64-encode
+ (z3:encode-buffer
+ (with-output-to-string
+ (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
+ #t))
+ ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
+ (else obj))) ;; rpc
+
+(define (api:string->obj msg #!key (transport 'http))
+ (case transport
+ ;; ((fs) msg)
+ ((http fs)
+ (if (string? msg)
+ (with-input-from-string
+ (z3:decode-buffer
+ (base64:base64-decode
+ (string-substitute
+ (regexp "_") "=" msg #t)))
+ (lambda ()(deserialize)))
+ (begin
+ (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
+ (print-call-chain (current-error-port))
+ msg))) ;; crude reply for when things go awry
+ ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
+ (else msg))) ;; rpc
+
+
+
+;; 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 )
+;;
+(define (api:execute-requests dbstruct dat)
+ (handle-exceptions
+ exn
+ (let ((call-chain (get-call-chain)))
+ (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
+ (cond
+ ((not (vector? dat)) ;; it is an error to not receive a vector
+ (vector #f (vector #f "remote must be called with a vector")))
+ ((> *api-process-request-count* 20) ;; 20)
+ (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
+ (set! *server-overloaded* #t)
+ (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
+ (else
+ (let* ((cmd-in (vector-ref dat 0))
+ (cmd (if (symbol? cmd-in)
+ cmd-in
+ (string->symbol cmd-in)))
+ (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
+ (common:telemetry-log (conc "api-in:"(->string cmd))
+ payload: `((params . ,params)))
+
+ #t))
+ (res
+ (if writecmd-in-readonly-mode
+ (conc "attempt to run write command "cmd" on a read-only database")
+ (case cmd
+ ;;===============================================
+ ;; READ/WRITE QUERIES
+ ;;===============================================
+
+ ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
+
+ ;; SERVERS
+ ((start-server) (apply server:kind-run params))
+ ((kill-server) (set! *server-run* #f))
+
+ ;; TESTS
+
+ ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
+ ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
+ ((test-set-state-status-by-id)
+
+ ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
+ (db:set-state-status-and-roll-up-items
+ dbstruct
+ (list-ref params 0) ; run-id
+ (list-ref params 1) ; test-name
+ #f ; item-path
+ (list-ref params 2) ; state
+ (list-ref params 3) ; status
+ (list-ref params 4) ; comment
+ ))
+
+ ((delete-test-records) (apply db:delete-test-records dbstruct params))
+ ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
+ ((test-set-state-status) (apply db:test-set-state-status dbstruct params))
+ ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
+ ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
+ ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params))
+ ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
+ ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
+
+ ;; RUNS
+ ((register-run) (apply db:register-run dbstruct params))
+ ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
+ ((delete-run) (apply db:delete-run dbstruct params))
+ ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
+ ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
+ ((update-run-stats) (apply db:update-run-stats dbstruct params))
+ ((set-var) (apply db:set-var dbstruct params))
+ ((del-var) (apply db:del-var dbstruct params))
+
+ ;; STEPS
+ ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
+ ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
+
+ ;; TEST DATA
+ ((test-data-rollup) (apply db:test-data-rollup dbstruct params))
+ ((csv->test-data) (apply db:csv->test-data dbstruct params))
+
+ ;; MISC
+ ((sync-inmem->db) (let ((run-id (car params)))
+ (db:sync-touched dbstruct run-id force-sync: #t)))
+ ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
+
+ ;; TESTMETA
+ ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
+ ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
+ ((get-tests-tags) (db:get-tests-tags dbstruct))
+
+ ;; TASKS
+ ((tasks-add) (apply tasks:add dbstruct params))
+ ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
+ ((tasks-get-last) (apply tasks:get-last dbstruct params))
+
+ ;; NO SYNC DB
+ ((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
+ ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
+ ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
+ ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params))
+
+ ;; ARCHIVES
+ ;; ((archive-get-allocations)
+ ((archive-register-disk) (apply db:archive-register-disk dbstruct params))
+ ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
+ ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
+
+ ;;======================================================================
+ ;; READ ONLY QUERIES
+ ;;======================================================================
+
+ ;; KEYS
+ ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
+ ((get-keys) (db:get-keys dbstruct))
+ ((get-key-vals) (apply db:get-key-vals dbstruct params))
+ ((get-target) (apply db:get-target dbstruct params))
+ ((get-targets) (db:get-targets dbstruct))
+
+ ;; ARCHIVES
+ ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
+
+ ;; TESTS
+ ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
+ ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
+ ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
+ ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
+ ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
+ ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
+ ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
+ ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
+ ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
+ ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
+ ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
+ ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
+ ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
+ ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
+ ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
+ ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
+ ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params))
+ ((synchash-get) (apply synchash:server-get dbstruct params))
+ ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
+ ((get-test-times) (apply db:get-test-times dbstruct params))
+
+ ;; RUNS
+ ((get-run-info) (apply db:get-run-info dbstruct params))
+ ((get-run-status) (apply db:get-run-status dbstruct params))
+ ((get-run-state) (apply db:get-run-state dbstruct params))
+ ((set-run-status) (apply db:set-run-status dbstruct params))
+ ((set-run-state-status) (apply db:set-run-state-status dbstruct params))
+ ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
+ ((get-test-id) (apply db:get-test-id dbstruct params))
+ ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
+ ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
+ ((get-runs) (apply db:get-runs dbstruct params))
+ ((simple-get-runs) (apply db:simple-get-runs dbstruct params))
+ ((get-num-runs) (apply db:get-num-runs dbstruct params))
+ ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params))
+ ((get-all-run-ids) (db:get-all-run-ids dbstruct))
+ ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
+ ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
+ ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
+ ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
+ ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
+ ((get-var) (apply db:get-var dbstruct params))
+ ((get-run-stats) (apply db:get-run-stats dbstruct params))
+ ((get-run-times) (apply db:get-run-times dbstruct params))
+
+ ;; STEPS
+ ((get-steps-data) (apply db:get-steps-data dbstruct params))
+ ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
+ ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params))
+
+ ;; TEST DATA
+ ((read-test-data) (apply db:read-test-data dbstruct params))
+ ((read-test-data*) (apply db:read-test-data* dbstruct params))
+ ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params))
+
+ ;; MISC
+ ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params))
+ ((have-incompletes?) (apply db:have-incompletes? dbstruct params))
+ ((login) (apply db:login dbstruct params))
+ ((general-call) (let ((stmtname (car params))
+ (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))
+ ;; TESTMETA
+ ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
+
+ ;; TASKS
+ ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
+ (else
+ (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
+ (conc "ERROR: BAD api call " cmd))))))
+
+
+ ;; save all stats
+ (let ((delta-t (- (current-milliseconds)
+ start-t)))
+ (hash-table-set! *db-api-call-time* cmd
+ (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
+ (if writecmd-in-readonly-mode
+ (begin
+ #;(common:telemetry-log (conc "api-out:"(->string cmd))
+ payload: `((params . ,params)
+ (ok-res . #t)))
+ (vector #f res))
+ (begin
+ #;(common:telemetry-log (conc "api-out:"(->string cmd))
+ payload: `((params . ,params)
+ (ok-res . #f)))
+ (vector #t res))))))))
+
+;; http-server send-response
+;; api:process-request
+;; db:*
+;;
+;; NB// Runs on the server as part of the server loop
+;;
+(define (api:process-request dbstruct $) ;; the $ is the request vars proc
+ (set! *api-process-request-count* (+ *api-process-request-count* 1))
+ (let* ((cmd ($ 'cmd))
+ (paramsj ($ 'params))
+ (params (api:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?)
+ (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
+ (success (vector-ref resdat 0))
+ (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
+ (if (not success)
+ (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
+ (if (> *api-process-request-count* *max-api-process-requests*)
+ (set! *max-api-process-requests* *api-process-request-count*))
+ (set! *api-process-request-count* (- *api-process-request-count* 1))
+ ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
+ ;; (rmt:dat->json-str
+ ;; (if (or (string? res)
+ ;; (list? res)
+ ;; (number? res)
+ ;; (boolean? res))
+ ;; res
+ ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
+ (api:obj->string res transport: 'http)))
+
+
+)
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
@@ -151,18 +151,17 @@
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
(define *db-with-db-mutex* (make-mutex))
-(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
+
;; no sync db
(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)
@@ -170,12 +169,10 @@
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
-(define *api-process-request-count* 0)
-(define *max-api-process-requests* 0)
(define *server-overloaded* #f)
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
@@ -270,21 +267,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)
@@ -331,13 +317,10 @@
;;======================================================================
(define (common:get-full-version)
(conc megatest-version "-" megatest-fossil-hash))
-(define (common:version-signature)
- (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-
;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
(rmt:get-var "MEGATEST_VERSION"))
@@ -359,13 +342,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 +628,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
@@ -671,51 +643,10 @@
(print-call-chain (current-error-port))
#f)
(read (open-input-string (base64:base64-decode instr))))
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
-;; dot-locking egg seems not to work, using this for now
-;; if lock is older than expire-time then remove it and try again
-;; to get the lock
-;;
-(define (common:simple-file-lock fname #!key (expire-time 300))
- (if (common:file-exists? fname)
- (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
- (begin
- (handle-exceptions exn #f (delete-file* fname))
- (common:simple-file-lock fname expire-time: expire-time))
- #f)
- (let ((key-string (conc (get-host-name) "-" (current-process-id))))
- (with-output-to-file fname
- (lambda ()
- (print key-string)))
- (thread-sleep! 0.25)
- (if (common:file-exists? fname)
- (handle-exceptions exn
- #f
- (with-input-from-file fname
- (lambda ()
- (equal? key-string (read-line)))))
- #f))))
-
-(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
- (let ((end-time (+ expire-time (current-seconds))))
- (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
- (if got-lock
- #t
- (if (> end-time (current-seconds))
- (begin
- (thread-sleep! 3)
- (loop (common:simple-file-lock fname expire-time: expire-time)))
- #f)))))
-
-(define (common:simple-file-release-lock fname)
- (handle-exceptions
- exn
- #f ;; I don't really care why this failed (at least for now)
- (delete-file* fname)))
-
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
@@ -857,37 +788,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 +900,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 +1006,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)
@@ -1267,14 +1144,10 @@
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
-(define (common:get-fields cfgdat)
- (let ((fields (hash-table-ref/default cfgdat "fields" '())))
- (map car fields)))
-
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
@@ -1589,32 +1462,10 @@
;;======================================================================
;; S Y S T E M S T U F F
;;======================================================================
-;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
-;;
-(define (common:lazy-modification-time fpath)
- (handle-exceptions
- exn
- 0
- (file-modification-time fpath)))
-
-;; find timestamp of newest file associated with a sqlite db file
-(define (common:lazy-sqlite-db-modification-time fpath)
- (let* ((glob-list (handle-exceptions
- exn
- `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
- (glob (conc fpath "*"))))
- (file-list (if (eq? 0 (length glob-list))
- '("/no/such/file")
- glob-list)))
- (apply max
- (map
- common:lazy-modification-time
- file-list))))
-
;; return a nice clean pathname made absolute
(define (common:nice-path dir)
(let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
(if match ;; using ~ for home?
(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
@@ -2058,24 +1909,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)
@@ -2360,322 +2212,10 @@
(cond
(with-vars (common:without-vars fullcmd))
(with-orig-env (common:with-orig-env fullcmd))
(else (common:without-vars fullcmd "MT_.*")))))
-;;======================================================================
-;; T I M E A N D D A T E
-;;======================================================================
-
-;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
-(define (common:hms-string->seconds tstr)
- (let ((parts (string-split-fields "\\w+" tstr))
- (time-secs 0)
- ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
- (trx (regexp "(\\d+)([smhdMyw])")))
- (for-each (lambda (part)
- (let ((match (string-match trx part)))
- (if match
- (let ((val (string->number (cadr match)))
- (unt (caddr match)))
- (if val
- (set! time-secs (+ time-secs (* val
- (case (string->symbol unt)
- ((s) 1)
- ((m) 60) ;; minutes
- ((h) 3600)
- ((d) 86400)
- ((w) 604800)
- ((M) 2628000) ;; aproximately one month
- ((y) 31536000)
- (else #f))))))))))
- parts)
- time-secs))
-
-(define (seconds->hr-min-sec secs)
- (let* ((hrs (quotient secs 3600))
- (min (quotient (- secs (* hrs 3600)) 60))
- (sec (- secs (* hrs 3600)(* min 60))))
- (conc (if (> hrs 0)(conc hrs "hr ") "")
- (if (> min 0)(conc min "m ") "")
- sec "s")))
-
-(define (seconds->time-string sec)
- (time->string
- (seconds->local-time sec) "%H:%M:%S"))
-
-(define (seconds->work-week/day-time sec)
- (time->string
- (seconds->local-time sec) "ww%V.%u %H:%M"))
-
-(define (seconds->work-week/day sec)
- (time->string
- (seconds->local-time sec) "ww%V.%u"))
-
-(define (seconds->year-work-week/day sec)
- (time->string
- (seconds->local-time sec) "%yww%V.%w"))
-
-(define (seconds->year-work-week/day-time sec)
- (time->string
- (seconds->local-time sec) "%Yww%V.%w %H:%M"))
-
-(define (seconds->year-week/day-time sec)
- (time->string
- (seconds->local-time sec) "%Yw%V.%w %H:%M"))
-
-(define (seconds->quarter sec)
- (case (string->number
- (time->string
- (seconds->local-time sec)
- "%m"))
- ((1 2 3) 1)
- ((4 5 6) 2)
- ((7 8 9) 3)
- ((10 11 12) 4)
- (else #f)))
-
-;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
-;;
-(define (common:date-time->seconds datetime)
- (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
-
-;; given span of seconds tstart to tend
-;; find start time to mark and mark delta
-;;
-(define (common:find-start-mark-and-mark-delta tstart tend)
- (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
- (result #f)
- (min 60)
- (hr (* 60 60))
- (day (* 24 hr))
- (yr (* 365 day)) ;; year
- (mo (/ yr 12))
- (wk (* day 7)))
- (for-each
- (lambda (max-blks)
- (for-each
- (lambda (span) ;; 5 2 1
- (if (not result)
- (for-each
- (lambda (timeunit timesym) ;; year month day hr min sec
- (if (not result)
- (let* ((time-blk (* span timeunit))
- (num-blks (quotient deltat time-blk)))
- (if (and (> num-blks 4)(< num-blks max-blks))
- (let ((first (* (quotient tstart time-blk) time-blk)))
- (set! result (list span timeunit time-blk first timesym))
- )))))
- (list yr mo wk day hr min 1)
- '( y mo w d h m s))))
- (list 8 6 5 2 1)))
- '(5 10 15 20 30 40 50 500))
- (if values
- (apply values result)
- (values 0 day 1 0 'd))))
-
-;; given x y lim return the cron expansion
-;;
-(define (common:expand-cron-slash x y lim)
- (let loop ((curr x)
- (res `()))
- (if (< curr lim)
- (loop (+ curr y) (cons curr res))
- (reverse res))))
-
-;; expand a complex cron string to a list of cron strings
-;;
-;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c
-;;
-;; NOTE: with flatten a lot of the crud below can be factored down.
-;;
-(define (common:cron-expand cron-str)
- (if (list? cron-str)
- (flatten
- (fold (lambda (x res)
- (if (list? x)
- (let ((newres (map common:cron-expand x)))
- (append x newres))
- (cons x res)))
- '()
- cron-str)) ;; (map common:cron-expand cron-str))
- (let ((cron-items (string-split cron-str))
- (slash-rx (regexp "(\\d+)/(\\d+)"))
- (comma-rx (regexp ".*,.*"))
- (max-vals '((min . 60)
- (hour . 24)
- (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
- (month . 12)
- (dayofweek . 7))))
- (if (< (length cron-items) 5) ;; bad spec
- cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
- (let loop ((hed (car cron-items))
- (tal (cdr cron-items))
- (type 'min)
- (type-tal '(hour dayofmonth month dayofweek))
- (res '()))
- (regex-case
- hed
- (slash-rx ( _ base incr ) (let* ((basen (string->number base))
- (incrn (string->number incr))
- (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
- (new-list-crons (fold (lambda (x myres)
- (cons (conc (if (null? res)
- ""
- (conc (string-intersperse res " ") " "))
- x " " (string-intersperse tal " "))
- myres))
- '() expanded-vals)))
- ;; (print "new-list-crons: " new-list-crons)
- ;; (fold (lambda (x res)
- ;; (if (list? x)
- ;; (let ((newres (map common:cron-expand x)))
- ;; (append x newres))
- ;; (cons x res)))
- ;; '()
- (flatten (map common:cron-expand new-list-crons))))
- ;; (map common:cron-expand (map common:cron-expand new-list-crons))))
- (else (if (null? tal)
- cron-str
- (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
-
-
-;; given a cron string and the last time event was processed return #t to run or #f to not run
-;;
-;; min hour dayofmonth month dayofweek
-;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
-;;
-;; #t => yes, run the job
-;; #f => no, do not run the job
-;;
-(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
- (let* ((cron-items (map string->number (string-split cron-str)))
- (now-seconds (or now-seconds-in (current-seconds)))
- (now-time (seconds->local-time now-seconds))
- (last-done-time (seconds->local-time last-done))
- (all-times (make-hash-table)))
- ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
- (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
- #f
- (match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
- cron-items)
- ;; 0 1 2 3 4 5 6
- ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
- (vector->list now-time))
- ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
- (vector->list last-done-time)))
- ;; create all possible time slots
- ;; remove invalid slots due to (for example) day of week
- ;; get the start and end entries for the ref-seconds (current) time
- ;; if last-done > ref-seconds => this is an ERROR!
- ;; does the last-done time fall in the legit region?
- ;; yes => #f do not run again this command
- ;; no => #t ok to run the command
- (for-each ;; month
- (lambda (month)
- (for-each ;; dayofmonth
- (lambda (dom)
- (for-each
- (lambda (hr) ;; hour
- (for-each
- (lambda (minute) ;; minute
- (let ((copy-now (apply vector (vector->list now-time))))
- (vector-set! copy-now 0 0) ;; force seconds to zero
- (vector-set! copy-now 1 minute)
- (vector-set! copy-now 2 hr)
- (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
- (vector-set! copy-now 4 month)
- (let* ((copy-now-secs (local-time->seconds copy-now))
- (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
- (if (or (not cdayofweek)
- (equal? (vector-ref new-copy 6)
- cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
- (if (or (not cdayofmonth)
- (equal? (vector-ref new-copy 3)
- (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
- (hash-table-set! all-times copy-now-secs new-copy))))))
- (if cmin
- `(,cmin) ;; if given cmin, have to use it
- (list (- nmin 1) nmin (+ nmin 1))))) ;; minute
- (if chour
- `(,chour)
- (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
- (if cdayofmonth
- `(,cdayofmonth)
- (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
- (if cmonth
- `(,cmonth)
- (list (- nmonth 1) nmonth (+ nmonth 1))))
- (let ((before #f)
- (is-in #f))
- (for-each
- (lambda (moment)
- (if (and before
- (<= before now-seconds)
- (>= moment now-seconds))
- (begin
- ;; (print)
- ;; (print "Before: " (time->string (seconds->local-time before)))
- ;; (print "Now: " (time->string (seconds->local-time now-seconds)))
- ;; (print "After: " (time->string (seconds->local-time moment)))
- ;; (print "Last: " (time->string (seconds->local-time last-done)))
- (if (< last-done before)
- (set! is-in before))
- ))
- (set! before moment))
- (sort (hash-table-keys all-times) <))
- is-in)))))
-
-(define (common:extended-cron cron-str now-seconds-in last-done)
- (let ((expanded-cron (common:cron-expand cron-str)))
- (if (string? expanded-cron)
- (common:cron-event expanded-cron now-seconds-in last-done)
- (let loop ((hed (car expanded-cron))
- (tal (cdr expanded-cron)))
- (if (common:cron-event hed now-seconds-in last-done)
- #t
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal))))))))
-
-;;======================================================================
-;; C O L O R S
-;;======================================================================
-
-(define (common:name->iup-color name)
- (case (string->symbol (string-downcase name))
- ((red) "223 33 49")
- ((grey) "192 192 192")
- ((orange) "255 172 13")
- ((purple) "This is unfinished ...")))
-
-;; (define (common:get-color-for-state-status state status)
-;; (case (string->symbol state)
-;; ((COMPLETED)
-;; (case (string->symbol status)
-;; ((PASS) "70 249 73")
-;; ((WARN WAIVED) "255 172 13")
-;; ((SKIP) "230 230 0")
-;; (else "223 33 49")))
-;; ((LAUNCHED) "101 123 142")
-;; ((CHECK) "255 100 50")
-;; ((REMOTEHOSTSTART) "50 130 195")
-;; ((RUNNING) "9 131 232")
-;; ((KILLREQ) "39 82 206")
-;; ((KILLED) "234 101 17")
-;; ((NOT_STARTED) "240 240 240")
-;; (else "192 192 192")))
-
-(define (common:iup-color->rgb-hex instr)
- (string-intersperse
- (map (lambda (x)
- (number->string x 16))
- (map string->number
- (string-split instr)))
- "/"))
-
;;======================================================================
;; L O C K I N G M E C H A N I S M S
;;======================================================================
;; faux-lock is deprecated. Please use simple-lock below
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -17,12 +17,236 @@
;; 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)
+ (megatest-version "1.6536")
+ (megatest-fossil-hash #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 +304,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 +315,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 +345,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 +442,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 +459,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,482 @@
;; 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-1 files format srfi-13 matchable
+ srfi-69 ports
+ regex-case regex)
+
+(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 (common:version-signature alldat)
+ (conc (alldat-megatest-version alldat)
+ "-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
+
+(define (common:get-fields cfgdat)
+ (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+ (map car fields)))
+
+;;======================================================================
+;; T I M E A N D D A T E
+;;======================================================================
+
+;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
+(define (common:hms-string->seconds tstr)
+ (let ((parts (string-split-fields "\\w+" tstr))
+ (time-secs 0)
+ ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
+ (trx (regexp "(\\d+)([smhdMyw])")))
+ (for-each (lambda (part)
+ (let ((match (string-match trx part)))
+ (if match
+ (let ((val (string->number (cadr match)))
+ (unt (caddr match)))
+ (if val
+ (set! time-secs (+ time-secs (* val
+ (case (string->symbol unt)
+ ((s) 1)
+ ((m) 60) ;; minutes
+ ((h) 3600)
+ ((d) 86400)
+ ((w) 604800)
+ ((M) 2628000) ;; aproximately one month
+ ((y) 31536000)
+ (else #f))))))))))
+ parts)
+ time-secs))
+
+(define (seconds->hr-min-sec secs)
+ (let* ((hrs (quotient secs 3600))
+ (min (quotient (- secs (* hrs 3600)) 60))
+ (sec (- secs (* hrs 3600)(* min 60))))
+ (conc (if (> hrs 0)(conc hrs "hr ") "")
+ (if (> min 0)(conc min "m ") "")
+ sec "s")))
+
+(define (seconds->time-string sec)
+ (time->string
+ (seconds->local-time sec) "%H:%M:%S"))
+
+(define (seconds->work-week/day-time sec)
+ (time->string
+ (seconds->local-time sec) "ww%V.%u %H:%M"))
+
+(define (seconds->work-week/day sec)
+ (time->string
+ (seconds->local-time sec) "ww%V.%u"))
+
+(define (seconds->year-work-week/day sec)
+ (time->string
+ (seconds->local-time sec) "%yww%V.%w"))
+
+(define (seconds->year-work-week/day-time sec)
+ (time->string
+ (seconds->local-time sec) "%Yww%V.%w %H:%M"))
+
+(define (seconds->year-week/day-time sec)
+ (time->string
+ (seconds->local-time sec) "%Yw%V.%w %H:%M"))
+
+(define (seconds->quarter sec)
+ (case (string->number
+ (time->string
+ (seconds->local-time sec)
+ "%m"))
+ ((1 2 3) 1)
+ ((4 5 6) 2)
+ ((7 8 9) 3)
+ ((10 11 12) 4)
+ (else #f)))
+
+;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
+;;
+(define (common:date-time->seconds datetime)
+ (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
+
+;; given span of seconds tstart to tend
+;; find start time to mark and mark delta
+;;
+(define (common:find-start-mark-and-mark-delta tstart tend)
+ (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
+ (result #f)
+ (min 60)
+ (hr (* 60 60))
+ (day (* 24 hr))
+ (yr (* 365 day)) ;; year
+ (mo (/ yr 12))
+ (wk (* day 7)))
+ (for-each
+ (lambda (max-blks)
+ (for-each
+ (lambda (span) ;; 5 2 1
+ (if (not result)
+ (for-each
+ (lambda (timeunit timesym) ;; year month day hr min sec
+ (if (not result)
+ (let* ((time-blk (* span timeunit))
+ (num-blks (quotient deltat time-blk)))
+ (if (and (> num-blks 4)(< num-blks max-blks))
+ (let ((first (* (quotient tstart time-blk) time-blk)))
+ (set! result (list span timeunit time-blk first timesym))
+ )))))
+ (list yr mo wk day hr min 1)
+ '( y mo w d h m s))))
+ (list 8 6 5 2 1)))
+ '(5 10 15 20 30 40 50 500))
+ (if values
+ (apply values result)
+ (values 0 day 1 0 'd))))
+
+;; given x y lim return the cron expansion
+;;
+(define (common:expand-cron-slash x y lim)
+ (let loop ((curr x)
+ (res `()))
+ (if (< curr lim)
+ (loop (+ curr y) (cons curr res))
+ (reverse res))))
+
+;; expand a complex cron string to a list of cron strings
+;;
+;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c
+;;
+;; NOTE: with flatten a lot of the crud below can be factored down.
+;;
+(define (common:cron-expand cron-str)
+ (if (list? cron-str)
+ (flatten
+ (fold (lambda (x res)
+ (if (list? x)
+ (let ((newres (map common:cron-expand x)))
+ (append x newres))
+ (cons x res)))
+ '()
+ cron-str)) ;; (map common:cron-expand cron-str))
+ (let ((cron-items (string-split cron-str))
+ (slash-rx (regexp "(\\d+)/(\\d+)"))
+ (comma-rx (regexp ".*,.*"))
+ (max-vals '((min . 60)
+ (hour . 24)
+ (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
+ (month . 12)
+ (dayofweek . 7))))
+ (if (< (length cron-items) 5) ;; bad spec
+ cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
+ (let loop ((hed (car cron-items))
+ (tal (cdr cron-items))
+ (type 'min)
+ (type-tal '(hour dayofmonth month dayofweek))
+ (res '()))
+ (regex-case
+ hed
+ (slash-rx ( _ base incr ) (let* ((basen (string->number base))
+ (incrn (string->number incr))
+ (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
+ (new-list-crons (fold (lambda (x myres)
+ (cons (conc (if (null? res)
+ ""
+ (conc (string-intersperse res " ") " "))
+ x " " (string-intersperse tal " "))
+ myres))
+ '() expanded-vals)))
+ ;; (print "new-list-crons: " new-list-crons)
+ ;; (fold (lambda (x res)
+ ;; (if (list? x)
+ ;; (let ((newres (map common:cron-expand x)))
+ ;; (append x newres))
+ ;; (cons x res)))
+ ;; '()
+ (flatten (map common:cron-expand new-list-crons))))
+ ;; (map common:cron-expand (map common:cron-expand new-list-crons))))
+ (else (if (null? tal)
+ cron-str
+ (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
+
+
+;; given a cron string and the last time event was processed return #t to run or #f to not run
+;;
+;; min hour dayofmonth month dayofweek
+;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
+;;
+;; #t => yes, run the job
+;; #f => no, do not run the job
+;;
+(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
+ (let* ((cron-items (map string->number (string-split cron-str)))
+ (now-seconds (or now-seconds-in (current-seconds)))
+ (now-time (seconds->local-time now-seconds))
+ (last-done-time (seconds->local-time last-done))
+ (all-times (make-hash-table)))
+ ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
+ (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
+ #f
+ (match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
+ cron-items)
+ ;; 0 1 2 3 4 5 6
+ ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
+ (vector->list now-time))
+ ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
+ (vector->list last-done-time)))
+ ;; create all possible time slots
+ ;; remove invalid slots due to (for example) day of week
+ ;; get the start and end entries for the ref-seconds (current) time
+ ;; if last-done > ref-seconds => this is an ERROR!
+ ;; does the last-done time fall in the legit region?
+ ;; yes => #f do not run again this command
+ ;; no => #t ok to run the command
+ (for-each ;; month
+ (lambda (month)
+ (for-each ;; dayofmonth
+ (lambda (dom)
+ (for-each
+ (lambda (hr) ;; hour
+ (for-each
+ (lambda (minute) ;; minute
+ (let ((copy-now (apply vector (vector->list now-time))))
+ (vector-set! copy-now 0 0) ;; force seconds to zero
+ (vector-set! copy-now 1 minute)
+ (vector-set! copy-now 2 hr)
+ (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
+ (vector-set! copy-now 4 month)
+ (let* ((copy-now-secs (local-time->seconds copy-now))
+ (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
+ (if (or (not cdayofweek)
+ (equal? (vector-ref new-copy 6)
+ cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
+ (if (or (not cdayofmonth)
+ (equal? (vector-ref new-copy 3)
+ (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
+ (hash-table-set! all-times copy-now-secs new-copy))))))
+ (if cmin
+ `(,cmin) ;; if given cmin, have to use it
+ (list (- nmin 1) nmin (+ nmin 1))))) ;; minute
+ (if chour
+ `(,chour)
+ (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
+ (if cdayofmonth
+ `(,cdayofmonth)
+ (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
+ (if cmonth
+ `(,cmonth)
+ (list (- nmonth 1) nmonth (+ nmonth 1))))
+ (let ((before #f)
+ (is-in #f))
+ (for-each
+ (lambda (moment)
+ (if (and before
+ (<= before now-seconds)
+ (>= moment now-seconds))
+ (begin
+ ;; (print)
+ ;; (print "Before: " (time->string (seconds->local-time before)))
+ ;; (print "Now: " (time->string (seconds->local-time now-seconds)))
+ ;; (print "After: " (time->string (seconds->local-time moment)))
+ ;; (print "Last: " (time->string (seconds->local-time last-done)))
+ (if (< last-done before)
+ (set! is-in before))
+ ))
+ (set! before moment))
+ (sort (hash-table-keys all-times) <))
+ is-in)))))
+
+(define (common:extended-cron cron-str now-seconds-in last-done)
+ (let ((expanded-cron (common:cron-expand cron-str)))
+ (if (string? expanded-cron)
+ (common:cron-event expanded-cron now-seconds-in last-done)
+ (let loop ((hed (car expanded-cron))
+ (tal (cdr expanded-cron)))
+ (if (common:cron-event hed now-seconds-in last-done)
+ #t
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal))))))))
+
+;;======================================================================
+;; C O L O R S
+;;======================================================================
+
+(define (common:name->iup-color name)
+ (case (string->symbol (string-downcase name))
+ ((red) "223 33 49")
+ ((grey) "192 192 192")
+ ((orange) "255 172 13")
+ ((purple) "This is unfinished ...")))
+
+;; (define (common:get-color-for-state-status state status)
+;; (case (string->symbol state)
+;; ((COMPLETED)
+;; (case (string->symbol status)
+;; ((PASS) "70 249 73")
+;; ((WARN WAIVED) "255 172 13")
+;; ((SKIP) "230 230 0")
+;; (else "223 33 49")))
+;; ((LAUNCHED) "101 123 142")
+;; ((CHECK) "255 100 50")
+;; ((REMOTEHOSTSTART) "50 130 195")
+;; ((RUNNING) "9 131 232")
+;; ((KILLREQ) "39 82 206")
+;; ((KILLED) "234 101 17")
+;; ((NOT_STARTED) "240 240 240")
+;; (else "192 192 192")))
+
+(define (common:iup-color->rgb-hex instr)
+ (string-intersperse
+ (map (lambda (x)
+ (number->string x 16))
+ (map string->number
+ (string-split instr)))
+ "/"))
+
+;; dot-locking egg seems not to work, using this for now
+;; if lock is older than expire-time then remove it and try again
+;; to get the lock
+;;
+(define (common:simple-file-lock fname #!key (expire-time 300))
+ (if (file-exists? fname)
+ (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
+ (begin
+ (handle-exceptions exn #f (delete-file* fname))
+ (common:simple-file-lock fname expire-time: expire-time))
+ #f)
+ (let ((key-string (conc (get-host-name) "-" (current-process-id))))
+ (with-output-to-file fname
+ (lambda ()
+ (print key-string)))
+ (thread-sleep! 0.25)
+ (if (file-exists? fname)
+ (handle-exceptions exn
+ #f
+ (with-input-from-file fname
+ (lambda ()
+ (equal? key-string (read-line)))))
+ #f))))
+
+(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
+ (let ((end-time (+ expire-time (current-seconds))))
+ (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
+ (if got-lock
+ #t
+ (if (> end-time (current-seconds))
+ (begin
+ (thread-sleep! 3)
+ (loop (common:simple-file-lock fname expire-time: expire-time)))
+ #f)))))
+
+(define (common:simple-file-release-lock fname)
+ (handle-exceptions
+ exn
+ #f ;; I don't really care why this failed (at least for now)
+ (delete-file* fname)))
+
+;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
+;;
+(define (common:lazy-modification-time fpath)
+ (handle-exceptions
+ exn
+ 0
+ (file-modification-time fpath)))
+
+;; find timestamp of newest file associated with a sqlite db file
+(define (common:lazy-sqlite-db-modification-time fpath)
+ (let* ((glob-list (handle-exceptions
+ exn
+ `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
+ (glob (conc fpath "*"))))
+ (file-list (if (eq? 0 (length glob-list))
+ '("/no/such/file")
+ glob-list)))
+ (apply max
+ (map
+ common:lazy-modification-time
+ file-list))))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -522,32 +522,16 @@
(equal? (configf:lookup cfgdat section var) expected-val))
(define configf:lookup config-lookup)
(define configf:read-file read-config)
-;; safely look up a value that is expected to be a number, return
-;; a default (#f unless provided)
-;;
-(define (configf:lookup-number cfdat section varname #!key (default #f))
- (let* ((val (configf:lookup *configdat* section varname))
- (res (if val
- (string->number (string-substitute "\\s+" "" val #t))
- #f)))
- (cond
- (res res)
- (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
- (else default))))
-
(define (configf:section-vars cfgdat section)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
'()
(map car sectdat))))
-(define (configf:get-section cfgdat section)
- (hash-table-ref/default cfgdat section '()))
-
(define (configf:set-section-var cfgdat section var val)
(let ((sectdat (configf:get-section cfgdat section)))
(hash-table-set! cfgdat section
(config:assoc-safe-add sectdat var val))))
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,64 @@
+;;======================================================================
+;; 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 regex)
+;; (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))
+
+(define (configf:get-section cfgdat section)
+ (hash-table-ref/default cfgdat section '()))
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (configf:lookup-number cfgdat section varname #!key (default #f))
+ (let* ((val (configf:lookup cfgdat section varname))
+ (res (if val
+ (string->number (string-substitute "\\s+" "" val #t))
+ #f)))
+ (cond
+ (res res)
+ (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+ (else default))))
+
+
+)
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,207 +148,25 @@
;; 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) ";"))))
-;; open an sql database inside a file lock
-;; returns: db existed-prior-to-opening
-;; RA => Returns a db handler; sets the lock if opened in writable mode
-;;
-;; (define *db-open-mutex* (make-mutex))
-
-(define (db:lock-create-open fname initproc)
- (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
- (raw-fname (pathname-file fname))
- (dir-writable (file-write-access? parent-dir))
- (file-exists (common:file-exists? fname))
- (file-write (if file-exists
- (file-write-access? fname)
- dir-writable )))
- ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
- (if file-write ;; dir-writable
- (condition-case
- (let* ((lockfname (conc fname ".lock"))
- (readyfname (conc parent-dir "/.ready-" raw-fname))
- (readyexists (common:file-exists? readyfname)))
- (if (not readyexists)
- (common:simple-file-lock-and-wait lockfname))
- (let ((db (sqlite3:open-database fname)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
- (begin
- ;;(print "DEBUG: Setting tmp_mode for " fname)
- (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
- )
- )
- (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
- (begin
- ;;(print "DEBUG: Setting nfs_mode for " fname)
- (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
- )
- )
- (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))
- (configf:lookup *configdat* "setup" "use-wal")
- (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
- (sqlite3:execute db "PRAGMA journal_mode=WAL;")
- (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
- (if (not file-exists)
- (initproc db))
- (if (not readyexists)
- (begin
- (common:simple-file-release-lock lockfname)
- (with-output-to-file
- readyfname
- (lambda ()
- (print "Ready at "
- (seconds->year-work-week/day-time
- (current-seconds)))))))
- db))
- (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
- (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
- (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
- (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))))
-
- (condition-case
- (begin
- (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
- (let ((db (sqlite3:open-database fname)))
- ;; (mutex-unlock! *db-open-mutex*)
- db))
- (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
- (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
- (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
- (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))))
-
-;; Open the classic megatest.db file (defaults to open in toppath)
-;;
-;; NOTE: returns a dbdat not a dbstruct!
-;;
-
-;;(define (db:reopen-megatest-db
-
-(define (db:open-megatest-db #!key (path #f)(name #f))
- (let* ((dbdir (or path *toppath*))
- (dbpath (conc dbdir "/" (or name "megatest.db")))
- (dbexists (common:file-exists? dbpath))
- (db (db:lock-create-open dbpath
- (lambda (db)
- (db:initialize-main-db db)
- ;;(db:initialize-run-id-db db)
- )))
- (write-access (file-write-access? dbpath)))
- (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
- (if (and dbexists (not write-access))
- (set! *db-write-access* #f))
- (cons db dbpath)))
+ (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))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
(let ((tmpdb (db:get-db dbstruct))
@@ -462,93 +231,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 +252,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 +461,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)
@@ -1153,235 +592,10 @@
(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
-(define (db:initialize-main-db dbdat)
- (when (not *configinfo*)
- (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
- (let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
- (keys (keys:config-get-fields configdat))
- (havekeys (> (length keys) 0))
- (keystr (keys->keystr keys))
- (fieldstr (keys:make-key/field-string configdat))
- (db (db:dbdat-get-db dbdat)))
- (for-each (lambda (key)
- (let ((keyn key))
- (if (member (string-downcase keyn)
- (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
- "pass_count" "contour"))
- (begin
- (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.")
- (exit 1)))))
- keys)
- (sqlite3:with-transaction
- db
- (lambda ()
- ;; handle-exceptions
- ;; exn
- ;; (begin
- ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
- ;; (exit))
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
- (for-each (lambda (key)
- (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
- keys)
- (sqlite3:execute db (conc
- "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
- fieldstr (if havekeys "," "") "
- runname TEXT DEFAULT 'norun',
- contour TEXT DEFAULT '',
- state TEXT DEFAULT '',
- status TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- event_time TIMESTAMP DEFAULT (strftime('%s','now')),
- comment TEXT DEFAULT '',
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
- FOR EACH ROW
- BEGIN
- UPDATE runs SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
- id INTEGER PRIMARY KEY,
- run_id INTEGER,
- state TEXT,
- status TEXT,
- count INTEGER,
- last_update INTEGER DEFAULT (strftime('%s','now')))")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
- FOR EACH ROW
- BEGIN
- UPDATE run_stats SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
- id INTEGER PRIMARY KEY,
- testname TEXT DEFAULT '',
- author TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- description TEXT DEFAULT '',
- reviewed TIMESTAMP,
- iterated TEXT DEFAULT '',
- avg_runtime REAL,
- avg_disk REAL,
- tags TEXT DEFAULT '',
- jobgroup TEXT DEFAULT 'default',
- CONSTRAINT test_meta_constraint UNIQUE (testname));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
- action TEXT DEFAULT '',
- owner TEXT,
- state TEXT DEFAULT 'new',
- target TEXT DEFAULT '',
- name TEXT DEFAULT '',
- testpatt TEXT DEFAULT '',
- keylock TEXT,
- params TEXT,
- creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
- execution_time TIMESTAMP);")
- ;; archive disk areas, cached info from [archive-disks]
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
- id INTEGER PRIMARY KEY,
- archive_area_name TEXT,
- disk_path TEXT,
- last_df INTEGER DEFAULT -1,
- last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
- creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
- ;; individual bup (or tar) data chunks
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
- id INTEGER PRIMARY KEY,
- archive_disk_id INTEGER,
- disk_path TEXT,
- last_du INTEGER DEFAULT -1,
- last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
- creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
- ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
- ;; NB// the per run/test recording of where the archive is stored is done in the test
- ;; record.
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
- id INTEGER PRIMARY KEY,
- archive_block_id INTEGER,
- testname TEXT,
- item_path TEXT,
- creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
- ;; move this clean up call somewhere else
- (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
- (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
- ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
- ;; Must do this *after* running patch db !! No more.
- ;; cannot use db:set-var since it will deadlock, hardwire the code here
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
- (debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
-
- ;;======================================================================
- ;; R U N S P E C I F I C D B
- ;;======================================================================
-
- ;; (define (db:initialize-run-id-db db)
- ;; (sqlite3:with-transaction
- ;; db
- ;; (lambda ()
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
- (id INTEGER PRIMARY KEY,
- run_id INTEGER DEFAULT -1,
- testname TEXT DEFAULT 'noname',
- host TEXT DEFAULT 'n/a',
- cpuload REAL DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- uname TEXT DEFAULT 'n/a',
- rundir TEXT DEFAULT '/tmp/badname',
- shortdir TEXT DEFAULT '/tmp/badname',
- item_path TEXT DEFAULT '',
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'FAIL',
- attemptnum INTEGER DEFAULT 0,
- final_logf TEXT DEFAULT 'logs/final.log',
- logdat TEXT DEFAULT '',
- run_duration INTEGER DEFAULT 0,
- comment TEXT DEFAULT '',
- event_time TIMESTAMP DEFAULT (strftime('%s','now')),
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
- ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
-
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
-
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
- FOR EACH ROW
- BEGIN
- UPDATE tests SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
- (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- stepname TEXT,
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'n/a',
- event_time TIMESTAMP,
- comment TEXT DEFAULT '',
- logfile TEXT DEFAULT '',
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
- FOR EACH ROW
- BEGIN
- UPDATE test_steps SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- category TEXT DEFAULT '',
- variable TEXT,
- value REAL,
- expected REAL,
- tol REAL,
- units TEXT,
- comment TEXT DEFAULT '',
- status TEXT DEFAULT 'n/a',
- type TEXT DEFAULT '',
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
- FOR EACH ROW
- BEGIN
- UPDATE test_data SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- update_time TIMESTAMP,
- cpuload INTEGER DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- diskusage INTGER DEFAULT -1,
- run_duration INTEGER DEFAULT 0);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- state TEXT DEFAULT 'new',
- status TEXT DEFAULT 'n/a',
- archive_type TEXT DEFAULT 'bup',
- du INTEGER,
- archive_path TEXT);")))
- db)) ;; )
-
;;======================================================================
;; A R C H I V E S
;;======================================================================
;; dneeded is minimum space needed, scan for existing archives that
@@ -1930,11 +1144,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 +1220,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 +1439,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
@@ -3662,43 +2860,10 @@
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
-;; NOTE: Can remove the regex and base64 encoding for zmq
-(define (db:obj->string obj #!key (transport 'http))
- (case transport
- ;; ((fs) obj)
- ((http fs)
- (string-substitute
- (regexp "=") "_"
- (base64:base64-encode
- (z3:encode-buffer
- (with-output-to-string
- (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
- #t))
- ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
- (else obj))) ;; rpc
-
-(define (db:string->obj msg #!key (transport 'http))
- (case transport
- ;; ((fs) msg)
- ((http fs)
- (if (string? msg)
- (with-input-from-string
- (z3:decode-buffer
- (base64:base64-decode
- (string-substitute
- (regexp "_") "=" msg #t)))
- (lambda ()(deserialize)))
- (begin
- (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
- (print-call-chain (current-error-port))
- msg))) ;; crude reply for when things go awry
- ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
- (else msg))) ;; rpc
-
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-db dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
@@ -4744,6 +3909,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,874 @@
+;;======================================================================
+;; 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))
+(declare (uses keysmod))
+(declare (uses tasksmod))
+
+(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
+ srfi-13)
+(import commonmod)
+(import configfmod)
+(import keysmod)
+(import files)
+(import tasksmod)
+
+;; (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 ((toppath (alldat-areapath alldat))
+ (configdat (alldat-mtconfig alldat))
+ (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 (file-exists? dbpath))
+ (tmpdbfname (conc dbpath "/megatest.db"))
+ (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
+ (mtdbexists (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)
+ (let* ((configdat (alldat-mtconfig alldat)))
+ (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))))))
+
+;; Open the classic megatest.db file (defaults to open in toppath)
+;;
+;; NOTE: returns a dbdat not a dbstruct!
+;;
+
+;;(define (db:reopen-megatest-db
+
+(define (db:open-megatest-db alldat #!key (path #f)(name #f))
+ (let* ((dbdir (or path (alldat-areapath alldat)))
+ (dbpath (conc dbdir "/" (or name "megatest.db")))
+ (dbexists (file-exists? dbpath))
+ (db (db:lock-create-open dbpath
+ (lambda (db)
+ (db:initialize-main-db db)
+ ;;(db:initialize-run-id-db db)
+ )))
+ (write-access (file-write-access? dbpath)))
+ (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ (cons db dbpath)))
+
+(define (db:initialize-main-db alldat dbdat)
+ #;(when (not *configinfo*)
+ (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
+ (let* ((configdat (alldat-mtconfig alldat))
+ ;; (configdat (car *configinfo*)) ;; tut tut, global warning...
+ (keys (common:get-fields configdat))
+ (havekeys (> (length keys) 0))
+ (keystr (keys->keystr keys))
+ (fieldstr (keys:make-key/field-string configdat))
+ (db (db:dbdat-get-db dbdat)))
+ (for-each (lambda (key)
+ (let ((keyn key))
+ (if (member (string-downcase keyn)
+ (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
+ "pass_count" "contour"))
+ (begin
+ (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.")
+ (exit 1)))))
+ keys)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ ;; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
+ ;; (exit))
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
+ (for-each (lambda (key)
+ (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
+ keys)
+ (sqlite3:execute db (conc
+ "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
+ fieldstr (if havekeys "," "") "
+ runname TEXT DEFAULT 'norun',
+ contour TEXT DEFAULT '',
+ state TEXT DEFAULT '',
+ status TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ comment TEXT DEFAULT '',
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ FOR EACH ROW
+ BEGIN
+ UPDATE runs SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
+ id INTEGER PRIMARY KEY,
+ run_id INTEGER,
+ state TEXT,
+ status TEXT,
+ count INTEGER,
+ last_update INTEGER DEFAULT (strftime('%s','now')))")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ FOR EACH ROW
+ BEGIN
+ UPDATE run_stats SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
+ id INTEGER PRIMARY KEY,
+ testname TEXT DEFAULT '',
+ author TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ description TEXT DEFAULT '',
+ reviewed TIMESTAMP,
+ iterated TEXT DEFAULT '',
+ avg_runtime REAL,
+ avg_disk REAL,
+ tags TEXT DEFAULT '',
+ jobgroup TEXT DEFAULT 'default',
+ CONSTRAINT test_meta_constraint UNIQUE (testname));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
+ action TEXT DEFAULT '',
+ owner TEXT,
+ state TEXT DEFAULT 'new',
+ target TEXT DEFAULT '',
+ name TEXT DEFAULT '',
+ testpatt TEXT DEFAULT '',
+ keylock TEXT,
+ params TEXT,
+ creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ execution_time TIMESTAMP);")
+ ;; archive disk areas, cached info from [archive-disks]
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
+ id INTEGER PRIMARY KEY,
+ archive_area_name TEXT,
+ disk_path TEXT,
+ last_df INTEGER DEFAULT -1,
+ last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
+ ;; individual bup (or tar) data chunks
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
+ id INTEGER PRIMARY KEY,
+ archive_disk_id INTEGER,
+ disk_path TEXT,
+ last_du INTEGER DEFAULT -1,
+ last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
+ ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
+ ;; NB// the per run/test recording of where the archive is stored is done in the test
+ ;; record.
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
+ id INTEGER PRIMARY KEY,
+ archive_block_id INTEGER,
+ testname TEXT,
+ item_path TEXT,
+ creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
+ ;; move this clean up call somewhere else
+ (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
+ (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
+ ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
+ CONSTRAINT metadat_constraint UNIQUE (var));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
+ ;; Must do this *after* running patch db !! No more.
+ ;; cannot use db:set-var since it will deadlock, hardwire the code here
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
+ (debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
+
+ ;;======================================================================
+ ;; R U N S P E C I F I C D B
+ ;;======================================================================
+
+ ;; (define (db:initialize-run-id-db db)
+ ;; (sqlite3:with-transaction
+ ;; db
+ ;; (lambda ()
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
+ (id INTEGER PRIMARY KEY,
+ run_id INTEGER DEFAULT -1,
+ testname TEXT DEFAULT 'noname',
+ host TEXT DEFAULT 'n/a',
+ cpuload REAL DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ uname TEXT DEFAULT 'n/a',
+ rundir TEXT DEFAULT '/tmp/badname',
+ shortdir TEXT DEFAULT '/tmp/badname',
+ item_path TEXT DEFAULT '',
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'FAIL',
+ attemptnum INTEGER DEFAULT 0,
+ final_logf TEXT DEFAULT 'logs/final.log',
+ logdat TEXT DEFAULT '',
+ run_duration INTEGER DEFAULT 0,
+ comment TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
+ ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
+
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
+
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ FOR EACH ROW
+ BEGIN
+ UPDATE tests SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
+ (id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ stepname TEXT,
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'n/a',
+ event_time TIMESTAMP,
+ comment TEXT DEFAULT '',
+ logfile TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_steps SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ category TEXT DEFAULT '',
+ variable TEXT,
+ value REAL,
+ expected REAL,
+ tol REAL,
+ units TEXT,
+ comment TEXT DEFAULT '',
+ status TEXT DEFAULT 'n/a',
+ type TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_data SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ update_time TIMESTAMP,
+ cpuload INTEGER DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ diskusage INTGER DEFAULT -1,
+ run_duration INTEGER DEFAULT 0);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ state TEXT DEFAULT 'new',
+ status TEXT DEFAULT 'n/a',
+ archive_type TEXT DEFAULT 'bup',
+ du INTEGER,
+ archive_path TEXT);")))
+ db)) ;; )
+
+;; open an sql database inside a file lock
+;; returns: db existed-prior-to-opening
+;; RA => Returns a db handler; sets the lock if opened in writable mode
+;;
+;; (define *db-open-mutex* (make-mutex))
+;;
+(define (db:lock-create-open alldat fname initproc)
+ (let* ((configdat (alldat-mtconfig alldat))
+ (parent-dir (or (pathname-directory fname)
+ (current-directory))) ;; no parent? go local
+ (raw-fname (pathname-file fname))
+ (dir-writable (file-write-access? parent-dir))
+ (file-exists (file-exists? fname))
+ (file-write (if file-exists
+ (file-write-access? fname)
+ dir-writable )))
+ ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
+ (if file-write ;; dir-writable
+ (condition-case
+ (let* ((lockfname (conc fname ".lock"))
+ (readyfname (conc parent-dir "/.ready-" raw-fname))
+ (readyexists (file-exists? readyfname)))
+ (if (not readyexists)
+ (common:simple-file-lock-and-wait lockfname))
+ (let ((db (sqlite3:open-database fname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (and (configf:lookup configdat "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
+ (begin
+ ;;(print "DEBUG: Setting tmp_mode for " fname)
+ (sqlite3:execute db (configf:lookup configdat "setup" "tmp_mode"))
+ )
+ )
+ (if (and (configf:lookup configdat "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
+ (begin
+ ;;(print "DEBUG: Setting nfs_mode for " fname)
+ (sqlite3:execute db (configf:lookup configdat "setup" "nfs_mode"))
+ )
+ )
+ (if (and (not (or (configf:lookup configdat "setup" "tmp_mode") (configf:lookup configdat "setup" "nfs_mode")))
+ (configf:lookup configdat "setup" "use-wal")
+ (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
+ (sqlite3:execute db "PRAGMA journal_mode=WAL;")
+ (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
+ (if (not file-exists)
+ (initproc db))
+ (if (not readyexists)
+ (begin
+ (common:simple-file-release-lock lockfname)
+ (with-output-to-file
+ readyfname
+ (lambda ()
+ (print "Ready at "
+ (seconds->year-work-week/day-time
+ (current-seconds)))))))
+ db))
+ (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
+ (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))))
+
+ (condition-case
+ (begin
+ (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
+ (let ((db (sqlite3:open-database fname)))
+ ;; (mutex-unlock! *db-open-mutex*)
+ db))
+ (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
+ (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))))
+ )))
+
+
+
+
+)
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,17 +24,17 @@
(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, ...
- (string-intersperse keys ","))
-
(define (args:usage . a) #f)
;;======================================================================
;; key <=> target routines
;;======================================================================
@@ -73,13 +73,6 @@
;;======================================================================
;; config file related routines
;;======================================================================
-(define keys:config-get-fields common:get-fields)
-(define (keys:make-key/field-string confdat)
- (let ((fields (configf:get-section confdat "fields")))
- (string-join
- (map (lambda (field)(conc (car field) " " (cadr field)))
- fields)
- ",")))
-
+;; (define keys:config-get-fields common:get-fields)
ADDED keysmod.scm
Index: keysmod.scm
==================================================================
--- /dev/null
+++ keysmod.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 keysmod))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(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)
+(import configfmod)
+
+;; (use (prefix ulex ulex:))
+(import srfi-13)
+
+(include "common_records.scm")
+
+(define (keys:make-key/field-string confdat)
+ (let ((fields (configf:get-section confdat "fields")))
+ (string-join
+ (map (lambda (field)(conc (car field) " " (cadr field)))
+ fields)
+ ",")))
+
+(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
+ (string-intersperse keys ","))
+
+
+)
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,115 @@
;;======================================================================
(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 (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: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 +142,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,1072 +26,11 @@
(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")
-;;======================================================================
-;; Tasks db
-;;======================================================================
-
-;; wait up to aprox n seconds for a journal to go away
-;;
-(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f))
- (if (not (string? path))
- (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)")
- (let ((fullpath (conc path "-journal")))
- (handle-exceptions
- exn
- (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))
- (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
- #t) ;; if stuff goes wrong just allow it to move on
- (let loop ((journal-exists (common:file-exists? fullpath))
- (count n)) ;; wait ten times ...
- (if journal-exists
- (begin
- (if (and waiting-msg
- (eq? (modulo n 30) 0))
- (debug:print 0 *default-log-port* waiting-msg))
- (if (> count 0)
- (begin
- (thread-sleep! 1)
- (loop (common:file-exists? fullpath)
- (- count 1)))
- (begin
- (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.")
- (if remove (system (conc "rm -rf " fullpath)))
- #f)))
- #t))))))
-
-(define (tasks:get-task-db-path)
- (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir")
- (configf:lookup *configdat* "setup" "dbdir")
- (conc (common:get-linktree) "/.db"))))
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
- (exit 1))
- (if (not (directory? dbdir))(create-directory dbdir #t)))
- dbdir))
-
-;; If file exists AND
-;; file readable
-;; ==> open it
-;; If file exists AND
-;; file NOT readable
-;; ==> open in-mem version
-;; If file NOT exists
-;; ==> open in-mem version
-;;
-(define (tasks:open-db #!key (numretries 4))
- (if *task-db*
- *task-db*
- (handle-exceptions
- exn
- (if (> numretries 0)
- (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))
- (thread-sleep! 1)
- (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))
- (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?
- ((and (string? *toppath*)(file-write-access? *toppath*))
- (sqlite3:open-database dbfile))
- ((file-read-access? dbpath) (sqlite3:open-database dbfile))
- (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
- (handler (make-busy-timeout 36000)))
- (if (and exists
- (not write-access))
- (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
- (sqlite3:set-busy-handler! mdb handler)
- (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
- ;; (if (or (and (not exists)
- ;; (file-write-access? *toppath*))
- ;; (not (file-read-access? dbpath)))
- ;; (begin
- ;;
- ;; TASKS QUEUE MOVED TO main.db
- ;;
- ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
- ;; action TEXT DEFAULT '',
- ;; owner TEXT,
- ;; state TEXT DEFAULT 'new',
- ;; target TEXT DEFAULT '',
- ;; name TEXT DEFAULT '',
- ;; testpatt TEXT DEFAULT '',
- ;; keylock TEXT,
- ;; params TEXT,
- ;; creation_time TIMESTAMP,
- ;; execution_time TIMESTAMP);")
- (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY,
- pid INTEGER,
- start_time TIMESTAMP,
- last_update TIMESTAMP,
- hostname TEXT,
- username TEXT,
- CONSTRAINT monitors_constraint UNIQUE (pid,hostname));")
- (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY,
- pid INTEGER,
- interface TEXT,
- hostname TEXT,
- port INTEGER,
- pubport INTEGER,
- start_time TIMESTAMP,
- priority INTEGER,
- state TEXT,
- mt_version TEXT,
- heartbeat TIMESTAMP,
- transport TEXT,
- run_id INTEGER);")
- ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
- (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
- server_id INTEGER,
- pid INTEGER,
- hostname TEXT,
- cmdline TEXT,
- login_time TIMESTAMP,
- logout_time TIMESTAMP DEFAULT -1,
- CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
-
- ;))
- (set! *task-db* (cons mdb dbpath))
- *task-db*))))
-
-;;======================================================================
-;; Server and client management
-;;======================================================================
-
-;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
-(define (tasks:hostinfo-get-id vec) (vector-ref vec 0))
-(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1))
-(define (tasks:hostinfo-get-port vec) (vector-ref vec 2))
-(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
-(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4))
-(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
-(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6))
-
-(define (tasks:need-server run-id)
- (equal? (configf:lookup *configdat* "server" "required") "yes"))
-
-;; no elegance here ...
-;;
-(define (tasks:kill-server hostname pid #!key (kill-switch ""))
- (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
- (setenv "TARGETHOST" hostname)
- (let* ((logdir (if (directory-exists? "logs")
- "logs/"
- ""))
- (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
- (gzfile (if logfile (conc logfile ".gz"))))
- (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
-
- (system (conc "nbfake kill "kill-switch" "pid))
-
- (when logfile
- (thread-sleep! 0.5)
- (if (common:file-exists? gzfile) (delete-file gzfile))
- (system (conc "gzip " logfile))
-
- (unsetenv "TARGETHOST_LOGF")
- (unsetenv "TARGETHOST"))))
-
-
-;;======================================================================
-;; M O N I T O R S
-;;======================================================================
-
-(define (tasks:remove-monitor-record mdb)
- (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;"
- (current-process-id)
- (get-host-name)))
-
-(define (tasks:get-monitors mdb)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (a . rem)
- (set! res (cons (apply vector a rem) res)))
- mdb
- "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;")
- (reverse res)
- ))
-
-(define (tasks:monitors->text-table monitors)
- (let ((fmtstr "~4a~8a~20a~20a~10a~10a"))
- (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n"
- (string-intersperse
- (map (lambda (monitor)
- (format #f fmtstr
- (tasks:monitor-get-id monitor)
- (tasks:monitor-get-pid monitor)
- (tasks:monitor-get-start_time monitor)
- (tasks:monitor-get-last_update monitor)
- (tasks:monitor-get-hostname monitor)
- (tasks:monitor-get-username monitor)))
- monitors)
- "\n"))))
-
-;; update the last_update field with the current time and
-;; if any monitors appear dead, remove them
-(define (tasks:monitors-update mdb)
- (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;"
- (current-process-id)
- (get-host-name))
- (let ((deadlist '()))
- (sqlite3:for-each-row
- (lambda (id pid host last-update delta)
- (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago")
- (set! deadlist (cons id deadlist)))
- mdb
- "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;")
- (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');")))
- )
-(define (tasks:register-monitor db port)
- (let* ((pid (current-process-id))
- (hostname (get-host-name))
- (userinfo (user-information (current-user-id)))
- (username (car userinfo)))
- (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
- (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);"
- pid hostname username)))
-
-(define (tasks:get-num-alive-monitors mdb)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- mdb
- "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
- (car (user-information (current-user-id))))
- res))
-
-;;
-(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"))
- (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
- (let ((modtime (file-modification-time megatestdbpath )))
- (if (> modtime last-db-update)
- (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch))
- ;; WARNING: Possible race conditon here!!
- ;; should this update be immediately after the task-get-action call above?
- (if (> (current-seconds) next-touch)
- (begin
- (tasks:monitors-update mdb)
- (loop (+ count 1)(+ (current-seconds) 240)))
- (loop (+ count 1) next-touch)))))))
-
-;;======================================================================
-;; T A S K S Q U E U E
-;;
-;; NOTE:: These operate on task_queue which is in main.db
-;;
-;;======================================================================
-
-;; NOTE: It might be good to add one more layer of checking to ensure
-;; that no task gets run in parallel.
-
-;; id INTEGER PRIMARY KEY,
-;; action TEXT DEFAULT '',
-;; owner TEXT,
-;; state TEXT DEFAULT 'new',
-;; target TEXT DEFAULT '',
-;; name TEXT DEFAULT '',
-;; testpatt TEXT DEFAULT '',
-;; keylock TEXT,
-;; params TEXT,
-;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
-;; execution_time TIMESTAMP);
-
-
-;; register a task
-(define (tasks:add dbstruct action owner target runname testpatt params)
- (db:with-db
- dbstruct #f #t
- (lambda (db)
- (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
- VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);"
- action
- owner
- target
- runname
- testpatt
- (if params params "")))))
-
-(define (keys:key-vals-hash->target keys key-params)
- (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) "")))
- (if (> (length keys) 1)
- (for-each (lambda (key)
- (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) ""))))
- (cdr keys)))
- tmp))
-
-;; for use from the gui, not ported
-;;
-;; (define (tasks:add-from-params mdb action keys key-params var-params)
-;; (let ((target (keys:key-vals-hash->target keys key-params))
-;; (owner (car (user-information (current-user-id))))
-;; (runname (hash-table-ref/default var-params "runname" #f))
-;; (testpatts (hash-table-ref/default var-params "testpatts" "%"))
-;; (params (hash-table-ref/default var-params "params" "")))
-;; (tasks:add mdb action owner target runname testpatts params)))
-
-;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old
-;;
-(define (tasks:snag-a-task dbstruct)
- (let ((res #f)
- (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))
- (db:with-db
- dbstruct #f #t
- (lambda (db)
- ;; first randomly set a new to pid-hostname-hostname
- (sqlite3:execute
- db
- "UPDATE tasks_queue SET keylock=? WHERE id IN
- (SELECT id FROM tasks_queue
- WHERE state='new' OR
- (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR
- state='reset'
- ORDER BY RANDOM() LIMIT 1);" keytxt)
-
- (sqlite3:for-each-row
- (lambda (id . rem)
- (set! res (apply vector id rem)))
- db
- "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt)
- (if res ;; yep, have work to be done
- (begin
- (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;"
- (tasks:task-get-id res))
- res)
- #f)))))
-
-(define (tasks:reset-stuck-tasks dbstruct)
- (let ((res '()))
- (db:with-db
- dbstruct #f #t
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (id delta)
- (set! res (cons id res)))
- db
- "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
- (sqlite3:execute
- db
- (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');")
- )))))
-
-;; return all tasks in the tasks_queue table
-;;
-(define (tasks:get-tasks dbstruct types states)
- (let ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (id . rem)
- (set! res (cons (apply vector id rem) res)))
- db
- (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time
- FROM tasks_queue "
- ;; WHERE
- ;; state IN " statesstr " AND
- ;; action IN " actionsstr
- " ORDER BY creation_time DESC;"))
- res))))
-
-(define (tasks:get-last dbstruct target runname)
- (let ((res #f))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (id . rem)
- (set! res (apply vector id rem)))
- db
- (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time
- FROM tasks_queue
- WHERE
- target = ? AND name =?
- ORDER BY creation_time DESC LIMIT 1;")
- target runname)
- res))))
-
-;; remove tasks given by a string of numbers comma separated
-(define (tasks:remove-queue-entries dbstruct task-ids)
- (db:with-db
- dbstruct #f #t
- (lambda (db)
- (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
-
-(define (tasks:process-queue dbstruct)
- (let* ((task (tasks:snag-a-task dbstruct))
- (action (if task (tasks:task-get-action task) #f)))
- (if action (print "tasks:process-queue task: " task))
- (if action
- (case (string->symbol action)
- ((run) (tasks:start-run dbstruct task))
- ((remove) (tasks:remove-runs dbstruct task))
- ((lock) (tasks:lock-runs dbstruct task))
- ;; ((monitor) (tasks:start-monitor db task))
- ((rollup) (tasks:rollup-runs dbstruct task))
- ((updatemeta)(tasks:update-meta dbstruct task))
- ((kill) (tasks:kill-monitors dbstruct task))))))
-
-(define (tasks:tasks->text tasks)
- (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
- (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
- (string-intersperse
- (map (lambda (task)
- (format #f fmtstr
- (tasks:task-get-id task)
- (tasks:task-get-action task)
- (tasks:task-get-owner task)
- (tasks:task-get-state task)
- (tasks:task-get-target task)
- (tasks:task-get-name task)
- (tasks:task-get-test task)
- ;; (tasks:task-get-item task)
- (tasks:task-get-params task)))
- tasks) "\n"))))
-
-(define (tasks:set-state dbstruct task-id state)
- (db:with-db
- dbstruct #f #t
- (lambda (db)
- (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;"
- state
- task-id))))
-
-;;======================================================================
-;; Access using task key (stored in params; (hash-table->alist flags) hostname pid
-;;======================================================================
-
-(define (tasks:param-key->id dbstruct task-params)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;"
- task-params)))))
-
-(define (tasks:set-state-given-param-key dbstruct param-key new-state)
- (db:with-db
- dbstruct #f #t
- (lambda (db)
- (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key))))
-
-(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (handle-exceptions
- exn
- '()
- (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE
- params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
- param-key state-patt action-patt test-patt)))))
-
-(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
- ;; (handle-exceptions
- ;; exn
- ;; '()
- ;; (sqlite3:first-row
- (let ((db (db:delay-if-busy (db:get-db dbstruct)))
- (res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (cons (cons a b) res)))
- db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
- WHERE
- target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
- target run-name state-patt action-patt test-patt)
- res)) ;; )
-
-;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
-;;
-;; do a remote call to get the task queue info but do the killing as self here.
-;;
-(define (tasks:kill-runner target run-name testpatt)
- (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests"))
- (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
- (if (null? records)
- (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
- (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill."))
- (for-each
- (lambda (record)
- (let* ((param-key (list-ref record 8))
- (match-dat (string-search hostpid-rx param-key)))
- (if match-dat
- (let ((hostname (cadr match-dat))
- (pid (string->number (caddr match-dat))))
- (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname)
- (if (equal? (get-host-name) hostname)
- (if (process:alive? pid)
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- #t)
- (process-signal pid signal/int)
- (thread-sleep! 5)
- (if (process:alive? pid)
- (process-signal pid signal/kill)))))
- ;; (call-with-environment-variables
- (let ((old-targethost (getenv "TARGETHOST")))
- (setenv "TARGETHOST" hostname)
- (setenv "TARGETHOST_LOGF" "server-kills.log")
- (system (conc "nbfake kill " pid))
- (if old-targethost (setenv "TARGETHOST" old-targethost))
- (unsetenv "TARGETHOST")
- (unsetenv "TARGETHOST_LOGF"))))
- (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
- records)))
-
-;; (define (tasks:start-run dbstruct mdb task)
-;; (let ((flags (make-hash-table)))
-;; (hash-table-set! flags "-rerun" "NOT_STARTED")
-;; (if (not (string=? (tasks:task-get-params task) ""))
-;; (hash-table-set! flags "-setvars" (tasks:task-get-params task)))
-;; (print "Starting run " task)
-;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
-;; (runs:run-tests db
-;; (tasks:task-get-target task)
-;; (tasks:task-get-name task)
-;; (tasks:task-get-test task)
-;; (tasks:task-get-item task)
-;; (tasks:task-get-owner task)
-;; flags)
-;; (tasks:set-state mdb (tasks:task-get-id task) "waiting")))
-;;
-;; (define (tasks:rollup-runs db mdb task)
-;; (let* ((flags (make-hash-table))
-;; (keys (db:get-keys db))
-;; (keyvals (keys:target-keyval keys (tasks:task-get-target task))))
-;; ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
-;; (print "Starting rollup " task)
-;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
-;; (runs:rollup-run db
-;; keys
-;; keyvals
-;; (tasks:task-get-name task)
-;; (tasks:task-get-owner task))
-;; (tasks:set-state mdb (tasks:task-get-id task) "waiting")))
-
-;;======================================================================
-;; S Y N C T O P O S T G R E S Q L
-;;======================================================================
-
-;; In the spirit of "dump your junk in the tasks module" I'll put the
-;; sync to postgres here for now.
-
-;; 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)))
- (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))
- #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception
- (pgdb:add-area dbh area-name (or toppath *toppath*)))))
- (or success
- (case modifier
- ((none)(loop (conc (current-user-name) "_" area-name) 'user))
- ((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
- area-name) 'areasig))
- (else #f)))))) ;; give up
-
-(define (task:print-runtime run-times saperator)
-(for-each
- (lambda (run-time-info)
- (let* ((run-name (vector-ref run-time-info 0))
- (run-time (vector-ref run-time-info 1))
- (target (vector-ref run-time-info 2)))
- (print target saperator run-name saperator run-time )))
- run-times))
-
-(define (task:print-runtime-as-json run-times)
- (let loop ((run-time-info (car run-times))
- (rema (cdr run-times))
- (str ""))
- (let* ((run-name (vector-ref run-time-info 0))
- (run-time (vector-ref run-time-info 1))
- (target (vector-ref run-time-info 2)))
- ;(print (not (equal? str "")))
- (if (not (equal? str ""))
- (set! str (conc str ",")))
- (if (null? rema)
- (print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]")
- (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}"))))))
-
-(define (task:get-run-times)
- (let* (
- (run-patt (if (args:get-arg "-run-patt")
- (args:get-arg "-run-patt")
- "%"))
- (target-patt (if (args:get-arg "-target-patt")
- (args:get-arg "-target-patt")
- "%"))
-
- (run-times (rmt:get-run-times run-patt target-patt )))
- (if (eq? (length run-times) 0)
- (begin
- (print "Data not found!!")
- (exit)))
- (if (equal? (args:get-arg "-dumpmode") "json")
- (task:print-runtime-as-json run-times)
- (if (equal? (args:get-arg "-dumpmode") "csv")
- (task:print-runtime run-times ",")
- (task:print-runtime run-times " ")))))
-
-
-(define (task:print-testtime test-times saperator)
-(for-each
- (lambda (test-time-info)
- (let* ((test-name (vector-ref test-time-info 0))
- (test-time (vector-ref test-time-info 2))
- (test-item (if (eq? (string-length (vector-ref test-time-info 1)) 0)
- "N/A"
- (vector-ref test-time-info 1))))
- (print test-name saperator test-item saperator test-time )))
- test-times))
-
-(define (task:print-testtime-as-json test-times)
- (let loop ((test-time-info (car test-times))
- (rema (cdr test-times))
- (str ""))
- (let* ((test-name (vector-ref test-time-info 0))
- (test-time (vector-ref test-time-info 2))
- (item (vector-ref test-time-info 1)))
- ;(print (not (equal? str "")))
- (if (not (equal? str ""))
- (set! str (conc str ",")))
- (if (null? rema)
- (print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]")
- (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}"))))))
-
-
- (define (task:get-test-times)
- (let* ((runname (if (args:get-arg "-runname")
- (args:get-arg "-runname")
- #f))
- (target (if (args:get-arg "-target")
- (args:get-arg "-target")
- #f))
-
- (test-times (rmt:get-test-times runname target )))
- (if (not runname)
- (begin
- (print "Error: Missing argument -runname")
- (exit)))
- (if (string-contains runname "%")
- (begin
- (print "Error: Invalid runname, '%' not allowed (" runname ") ")
- (exit)))
- (if (not target)
- (begin
- (print "Error: Missing argument -target")
- (exit)))
- (if (string-contains target "%")
- (begin
- (print "Error: Invalid target, '%' not allowed (" target ") ")
- (exit)))
-
- (if (eq? (length test-times) 0)
- (begin
- (print "Data not found!!")
- (exit)))
- (if (equal? (args:get-arg "-dumpmode") "json")
- (task:print-testtime-as-json test-times)
- (if (equal? (args:get-arg "-dumpmode") "csv")
- (task:print-testtime test-times ",")
- (task:print-testtime test-times " ")))))
-
-
-
-;; gets mtpg-run-id and syncs the record if different
-;;
-(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
- (let* ((runs-ht (hash-table-ref cached-info 'runs))
- (runinf (hash-table-ref/default runs-ht run-id #f))
- (area-id (vector-ref area-info 0)))
- (if runinf
- runinf ;; already cached
- (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header >
- (run-name (rmt:get-run-name-from-id run-id))
- (row (db:get-rows run-dat)) ;; yes, this returns a single row
- (header (db:get-header run-dat))
- (state (db:get-value-by-header row header "state"))
- (status (db:get-value-by-header row header "status"))
- (owner (db:get-value-by-header row header "owner"))
- (event-time (db:get-value-by-header row header "event_time"))
- (comment (db:get-value-by-header row header "comment"))
- (fail-count (db:get-value-by-header row header "fail_count"))
- (pass-count (db:get-value-by-header row header "pass_count"))
- (db-contour (db:get-value-by-header row header "contour"))
- (contour (if (args:get-arg "-prepend-contour")
- (if (and db-contour (not (equal? db-contour "")) (string? db-contour ))
- (begin
- (debug:print-info 1 *default-log-port* "db-contour")
- db-contour)
- (args:get-arg "-contour"))))
- (run-tag (if (args:get-arg "-run-tag")
- (args:get-arg "-run-tag")
- ""))
- (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
- (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)))
- (if new-run-id
- (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
- (hash-table-set! runs-ht run-id new-run-id)
- ;; ensure key fields are up to date
- ;; if last_update == pgdb_last_update do not update smallest-last-update-time
- (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:refresh-run-info
- dbh
- new-run-id
- state status owner event-time comment fail-count pass-count area-id last-update publish-time)
- (debug:print-info 0 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id )
- (if (not (equal? run-tag ""))
- (task:add-run-tag dbh new-run-id run-tag))
- new-run-id)
-
- (if (equal? state "deleted")
- (begin
- (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
- (if (handle-exceptions
- exn
- (begin (print-call-chain)
- (print ((condition-property-accessor 'exn 'message) exn))
- #f)
-
- (pgdb:insert-run
- dbh
- spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))
- (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
- #f)))))))
-
-(define (task:add-run-tag dbh run-id tag)
- (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
- (if (not tag-info)
- (begin
- (if (handle-exceptions
- exn
- (begin
- (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
- #f)
- (pgdb:insert-tag dbh tag))
- (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
- #f)))
- ;;add to area_tags
- (handle-exceptions
- exn
- (begin
- (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
- #f)
- (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id))
- (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id)))))
-
-
-(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
- ; (print "Sync Steps " test-step-ids )
- (let ((test-ht (hash-table-ref cached-info 'tests))
- (step-ht (hash-table-ref cached-info 'steps)))
- (for-each
- (lambda (test-step-id)
- (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id))
- (step-id (tdb:step-get-id test-step-info))
- (test-id (tdb:step-get-test_id test-step-info))
- (stepname (tdb:step-get-stepname test-step-info))
- (state (tdb:step-get-state test-step-info))
- (status (tdb:step-get-status test-step-info))
- (event_time (tdb:step-get-event_time test-step-info))
- (comment (tdb:step-get-comment test-step-info))
- (logfile (tdb:step-get-logfile test-step-info))
- (last-update (tdb:step-get-last_update test-step-info))
- (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
- (pgdb-step-id (if pgdb-test-id
- (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
- #f)))
- (if step-id
- (begin
- (if pgdb-test-id
- (begin
- (if pgdb-step-id
- (begin
- (debug:print-info 1 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id )
- (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update))
- (begin
- (debug:print-info 1 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id)
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update )
- (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
- (hash-table-set! step-ht step-id pgdb-step-id ))
- (debug:print-info 1 *default-log-port* "Error: Test not cashed")))
- (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug
- test-step-ids)))
-
-(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
- (let ((test-ht (hash-table-ref cached-info 'tests))
- (data-ht (hash-table-ref cached-info 'data)))
- (for-each
- (lambda (test-data-id)
- (let* ((test-data-info (rmt:get-data-info-by-id test-data-id))
- (data-id (db:test-data-get-id test-data-info))
- (test-id (db:test-data-get-test_id test-data-info))
- (category (db:test-data-get-category test-data-info))
- (variable (db:test-data-get-variable test-data-info))
- (value (db:test-data-get-value test-data-info))
- (expected (db:test-data-get-expected test-data-info))
- (tol (db:test-data-get-tol test-data-info))
- (units (db:test-data-get-units test-data-info))
- (comment (db:test-data-get-comment test-data-info))
- (status (db:test-data-get-status test-data-info))
- (type (db:test-data-get-type test-data-info))
- (last-update (db:test-data-get-last_update test-data-info))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
-
- (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
- (pgdb-data-id (if pgdb-test-id
- (pgdb:get-test-data-id dbh pgdb-test-id category variable)
- #f)))
- (if data-id
- (begin
- (if pgdb-test-id
- (begin
- (if pgdb-data-id
- (begin
- (debug:print-info 1 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id)
- (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update))
- (begin
- (debug:print-info 1 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
- (if (handle-exceptions
- exn
- (begin (print-call-chain)
- (print ((condition-property-accessor 'exn 'message) exn))
- #f)
-
- (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update))
- ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
- (begin
- ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))
- #f)))
- (hash-table-set! data-ht data-id pgdb-data-id ))
- (begin
- (debug:print-info 1 *default-log-port* "Error: Test not in pgdb"))))
-
- (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug
- test-data-ids)))
-
-
-
-(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
- (let ((test-ht (hash-table-ref cached-info 'tests)))
- (for-each
- (lambda (test-id)
- ; (print test-id)
- (let* ((test-info (rmt:get-test-info-by-id #f test-id))
- (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm
- (test-id (db:test-get-id test-info))
- (test-name (db:test-get-testname test-info))
- (item-path (db:test-get-item-path test-info))
- (state (db:test-get-state test-info))
- (status (db:test-get-status test-info))
- (host (db:test-get-host test-info))
- (pid (db:test-get-process_id test-info))
- (cpuload (db:test-get-cpuload test-info))
- (diskfree (db:test-get-diskfree test-info))
- (uname (db:test-get-uname test-info))
- (run-dir (db:test-get-rundir test-info))
- (log-file (db:test-get-final_logf test-info))
- (run-duration (db:test-get-run_duration test-info))
- (comment (db:test-get-comment test-info))
- (event-time (db:test-get-event_time test-info))
- (archived (db:test-get-archived test-info))
- (last-update (db:test-get-last_update test-info))
- (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
- (pgdb-test-id (if pgdb-run-id
- (begin
- ;(print pgdb-run-id)
- (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
- #f)))
- ;; "id" "run_id" "testname" "state" "status" "event_time"
- ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
- ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived"
- (if pgdb-run-id
- (begin
- (if pgdb-test-id ;; have a record
- (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
- (debug:print-info 0 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id)
- (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time.
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid))
- (begin
- (debug:print-info 0 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
- (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
- (hash-table-set! test-ht test-id pgdb-test-id))
- (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
- test-ids)))
-
-(define (task:add-area-tag dbh area-info tag)
- (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
- (if (not tag-info)
- (begin
- (if (handle-exceptions
- exn
- (begin
- (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
- #f)
- (pgdb:insert-tag dbh tag))
- (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
- #f)))
- ;;add to area_tags
- (handle-exceptions
- exn
- (begin
- (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
- #f)
- (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))
- (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))))))
-
-(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
- (for-each
- (lambda (run-id)
- (debug:print-info 1 *default-log-port* "Check if run with " run-id " needs to be synced" )
- (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
-run-ids))
-
-
-;; get runs changed since last sync
-;; (define (tasks:sync-test-data dbh cached-info area-info)
-;; (let* ((
-
-(define (tasks:sync-to-postgres configdat dest)
- (print "In sync")
- (let* ((dbh (pgdb:open configdat dbname: dest))
- (area-info (pgdb:get-area-by-path dbh *toppath*))
- (cached-info (make-hash-table))
- (start (current-seconds))
- (test-patt (if (args:get-arg "-testpatt")
- (args:get-arg "-testpatt")
- "%"))
- (target (if (args:get-arg "-target")
- (args:get-arg "-target")
- #f))
- (run-name (if (args:get-arg "-runname")
- (args:get-arg "-runname")
- #f)))
- (if (and target (not run-name))
- (begin
- (print "Error: Provide runname")
- (exit 1)))
- (if (and (not target) run-name)
- (begin
- (print "Error: Provide target")
- (exit 1)))
- ;(print "123")
- ;(exit 1)
- (for-each (lambda (dtype)
- (hash-table-set! cached-info dtype (make-hash-table)))
- '(runs targets tests steps data))
- (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
- (if area-info
- (let* ((last-sync-time (vector-ref area-info 3))
- (smallest-last-update-time (make-hash-table))
- (changed (if (and target run-name)
- (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt)
- (rmt:get-changed-record-ids last-sync-time)))
- (run-ids (alist-ref 'runs changed))
- (test-ids (alist-ref 'tests changed))
- (test-step-ids (alist-ref 'test_steps changed))
- (test-data-ids (alist-ref 'test_data changed))
- (run-stat-ids (alist-ref 'run_stats changed))
- (area-tag (if (args:get-arg "-area-tag")
- (args:get-arg "-area-tag")
- (if (args:get-arg "-area")
- (args:get-arg "-area")
- ""))))
- (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
- (set! area-tag *default-area-tag*))
- (if (not (equal? area-tag ""))
- (task:add-area-tag dbh area-info area-tag))
- (if (or (not (null? test-ids)) (not (null? run-ids)))
- (begin
- (debug:print-info 0 *default-log-port* "syncing runs")
- (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing tests")
- (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing test steps")
- (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing test data")
- (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
- (print "----------done---------------")))
- (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
- (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time)
- (if (not (and target run-name))
- (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0)))
- (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed
- (if (tasks:set-area dbh configdat)
- (tasks:sync-to-postgres configdat dest)
- (begin
- (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
- #f)))))
-
ADDED tasksmod.scm
Index: tasksmod.scm
==================================================================
--- /dev/null
+++ tasksmod.scm
@@ -0,0 +1,1100 @@
+;;======================================================================
+;; 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")
+(include "task_records.scm")
+
+;;======================================================================
+;; Tasks db
+;;======================================================================
+
+;; wait up to aprox n seconds for a journal to go away
+;;
+#;(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f))
+ (if (not (string? path))
+ (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)")
+ (let ((fullpath (conc path "-journal")))
+ (handle-exceptions
+ exn
+ (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))
+ (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
+ #t) ;; if stuff goes wrong just allow it to move on
+ (let loop ((journal-exists (common:file-exists? fullpath))
+ (count n)) ;; wait ten times ...
+ (if journal-exists
+ (begin
+ (if (and waiting-msg
+ (eq? (modulo n 30) 0))
+ (debug:print 0 *default-log-port* waiting-msg))
+ (if (> count 0)
+ (begin
+ (thread-sleep! 1)
+ (loop (common:file-exists? fullpath)
+ (- count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.")
+ (if remove (system (conc "rm -rf " fullpath)))
+ #f)))
+ #t))))))
+
+#;(define (tasks:get-task-db-path)
+ (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir")
+ (configf:lookup *configdat* "setup" "dbdir")
+ (conc (common:get-linktree) "/.db"))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
+ (exit 1))
+ (if (not (directory? dbdir))(create-directory dbdir #t)))
+ dbdir))
+
+;; If file exists AND
+;; file readable
+;; ==> open it
+;; If file exists AND
+;; file NOT readable
+;; ==> open in-mem version
+;; If file NOT exists
+;; ==> open in-mem version
+;;
+#;(define (tasks:open-db alldat #!key (numretries 4))
+
+ (if *task-db*
+ *task-db*
+ (handle-exceptions
+ exn
+ (if (> numretries 0)
+ (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))
+ (thread-sleep! 1)
+ (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 (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?
+ ((and (string? *toppath*)(file-write-access? *toppath*))
+ (sqlite3:open-database dbfile))
+ ((file-read-access? dbpath) (sqlite3:open-database dbfile))
+ (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
+ (handler (make-busy-timeout 36000)))
+ (if (and exists
+ (not write-access))
+ (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
+ (sqlite3:set-busy-handler! mdb handler)
+ (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
+ ;; (if (or (and (not exists)
+ ;; (file-write-access? *toppath*))
+ ;; (not (file-read-access? dbpath)))
+ ;; (begin
+ ;;
+ ;; TASKS QUEUE MOVED TO main.db
+ ;;
+ ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
+ ;; action TEXT DEFAULT '',
+ ;; owner TEXT,
+ ;; state TEXT DEFAULT 'new',
+ ;; target TEXT DEFAULT '',
+ ;; name TEXT DEFAULT '',
+ ;; testpatt TEXT DEFAULT '',
+ ;; keylock TEXT,
+ ;; params TEXT,
+ ;; creation_time TIMESTAMP,
+ ;; execution_time TIMESTAMP);")
+ (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY,
+ pid INTEGER,
+ start_time TIMESTAMP,
+ last_update TIMESTAMP,
+ hostname TEXT,
+ username TEXT,
+ CONSTRAINT monitors_constraint UNIQUE (pid,hostname));")
+ (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY,
+ pid INTEGER,
+ interface TEXT,
+ hostname TEXT,
+ port INTEGER,
+ pubport INTEGER,
+ start_time TIMESTAMP,
+ priority INTEGER,
+ state TEXT,
+ mt_version TEXT,
+ heartbeat TIMESTAMP,
+ transport TEXT,
+ run_id INTEGER);")
+ ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
+ (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
+ server_id INTEGER,
+ pid INTEGER,
+ hostname TEXT,
+ cmdline TEXT,
+ login_time TIMESTAMP,
+ logout_time TIMESTAMP DEFAULT -1,
+ CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
+
+ ;))
+ (set! *task-db* (cons mdb dbpath))
+ *task-db*))))
+
+;;======================================================================
+;; Server and client management
+;;======================================================================
+
+;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
+(define (tasks:hostinfo-get-id vec) (vector-ref vec 0))
+(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1))
+(define (tasks:hostinfo-get-port vec) (vector-ref vec 2))
+(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
+(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4))
+(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
+(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6))
+
+#;(define (tasks:need-server run-id)
+ (equal? (configf:lookup *configdat* "server" "required") "yes"))
+
+;; no elegance here ...
+;;
+#;(define (tasks:kill-server hostname pid #!key (kill-switch ""))
+ (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
+ (setenv "TARGETHOST" hostname)
+ (let* ((logdir (if (directory-exists? "logs")
+ "logs/"
+ ""))
+ (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
+ (gzfile (if logfile (conc logfile ".gz"))))
+ (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
+
+ (system (conc "nbfake kill "kill-switch" "pid))
+
+ (when logfile
+ (thread-sleep! 0.5)
+ (if (common:file-exists? gzfile) (delete-file gzfile))
+ (system (conc "gzip " logfile))
+
+ (unsetenv "TARGETHOST_LOGF")
+ (unsetenv "TARGETHOST"))))
+
+
+;;======================================================================
+;; M O N I T O R S
+;;======================================================================
+
+#;(define (tasks:remove-monitor-record mdb)
+ (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;"
+ (current-process-id)
+ (get-host-name)))
+
+#;(define (tasks:get-monitors mdb)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . rem)
+ (set! res (cons (apply vector a rem) res)))
+ mdb
+ "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;")
+ (reverse res)
+ ))
+
+#;(define (tasks:monitors->text-table monitors)
+ (let ((fmtstr "~4a~8a~20a~20a~10a~10a"))
+ (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n"
+ (string-intersperse
+ (map (lambda (monitor)
+ (format #f fmtstr
+ (tasks:monitor-get-id monitor)
+ (tasks:monitor-get-pid monitor)
+ (tasks:monitor-get-start_time monitor)
+ (tasks:monitor-get-last_update monitor)
+ (tasks:monitor-get-hostname monitor)
+ (tasks:monitor-get-username monitor)))
+ monitors)
+ "\n"))))
+
+;; update the last_update field with the current time and
+;; if any monitors appear dead, remove them
+#;(define (tasks:monitors-update mdb)
+ (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;"
+ (current-process-id)
+ (get-host-name))
+ (let ((deadlist '()))
+ (sqlite3:for-each-row
+ (lambda (id pid host last-update delta)
+ (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago")
+ (set! deadlist (cons id deadlist)))
+ mdb
+ "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;")
+ (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');")))
+ )
+#;(define (tasks:register-monitor db port)
+ (let* ((pid (current-process-id))
+ (hostname (get-host-name))
+ (userinfo (user-information (current-user-id)))
+ (username (car userinfo)))
+ (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
+ (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);"
+ pid hostname username)))
+
+#;(define (tasks:get-num-alive-monitors mdb)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ mdb
+ "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
+ (car (user-information (current-user-id))))
+ res))
+
+;;
+#;(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 (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
+ (let ((modtime (file-modification-time megatestdbpath )))
+ (if (> modtime last-db-update)
+ (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch))
+ ;; WARNING: Possible race conditon here!!
+ ;; should this update be immediately after the task-get-action call above?
+ (if (> (current-seconds) next-touch)
+ (begin
+ (tasks:monitors-update mdb)
+ (loop (+ count 1)(+ (current-seconds) 240)))
+ (loop (+ count 1) next-touch)))))))
+
+;;======================================================================
+;; T A S K S Q U E U E
+;;
+;; NOTE:: These operate on task_queue which is in main.db
+;;
+;;======================================================================
+
+;; NOTE: It might be good to add one more layer of checking to ensure
+;; that no task gets run in parallel.
+
+;; id INTEGER PRIMARY KEY,
+;; action TEXT DEFAULT '',
+;; owner TEXT,
+;; state TEXT DEFAULT 'new',
+;; target TEXT DEFAULT '',
+;; name TEXT DEFAULT '',
+;; testpatt TEXT DEFAULT '',
+;; keylock TEXT,
+;; params TEXT,
+;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
+;; execution_time TIMESTAMP);
+
+
+;; register a task
+#;(define (tasks:add dbstruct action owner target runname testpatt params)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
+ VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);"
+ action
+ owner
+ target
+ runname
+ testpatt
+ (if params params "")))))
+
+#;(define (keys:key-vals-hash->target keys key-params)
+ (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) "")))
+ (if (> (length keys) 1)
+ (for-each (lambda (key)
+ (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) ""))))
+ (cdr keys)))
+ tmp))
+
+;; for use from the gui, not ported
+;;
+;; (define (tasks:add-from-params mdb action keys key-params var-params)
+;; (let ((target (keys:key-vals-hash->target keys key-params))
+;; (owner (car (user-information (current-user-id))))
+;; (runname (hash-table-ref/default var-params "runname" #f))
+;; (testpatts (hash-table-ref/default var-params "testpatts" "%"))
+;; (params (hash-table-ref/default var-params "params" "")))
+;; (tasks:add mdb action owner target runname testpatts params)))
+
+;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old
+;;
+#;(define (tasks:snag-a-task dbstruct)
+ (let ((res #f)
+ (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))
+ (db:with-db
+ dbstruct #f #t
+ (lambda (db)
+ ;; first randomly set a new to pid-hostname-hostname
+ (sqlite3:execute
+ db
+ "UPDATE tasks_queue SET keylock=? WHERE id IN
+ (SELECT id FROM tasks_queue
+ WHERE state='new' OR
+ (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR
+ state='reset'
+ ORDER BY RANDOM() LIMIT 1);" keytxt)
+
+ (sqlite3:for-each-row
+ (lambda (id . rem)
+ (set! res (apply vector id rem)))
+ db
+ "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt)
+ (if res ;; yep, have work to be done
+ (begin
+ (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;"
+ (tasks:task-get-id res))
+ res)
+ #f)))))
+
+#;(define (tasks:reset-stuck-tasks dbstruct)
+ (let ((res '()))
+ (db:with-db
+ dbstruct #f #t
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id delta)
+ (set! res (cons id res)))
+ db
+ "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
+ (sqlite3:execute
+ db
+ (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');")
+ )))))
+
+;; return all tasks in the tasks_queue table
+;;
+#;(define (tasks:get-tasks dbstruct types states)
+ (let ((res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id . rem)
+ (set! res (cons (apply vector id rem) res)))
+ db
+ (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time
+ FROM tasks_queue "
+ ;; WHERE
+ ;; state IN " statesstr " AND
+ ;; action IN " actionsstr
+ " ORDER BY creation_time DESC;"))
+ res))))
+
+#;(define (tasks:get-last dbstruct target runname)
+ (let ((res #f))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id . rem)
+ (set! res (apply vector id rem)))
+ db
+ (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time
+ FROM tasks_queue
+ WHERE
+ target = ? AND name =?
+ ORDER BY creation_time DESC LIMIT 1;")
+ target runname)
+ res))))
+
+;; remove tasks given by a string of numbers comma separated
+#;(define (tasks:remove-queue-entries dbstruct task-ids)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
+
+#;(define (tasks:process-queue dbstruct)
+ (let* ((task (tasks:snag-a-task dbstruct))
+ (action (if task (tasks:task-get-action task) #f)))
+ (if action (print "tasks:process-queue task: " task))
+ (if action
+ (case (string->symbol action)
+ ((run) (tasks:start-run dbstruct task))
+ ((remove) (tasks:remove-runs dbstruct task))
+ ((lock) (tasks:lock-runs dbstruct task))
+ ;; ((monitor) (tasks:start-monitor db task))
+ ((rollup) (tasks:rollup-runs dbstruct task))
+ ((updatemeta)(tasks:update-meta dbstruct task))
+ ((kill) (tasks:kill-monitors dbstruct task))))))
+
+#;(define (tasks:tasks->text tasks)
+ (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
+ (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
+ (string-intersperse
+ (map (lambda (task)
+ (format #f fmtstr
+ (tasks:task-get-id task)
+ (tasks:task-get-action task)
+ (tasks:task-get-owner task)
+ (tasks:task-get-state task)
+ (tasks:task-get-target task)
+ (tasks:task-get-name task)
+ (tasks:task-get-test task)
+ ;; (tasks:task-get-item task)
+ (tasks:task-get-params task)))
+ tasks) "\n"))))
+
+#;(define (tasks:set-state dbstruct task-id state)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;"
+ state
+ task-id))))
+
+;;======================================================================
+;; Access using task key (stored in params; (hash-table->alist flags) hostname pid
+;;======================================================================
+
+#;(define (tasks:param-key->id dbstruct task-params)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;"
+ task-params)))))
+
+#;(define (tasks:set-state-given-param-key dbstruct param-key new-state)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key))))
+
+#;(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (handle-exceptions
+ exn
+ '()
+ (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE
+ params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
+ param-key state-patt action-patt test-patt)))))
+
+#;(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
+ ;; (handle-exceptions
+ ;; exn
+ ;; '()
+ ;; (sqlite3:first-row
+ (let ((db (db:delay-if-busy (db:get-db dbstruct)))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (cons a b) res)))
+ db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
+ WHERE
+ target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
+ target run-name state-patt action-patt test-patt)
+ res)) ;; )
+
+;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
+;;
+;; do a remote call to get the task queue info but do the killing as self here.
+;;
+#;(define (tasks:kill-runner target run-name testpatt)
+ (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests"))
+ (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
+ (if (null? records)
+ (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
+ (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill."))
+ (for-each
+ (lambda (record)
+ (let* ((param-key (list-ref record 8))
+ (match-dat (string-search hostpid-rx param-key)))
+ (if match-dat
+ (let ((hostname (cadr match-dat))
+ (pid (string->number (caddr match-dat))))
+ (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname)
+ (if (equal? (get-host-name) hostname)
+ (if (process:alive? pid)
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ #t)
+ (process-signal pid signal/int)
+ (thread-sleep! 5)
+ (if (process:alive? pid)
+ (process-signal pid signal/kill)))))
+ ;; (call-with-environment-variables
+ (let ((old-targethost (getenv "TARGETHOST")))
+ (setenv "TARGETHOST" hostname)
+ (setenv "TARGETHOST_LOGF" "server-kills.log")
+ (system (conc "nbfake kill " pid))
+ (if old-targethost (setenv "TARGETHOST" old-targethost))
+ (unsetenv "TARGETHOST")
+ (unsetenv "TARGETHOST_LOGF"))))
+ (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
+ records)))
+
+;; (define (tasks:start-run dbstruct mdb task)
+;; (let ((flags (make-hash-table)))
+;; (hash-table-set! flags "-rerun" "NOT_STARTED")
+;; (if (not (string=? (tasks:task-get-params task) ""))
+;; (hash-table-set! flags "-setvars" (tasks:task-get-params task)))
+;; (print "Starting run " task)
+;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
+;; (runs:run-tests db
+;; (tasks:task-get-target task)
+;; (tasks:task-get-name task)
+;; (tasks:task-get-test task)
+;; (tasks:task-get-item task)
+;; (tasks:task-get-owner task)
+;; flags)
+;; (tasks:set-state mdb (tasks:task-get-id task) "waiting")))
+;;
+;; (define (tasks:rollup-runs db mdb task)
+;; (let* ((flags (make-hash-table))
+;; (keys (db:get-keys db))
+;; (keyvals (keys:target-keyval keys (tasks:task-get-target task))))
+;; ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
+;; (print "Starting rollup " task)
+;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
+;; (runs:rollup-run db
+;; keys
+;; keyvals
+;; (tasks:task-get-name task)
+;; (tasks:task-get-owner task))
+;; (tasks:set-state mdb (tasks:task-get-id task) "waiting")))
+
+;;======================================================================
+;; S Y N C T O P O S T G R E S Q L
+;;======================================================================
+
+;; In the spirit of "dump your junk in the tasks module" I'll put the
+;; sync to postgres here for now.
+
+;; 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 *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))
+ #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception
+ (pgdb:add-area dbh area-name (or toppath *toppath*)))))
+ (or success
+ (case modifier
+ ((none)(loop (conc (current-user-name) "_" area-name) 'user))
+ ((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
+ area-name) 'areasig))
+ (else #f)))))) ;; give up
+
+#;(define (task:print-runtime run-times saperator)
+(for-each
+ (lambda (run-time-info)
+ (let* ((run-name (vector-ref run-time-info 0))
+ (run-time (vector-ref run-time-info 1))
+ (target (vector-ref run-time-info 2)))
+ (print target saperator run-name saperator run-time )))
+ run-times))
+
+#;(define (task:print-runtime-as-json run-times)
+ (let loop ((run-time-info (car run-times))
+ (rema (cdr run-times))
+ (str ""))
+ (let* ((run-name (vector-ref run-time-info 0))
+ (run-time (vector-ref run-time-info 1))
+ (target (vector-ref run-time-info 2)))
+ ;(print (not (equal? str "")))
+ (if (not (equal? str ""))
+ (set! str (conc str ",")))
+ (if (null? rema)
+ (print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]")
+ (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}"))))))
+
+#;(define (task:get-run-times)
+ (let* (
+ (run-patt (if (args:get-arg "-run-patt")
+ (args:get-arg "-run-patt")
+ "%"))
+ (target-patt (if (args:get-arg "-target-patt")
+ (args:get-arg "-target-patt")
+ "%"))
+
+ (run-times (rmt:get-run-times run-patt target-patt )))
+ (if (eq? (length run-times) 0)
+ (begin
+ (print "Data not found!!")
+ (exit)))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (task:print-runtime-as-json run-times)
+ (if (equal? (args:get-arg "-dumpmode") "csv")
+ (task:print-runtime run-times ",")
+ (task:print-runtime run-times " ")))))
+
+
+#;(define (task:print-testtime test-times saperator)
+(for-each
+ (lambda (test-time-info)
+ (let* ((test-name (vector-ref test-time-info 0))
+ (test-time (vector-ref test-time-info 2))
+ (test-item (if (eq? (string-length (vector-ref test-time-info 1)) 0)
+ "N/A"
+ (vector-ref test-time-info 1))))
+ (print test-name saperator test-item saperator test-time )))
+ test-times))
+
+#;(define (task:print-testtime-as-json test-times)
+ (let loop ((test-time-info (car test-times))
+ (rema (cdr test-times))
+ (str ""))
+ (let* ((test-name (vector-ref test-time-info 0))
+ (test-time (vector-ref test-time-info 2))
+ (item (vector-ref test-time-info 1)))
+ ;(print (not (equal? str "")))
+ (if (not (equal? str ""))
+ (set! str (conc str ",")))
+ (if (null? rema)
+ (print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]")
+ (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}"))))))
+
+
+#; (define (task:get-test-times)
+ (let* ((runname (if (args:get-arg "-runname")
+ (args:get-arg "-runname")
+ #f))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ #f))
+
+ (test-times (rmt:get-test-times runname target )))
+ (if (not runname)
+ (begin
+ (print "Error: Missing argument -runname")
+ (exit)))
+ (if (string-contains runname "%")
+ (begin
+ (print "Error: Invalid runname, '%' not allowed (" runname ") ")
+ (exit)))
+ (if (not target)
+ (begin
+ (print "Error: Missing argument -target")
+ (exit)))
+ (if (string-contains target "%")
+ (begin
+ (print "Error: Invalid target, '%' not allowed (" target ") ")
+ (exit)))
+
+ (if (eq? (length test-times) 0)
+ (begin
+ (print "Data not found!!")
+ (exit)))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (task:print-testtime-as-json test-times)
+ (if (equal? (args:get-arg "-dumpmode") "csv")
+ (task:print-testtime test-times ",")
+ (task:print-testtime test-times " ")))))
+
+
+
+;; gets mtpg-run-id and syncs the record if different
+;;
+#;(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
+ (let* ((runs-ht (hash-table-ref cached-info 'runs))
+ (runinf (hash-table-ref/default runs-ht run-id #f))
+ (area-id (vector-ref area-info 0)))
+ (if runinf
+ runinf ;; already cached
+ (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header >
+ (run-name (rmt:get-run-name-from-id run-id))
+ (row (db:get-rows run-dat)) ;; yes, this returns a single row
+ (header (db:get-header run-dat))
+ (state (db:get-value-by-header row header "state"))
+ (status (db:get-value-by-header row header "status"))
+ (owner (db:get-value-by-header row header "owner"))
+ (event-time (db:get-value-by-header row header "event_time"))
+ (comment (db:get-value-by-header row header "comment"))
+ (fail-count (db:get-value-by-header row header "fail_count"))
+ (pass-count (db:get-value-by-header row header "pass_count"))
+ (db-contour (db:get-value-by-header row header "contour"))
+ (contour (if (args:get-arg "-prepend-contour")
+ (if (and db-contour (not (equal? db-contour "")) (string? db-contour ))
+ (begin
+ (debug:print-info 1 *default-log-port* "db-contour")
+ db-contour)
+ (args:get-arg "-contour"))))
+ (run-tag (if (args:get-arg "-run-tag")
+ (args:get-arg "-run-tag")
+ ""))
+ (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 *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)))
+ (if new-run-id
+ (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
+ (hash-table-set! runs-ht run-id new-run-id)
+ ;; ensure key fields are up to date
+ ;; if last_update == pgdb_last_update do not update smallest-last-update-time
+ (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:refresh-run-info
+ dbh
+ new-run-id
+ state status owner event-time comment fail-count pass-count area-id last-update publish-time)
+ (debug:print-info 0 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id )
+ (if (not (equal? run-tag ""))
+ (task:add-run-tag dbh new-run-id run-tag))
+ new-run-id)
+
+ (if (equal? state "deleted")
+ (begin
+ (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
+ (if (handle-exceptions
+ exn
+ (begin (print-call-chain)
+ (print ((condition-property-accessor 'exn 'message) exn))
+ #f)
+
+ (pgdb:insert-run
+ dbh
+ spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))
+ (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
+ #f)))))))
+
+#;(define (task:add-run-tag dbh run-id tag)
+ (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
+ (if (not tag-info)
+ (begin
+ (if (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ (pgdb:insert-tag dbh tag))
+ (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
+ #f)))
+ ;;add to area_tags
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id))
+ (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id)))))
+
+
+#;(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
+ ; (print "Sync Steps " test-step-ids )
+ (let ((test-ht (hash-table-ref cached-info 'tests))
+ (step-ht (hash-table-ref cached-info 'steps)))
+ (for-each
+ (lambda (test-step-id)
+ (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id))
+ (step-id (tdb:step-get-id test-step-info))
+ (test-id (tdb:step-get-test_id test-step-info))
+ (stepname (tdb:step-get-stepname test-step-info))
+ (state (tdb:step-get-state test-step-info))
+ (status (tdb:step-get-status test-step-info))
+ (event_time (tdb:step-get-event_time test-step-info))
+ (comment (tdb:step-get-comment test-step-info))
+ (logfile (tdb:step-get-logfile test-step-info))
+ (last-update (tdb:step-get-last_update test-step-info))
+ (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
+ (pgdb-step-id (if pgdb-test-id
+ (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
+ #f)))
+ (if step-id
+ (begin
+ (if pgdb-test-id
+ (begin
+ (if pgdb-step-id
+ (begin
+ (debug:print-info 1 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id )
+ (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update))
+ (begin
+ (debug:print-info 1 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id)
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update )
+ (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
+ (hash-table-set! step-ht step-id pgdb-step-id ))
+ (debug:print-info 1 *default-log-port* "Error: Test not cashed")))
+ (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug
+ test-step-ids)))
+
+#;(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
+ (let ((test-ht (hash-table-ref cached-info 'tests))
+ (data-ht (hash-table-ref cached-info 'data)))
+ (for-each
+ (lambda (test-data-id)
+ (let* ((test-data-info (rmt:get-data-info-by-id test-data-id))
+ (data-id (db:test-data-get-id test-data-info))
+ (test-id (db:test-data-get-test_id test-data-info))
+ (category (db:test-data-get-category test-data-info))
+ (variable (db:test-data-get-variable test-data-info))
+ (value (db:test-data-get-value test-data-info))
+ (expected (db:test-data-get-expected test-data-info))
+ (tol (db:test-data-get-tol test-data-info))
+ (units (db:test-data-get-units test-data-info))
+ (comment (db:test-data-get-comment test-data-info))
+ (status (db:test-data-get-status test-data-info))
+ (type (db:test-data-get-type test-data-info))
+ (last-update (db:test-data-get-last_update test-data-info))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
+
+ (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
+ (pgdb-data-id (if pgdb-test-id
+ (pgdb:get-test-data-id dbh pgdb-test-id category variable)
+ #f)))
+ (if data-id
+ (begin
+ (if pgdb-test-id
+ (begin
+ (if pgdb-data-id
+ (begin
+ (debug:print-info 1 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id)
+ (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update))
+ (begin
+ (debug:print-info 1 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
+ (if (handle-exceptions
+ exn
+ (begin (print-call-chain)
+ (print ((condition-property-accessor 'exn 'message) exn))
+ #f)
+
+ (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update))
+ ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
+ (begin
+ ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))
+ #f)))
+ (hash-table-set! data-ht data-id pgdb-data-id ))
+ (begin
+ (debug:print-info 1 *default-log-port* "Error: Test not in pgdb"))))
+
+ (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug
+ test-data-ids)))
+
+
+
+#;(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
+ (let ((test-ht (hash-table-ref cached-info 'tests)))
+ (for-each
+ (lambda (test-id)
+ ; (print test-id)
+ (let* ((test-info (rmt:get-test-info-by-id #f test-id))
+ (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm
+ (test-id (db:test-get-id test-info))
+ (test-name (db:test-get-testname test-info))
+ (item-path (db:test-get-item-path test-info))
+ (state (db:test-get-state test-info))
+ (status (db:test-get-status test-info))
+ (host (db:test-get-host test-info))
+ (pid (db:test-get-process_id test-info))
+ (cpuload (db:test-get-cpuload test-info))
+ (diskfree (db:test-get-diskfree test-info))
+ (uname (db:test-get-uname test-info))
+ (run-dir (db:test-get-rundir test-info))
+ (log-file (db:test-get-final_logf test-info))
+ (run-duration (db:test-get-run_duration test-info))
+ (comment (db:test-get-comment test-info))
+ (event-time (db:test-get-event_time test-info))
+ (archived (db:test-get-archived test-info))
+ (last-update (db:test-get-last_update test-info))
+ (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
+ (pgdb-test-id (if pgdb-run-id
+ (begin
+ ;(print pgdb-run-id)
+ (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
+ #f)))
+ ;; "id" "run_id" "testname" "state" "status" "event_time"
+ ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
+ ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived"
+ (if pgdb-run-id
+ (begin
+ (if pgdb-test-id ;; have a record
+ (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
+ (debug:print-info 0 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id)
+ (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time.
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid))
+ (begin
+ (debug:print-info 0 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
+ (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
+ (hash-table-set! test-ht test-id pgdb-test-id))
+ (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
+ test-ids)))
+
+#;(define (task:add-area-tag dbh area-info tag)
+ (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
+ (if (not tag-info)
+ (begin
+ (if (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ (pgdb:insert-tag dbh tag))
+ (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
+ #f)))
+ ;;add to area_tags
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))
+ (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))))))
+
+#;(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
+ (for-each
+ (lambda (run-id)
+ (debug:print-info 1 *default-log-port* "Check if run with " run-id " needs to be synced" )
+ (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
+run-ids))
+
+
+;; get runs changed since last sync
+;; (define (tasks:sync-test-data dbh cached-info area-info)
+;; (let* ((
+
+#;(define (tasks:sync-to-postgres configdat dest)
+ (print "In sync")
+ (let* ((dbh (pgdb:open configdat dbname: dest))
+ (area-info (pgdb:get-area-by-path dbh *toppath*))
+ (cached-info (make-hash-table))
+ (start (current-seconds))
+ (test-patt (if (args:get-arg "-testpatt")
+ (args:get-arg "-testpatt")
+ "%"))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ #f))
+ (run-name (if (args:get-arg "-runname")
+ (args:get-arg "-runname")
+ #f)))
+ (if (and target (not run-name))
+ (begin
+ (print "Error: Provide runname")
+ (exit 1)))
+ (if (and (not target) run-name)
+ (begin
+ (print "Error: Provide target")
+ (exit 1)))
+ ;(print "123")
+ ;(exit 1)
+ (for-each (lambda (dtype)
+ (hash-table-set! cached-info dtype (make-hash-table)))
+ '(runs targets tests steps data))
+ (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
+ (if area-info
+ (let* ((last-sync-time (vector-ref area-info 3))
+ (smallest-last-update-time (make-hash-table))
+ (changed (if (and target run-name)
+ (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt)
+ (rmt:get-changed-record-ids last-sync-time)))
+ (run-ids (alist-ref 'runs changed))
+ (test-ids (alist-ref 'tests changed))
+ (test-step-ids (alist-ref 'test_steps changed))
+ (test-data-ids (alist-ref 'test_data changed))
+ (run-stat-ids (alist-ref 'run_stats changed))
+ (area-tag (if (args:get-arg "-area-tag")
+ (args:get-arg "-area-tag")
+ (if (args:get-arg "-area")
+ (args:get-arg "-area")
+ ""))))
+ (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
+ (set! area-tag *default-area-tag*))
+ (if (not (equal? area-tag ""))
+ (task:add-area-tag dbh area-info area-tag))
+ (if (or (not (null? test-ids)) (not (null? run-ids)))
+ (begin
+ (debug:print-info 0 *default-log-port* "syncing runs")
+ (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing tests")
+ (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing test steps")
+ (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing test data")
+ (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
+ (print "----------done---------------")))
+ (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
+ (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time)
+ (if (not (and target run-name))
+ (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0)))
+ (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed
+ (if (tasks:set-area dbh configdat)
+ (tasks:sync-to-postgres configdat dest)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
+ #f)))))
+
+
+)
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")
+
+
+)