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 \ @@ -164,11 +164,11 @@ dcommon.o : run_records.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) : 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 Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -23,115 +23,15 @@ (declare (unit api)) (declare (uses rmt)) (declare (uses db)) (declare (uses tasks)) -;; allow these queries through without starting a server -;; -(define api:read-only-queries - '(get-key-val-pairs - get-var - get-keys - get-key-vals - test-toplevel-num-items - get-test-info-by-id - get-steps-info-by-id - get-data-info-by-id - test-get-rundir-from-test-id - get-count-tests-running-for-testname - get-count-tests-running - get-count-tests-running-in-jobgroup - get-previous-test-run-record - get-matching-previous-test-run-records - test-get-logfile-info - test-get-records-for-index-file - get-testinfo-state-status - test-get-top-process-pid - test-get-paths-matching-keynames-target-new - get-prereqs-not-met - get-count-tests-running-for-run-id - get-run-info - get-run-status - get-run-state - get-run-stats - get-run-times - get-targets - get-target - ;; register-run - get-tests-tags - get-test-times - get-tests-for-run - get-test-id - get-tests-for-runs-mindata - get-tests-for-run-mindata - get-run-name-from-id - get-runs - simple-get-runs - get-num-runs - get-runs-cnt-by-patt - get-all-run-ids - get-prev-run-ids - get-run-ids-matching-target - get-runs-by-patt - get-steps-data - get-steps-for-test - read-test-data - read-test-data* - login - tasks-get-last - testmeta-get-record - have-incompletes? - synchash-get - get-changed-record-ids - get-run-record-ids - get-not-completed-cnt)) - -(define api:write-queries - '( - get-keys-write ;; dummy "write" query to force server start - - ;; SERVERS - start-server - kill-server - - ;; TESTS - test-set-state-status-by-id - delete-test-records - delete-old-deleted-test-records - test-set-state-status - test-set-top-process-pid - set-state-status-and-roll-up-items - - update-pass-fail-counts - top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") - - ;; RUNS - register-run - set-tests-state-status - delete-run - lock/unlock-run - update-run-event_time - mark-incomplete - set-state-status-and-roll-up-run - ;; STEPS - teststep-set-status! - delete-steps-for-test - ;; TEST DATA - test-data-rollup - csv->test-data - - ;; MISC - sync-inmem->db - - ;; TESTMETA - testmeta-add-record - testmeta-update-field - - ;; TASKS - tasks-add - tasks-set-state-given-param-key - )) +(declare (uses apimod)) +(import apimod) + +;; api:read-only-queries and api:execute-requests have been moved into common_records + ;; These are called by the server on recipt of /api calls ;; - keep it simple, only return the actual result of the call, i.e. no meta info here ;; ;; - returns #( flag result ) @@ -159,11 +59,11 @@ (params (vector-ref dat 1)) (start-t (current-milliseconds)) (readonly-mode (dbr:dbstruct-read-only dbstruct)) (readonly-command (member cmd api:read-only-queries)) (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - (foo (begin + #;(foo (begin (common:telemetry-log (conc "api-in:"(->string cmd)) payload: `((params . ,params))) #t)) (res @@ -329,12 +229,12 @@ (run-id (cadr params)) (realparams (cddr params))) (db:general-call dbstruct stmtname realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ;; TASKS ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) ADDED apimod.scm Index: apimod.scm ================================================================== --- /dev/null +++ apimod.scm @@ -0,0 +1,35 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit apimod)) +(declare (uses commonmod)) + +(module apimod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import commonmod) +;; (use (prefix ulex ulex:)) + +(include "common_records.scm") + + +) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -132,11 +132,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)) (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 +255,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) "-" 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 +343,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) "-" 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 @@ -54,12 +54,15 @@ (else (rpc: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)) + ((http)(client:setup-http *alldat* 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)))) + +(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. @@ -70,11 +73,11 @@ ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; -(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 +84,37 @@ (exit 1)) ;; ;; Alternatively here, we can get the list of candidate servers and work our way ;; through them searching for a good one. ;; - (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) - (runremote (or area-dat *runremote*))) + (let* ((server-dat (server:get-rand-best areapath))) ;; (server:get-first-best areapath)) (if (not server-dat) ;; no server found - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + (client:setup-http runremote areapath remaining-tries: (- remaining-tries 1)) (let ((host (cadr server-dat)) (port (caddr server-dat))) (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if (and (not area-dat) - (not *runremote*)) - (set! *runremote* (make-remote))) (if (and host port) (let* ((start-res (case *transport-type* ((http)(http-transport:client-connect host port)))) (ping-res (case *transport-type* ((http)(rmt:login-no-auto-client-setup start-res))))) (if (and start-res ping-res) - (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago - (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) + (begin + (alldat-conndat-set! runremote start-res) (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 (case *transport-type* ((http)(http-transport:close-connections))) - (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) + (alldat-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) (thread-sleep! 1) - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + (client:setup-http runremote areapath remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered ;; (server:kind-run areapath) (server:start-and-wait areapath) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) + (client:setup-http runremote areapath remaining-tries: (- remaining-tries 1))))))))) ADDED clientmod.scm Index: clientmod.scm ================================================================== --- /dev/null +++ clientmod.scm @@ -0,0 +1,35 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit clientmod)) +(declare (uses commonmod)) + +(module clientmod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import commonmod) +;; (use (prefix ulex ulex:)) + +(include "common_records.scm") + + +) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -158,11 +158,10 @@ (define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg -(define *runremote* #f) ;; if set up for server communication this will hold ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) @@ -270,21 +269,10 @@ (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) -(defstruct remote - (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) - (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) - (last-server-check 0) ;; last time we checked to see if the server was alive - (conndat #f) - (transport *transport-type*) - (server-timeout (server:expiration-timeout)) - (force-server #f) - (ro-mode #f) - (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode - ;; launching and hosts (defstruct host (reachable #f) (last-update 0) (last-used 0) @@ -359,13 +347,12 @@ (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) - -(define (common:get-sync-lock-filepath) - (let* ((tmp-area (common:get-db-tmp-area)) +(define (common:get-sync-lock-filepath alldat) + (let* ((tmp-area (common:get-db-tmp-area alldat)) (lockfile (conc tmp-area "/megatest.db.sync-lock"))) lockfile)) ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma @@ -857,37 +844,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 +956,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 +1062,10 @@ (pathname-directory (pathname-directory (pathname-directory exe-path)))) #f))) -;; return first path that can be created or already exists and is writable -;; -(define (common:get-create-writeable-dir dirs) - (if (null? dirs) - #f - (let loop ((hed (car dirs)) - (tal (cdr dirs))) - (let ((res (or (and (directory? hed) - (file-write-access? hed) - hed) - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") - #f) - (create-directory hed #t))))) - (if (and (string? res) - (directory? res)) - res - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - ;; return the youngest timestamp . filename ;; (define (common:get-youngest glob-list) (let ((all-files (apply append (map (lambda (patt) @@ -2058,17 +1991,18 @@ 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 ;; Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -17,12 +17,218 @@ ;; 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 + (areapath #f) ;; i.e. toppath + (mtconfig #f) + (log-port #f) + (areadat #f) ;; i.e. runremote + (rmt-mutex (make-mutex)) + (db-sync-mutex (make-mutex)) + (read-only-queries api:read-only-queries) + (write-queries api:write-queries) + + ;; 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 + ) + +(define *alldat* (make-alldat)) ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; @@ -80,11 +286,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 +297,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 +327,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 +424,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 +441,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 @@ -22,11 +22,75 @@ (module commonmod * (import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 ports srfi-1 files format) + +(include "common_records.scm") + +(define (db:dbdat-get-path dbdat) + (if (pair? dbdat) + (cdr dbdat) + #f)) + +(define (common:get-area-name alldat) + (let* ((configdat (alldat-mtconfig alldat)) + (areapath (alldat-areapath alldat))) + (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_TESTSUITE_NAME") + (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 + (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 alldat dbpath) + dbpath)) + #f)))) ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) ;; ;; (define (set-functions dbgp dbgpinfo) ADDED configfmod.scm Index: configfmod.scm ================================================================== --- /dev/null +++ configfmod.scm @@ -0,0 +1,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 configfmod)) +(declare (uses commonmod)) + +(module configfmod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import commonmod) +;; (use (prefix ulex ulex:)) + +(include "common_records.scm") + + +) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -452,12 +452,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 @@ -379,12 +379,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 +511,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 +604,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) @@ -105,27 +112,16 @@ ;; 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)))) + (let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area *alldat*)))) ;; (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 ;; @@ -197,11 +193,11 @@ ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; ;; If run-id is #f return to create and retrieve the path where the db will live. ;; -(define db:dbfile-path common:get-db-tmp-area) +;; (define db:dbfile-path common:get-db-tmp-area) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) @@ -284,11 +280,11 @@ (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 + (dbpath (common:get-db-tmp-area *alldat* )) ;; path to tmp db area (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) @@ -304,13 +300,19 @@ ;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")) + (handle-exceptions + exn + (let ((call-chain (get-call-chain)) + (msg ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 *default-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 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) (if (and dbexists (not write-access)) (begin @@ -1930,11 +1932,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) @@ -2241,11 +2243,11 @@ res)) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) + (let* ((dbdir (common:get-db-tmp-area *alldat*)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates @@ -4744,6 +4746,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 db:setup) ADDED dbmod.scm Index: dbmod.scm ================================================================== --- /dev/null +++ dbmod.scm @@ -0,0 +1,41 @@ +;;====================================================================== +;; 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)) + +(module dbmod + * + +(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") + +;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? +(define (db:dbdat-get-db dbdat) + (if (pair? dbdat) + (car dbdat) + dbdat)) + + +) 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") + + +) 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") + + +) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -68,11 +68,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 +240,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 +269,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 +316,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 +335,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 +355,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 +515,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 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") + + +) ADDED keysmod.scm Index: keysmod.scm ================================================================== --- /dev/null +++ keysmod.scm @@ -0,0 +1,35 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit keysmod)) +(declare (uses commonmod)) + +(module keysmod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import commonmod) +;; (use (prefix ulex ulex:)) + +(include "common_records.scm") + + +) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -735,11 +735,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)))) ;;(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) @@ -1185,11 +1185,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))) (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 +1540,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) ":" 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)))) @@ -1593,11 +1593,11 @@ (car hhdat) #f))) (list 'serverurl (if *runremote* (remote-server-url *runremote*) #f)) ;; - (list 'areaname (common:get-testsuite-name)) + (list 'areaname (common:get-area-name)) (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: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -45,10 +45,13 @@ (declare (uses genexample)) ;; (declare (uses daemon)) (declare (uses db)) ;; (declare (uses dcommon)) +(declare (uses commonmod)) +(declare (uses rmtmod)) + (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) @@ -608,11 +611,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)) 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 processmod.scm Index: processmod.scm ================================================================== --- /dev/null +++ processmod.scm @@ -0,0 +1,35 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit processmod)) +(declare (uses commonmod)) + +(module processmod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import commonmod) +;; (use (prefix ulex ulex:)) + +(include "common_records.scm") + + +) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -22,13 +22,27 @@ (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (include "common_records.scm") + (declare (uses rmtmod)) - (import rmtmod) +(declare (uses commonmod)) +(import commonmod) + +(set-fn 'server:expiration-timeout server:expiration-timeout) +(set-fn 'common:get-homehost common:get-homehost) +(set-fn 'server:check-if-running server:check-if-running) +(set-fn 'api:execute-requests api:execute-requests) +(set-fn 'http-transport:close-connections http-transport:close-connections ) +(set-fn 'http-transport:client-api-send-receive http-transport:client-api-send-receive) +(set-fn 'server:kind-run server:kind-run) +(set-fn 'server:start-and-wait server:start-and-wait) +(set-fn 'server:check-if-running server:check-if-running) +(set-fn 'server:ping server:ping ) +(set-fn 'common:force-server? common:force-server? ) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; @@ -38,247 +52,50 @@ ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== -;; if a server is either running or in the process of starting call client:setup -;; else return #f to let the calling proc know that there is no server available -;; -(define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. - (let* ((runremote (or area-dat *runremote*)) - (cinfo (if (remote? runremote) - (remote-conndat runremote) - #f))) - (if cinfo - cinfo - (if (server:check-if-running areapath) - (client:setup areapath) - #f)))) - (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id -;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) -;; -(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected - - (common:telemetry-log (conc "rmt:"(->string cmd)) - payload: `((rid . ,rid) - (params . ,params))) - - - ;;DOT digraph megatest_state_status { - ;;DOT ranksep=0; - ;;DOT // rankdir=LR; - ;;DOT node [shape="box"]; - ;;DOT "rmt:send-receive" -> MUTEXLOCK; - ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; } - ;; do all the prep locked under the rmt-mutex - (mutex-lock! *rmt-mutex*) - - ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote - ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. - ;; 3. do the query, if on homehost use local access - ;; - (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value - (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas - (runremote (or area-dat - *runremote*)) - (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*))) - - ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity - ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; - ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; +;; (define *runremote* (make-remote)) + +;; this entry point can decide based on cmd whether to dispatch to old api calls via remote or via ulex +;; +(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) + (let* ((areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas + (alldat (or area-dat + *alldat*))) ;; ensure we have a record for our connection for given area - (if (not runremote) ;; can remove this one. should never get here. + (if (not (alldat-hh-dat alldat)) + (begin + (alldat-server-timeout-set! alldat (server:expiration-timeout)) + (alldat-hh-dat-set! alldat (common:get-homehost)) + )) ;; new alldat will come from this on next iteration + + ;; ensure we have a homehost record and mtconfig, do this here instead of in -orig + (if (or (not (alldat-mtconfig *alldat*)) + (not (alldat-hh-dat alldat)) + (not (pair? (alldat-hh-dat alldat)))) ;; not on homehost + (begin + (alldat-hh-dat-set! alldat (common:get-homehost)) + (alldat-mtconfig-set! *alldat* *configdat*) + (alldat-areapath-set! *alldat* *toppath*) + (alldat-areadat-set! *alldat* alldat) ;; TODO: converge usage of alldat and area-dat + )) + + (if (member cmd '(blah)) (begin - (set! *runremote* (make-remote)) - (set! runremote *runremote*))) ;; new runremote will come from this on next iteration - - ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity - ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"]; - ;; DOT SET_HOMEHOST -> MUTEXLOCK; - ;; ensure we have a homehost record - (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost - (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little - (remote-hh-dat-set! runremote (common:get-homehost))) - - ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) - (cond - ;;DOT EXIT; - ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" } - ;; give up if more than 15 attempts - ((> attemptnum 15) - (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") - (exit 1)) - - ;;DOT CASE2 [label="local\nreadonly\nquery"]; - ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2} - ;;DOT CASE2 -> "rmt:open-qry-close-locally"; - ;; readonly mode, read request- handle it - case 2 - ((and readonly-mode - (member cmd api:read-only-queries)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2") - (rmt:open-qry-close-locally cmd 0 params) - ) - - ;;DOT CASE3 [label="write in\nread-only mode"]; - ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3} - ;;DOT CASE3 -> "#f"; - ;; readonly mode, write request. Do nothing, return #f - (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params)) - - ;; This block was for pre-emptively resetting the connection if there had been no communication for some time. - ;; I don't think it adds any value. If the server is not there, just fail and start a new connection. - ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout) - ;; - ;;DOT CASE4 [label="reset\nconnection"]; - ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} - ;;DOT CASE4 -> "rmt:send-receive"; - ;; reset the connection if it has been unused too long - ((and runremote - (remote-conndat runremote) - (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on - (+ (http-transport:server-dat-get-last-access (remote-conndat runremote)) - (remote-server-timeout runremote)))) - (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") - (http-transport:close-connections area-dat: runremote) - (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. - (mutex-unlock! *rmt-mutex*) - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - - ;;DOT CASE5 [label="local\nread"]; - ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5}; - ;;DOT CASE5 -> "rmt:open-qry-close-locally"; - - ;; on homehost and this is a read - ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required - (cdr (remote-hh-dat runremote)) ;; on homehost - (member cmd api:read-only-queries)) ;; this is a read - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") - (rmt:open-qry-close-locally cmd 0 params)) - - ;;DOT CASE6 [label="init\nremote"]; - ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6}; - ;;DOT CASE6 -> "rmt:send-receive"; - ;; on homehost and this is a write, we already have a server, but server has died - ((and (cdr (remote-hh-dat runremote)) ;; on homehost - (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url runremote) ;; have a server - (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. - (set! *runremote* (make-remote)) - (remote-force-server-set! runremote (common:force-server?)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - - ;;DOT CASE7 [label="homehost\nwrite"]; - ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7}; - ;;DOT CASE7 -> "rmt:open-qry-close-locally"; - ;; on homehost and this is a write, we already have a server - ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required - (cdr (remote-hh-dat runremote)) ;; on homehost - (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url runremote)) ;; have a server - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") - (rmt:open-qry-close-locally cmd 0 params)) - - ;;DOT CASE8 [label="force\nserver"]; - ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8}; - ;;DOT CASE8 -> "rmt:open-qry-close-locally"; - ;; on homehost, no server contact made and this is a write, passively start a server - ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required - (cdr (remote-hh-dat runremote)) ;; have homehost - (not (remote-server-url runremote)) ;; no connection yet - (not (member cmd api:read-only-queries))) ;; not a read-only query - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8") - (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call - (if server-url - (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed - (if (common:force-server?) - (server:start-and-wait *toppath*) - (server:kind-run *toppath*)))) - (remote-force-server-set! runremote (common:force-server?)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1") - (rmt:open-qry-close-locally cmd 0 params)) - - ;;DOT CASE9 [label="force server\nnot on homehost"]; - ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9}; - ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive"; - ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one - (not (remote-conndat runremote))) - (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost - (not (remote-conndat runremote)))) ;; and no connection - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote)) - (mutex-unlock! *rmt-mutex*) - (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up? - (server:start-and-wait *toppath*)) - (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http - (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as - - ;;DOT CASE10 [label="on homehost"]; - ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10}; - ;;DOT CASE10 -> "rmt:open-qry-close-locally"; - ;; all set up if get this far, dispatch the query - ((and (not (remote-force-server runremote)) - (cdr (remote-hh-dat runremote))) ;; we are on homehost - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10") - (rmt:open-qry-close-locally cmd (if rid rid 0) params)) - - ;;DOT CASE11 [label="send_receive"]; - ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11}; - ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"]; - ;;DOT CASE11 -> "RESULT" [label="call succeeded"]; - ;; not on homehost, do server query - (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid))))) - ;;DOT } + (mutex-lock! *send-receive-mutex*) + (let ((ulex:conn (alldat-ulex:conn alldat))) + (if (not ulex:conn)(alldat-ulex:conn-set! alldat (rmtmod:setup-ulex areapath))) + (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat))) + (rmt:send-receive-orig *default-log-port* alldat *rmt-mutex* areapath *db-multi-sync-mutex* + cmd rid params *alldat* attemptnum: attemptnum area-dat: area-dat)))) ;; bunch of small functions factored out of send-receive to make debug easier ;; -(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid) - ;; (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") - ;; (mutex-lock! *rmt-mutex*) - (let* ((conninfo (remote-conndat runremote)) - (dat (case (remote-transport runremote) - ((http) (condition-case ;; handling here has - ;; caused a lot of - ;; problems. However it - ;; is needed to deal with - ;; attemtped - ;; communication to - ;; servers that have gone - ;; away - (http-transport:client-api-send-receive 0 conninfo cmd params) - ((commfail)(vector #f "communications fail")) - ((exn)(vector #f "other fail" (print-call-chain))))) - (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported") - (exit)))) - (success (if (vector? dat) (vector-ref dat 0) #f)) - (res (if (vector? dat) (vector-ref dat 1) #f))) - (if (and (vector? conninfo) (< 5 (vector-length conninfo))) - (http-transport:server-dat-update-last-access conninfo) ;; refresh access time - (begin - (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo) - (set! conninfo #f) - (remote-conndat-set! *runremote* #f) ;; NOTE: *runremote* is global copy of runremote. Purpose: factor out global. - (http-transport:close-connections area-dat: runremote))) - (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) - (mutex-unlock! *rmt-mutex*) - (if success ;; success only tells us that the transport was - ;; successful, have to examine the data to see if - ;; there was a detected issue at the other end - (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd) - (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params) - ))) - ;; (define (rmt:update-db-stats run-id rawcmd params duration) ;; (mutex-lock! *db-stats-mutex*) ;; (handle-exceptions ;; exn ;; (begin @@ -331,53 +148,10 @@ (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) -(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) - (let* ((qry-is-write (not (member cmd api:read-only-queries))) - (db-file-path (db:dbfile-path)) ;; 0)) - (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) - (read-only (not (file-write-access? db-file-path))) - (start (current-milliseconds)) - (resdat (if (not (and read-only qry-is-write)) - (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) - (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. - exn ;; This is an attempt to detect that situation and recover gracefully - (begin - (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy - (if (and (vector? v) - (> (vector-length v) 1)) - (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) - newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record - (vector #t '())))) ;; we could also check that the returned types are valid - (vector #t '()))) - (success (vector-ref resdat 0)) - (res (vector-ref resdat 1)) - (duration (- (current-milliseconds) start))) - (if (and read-only qry-is-write) - (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) - (if (not success) - (if (> remretries 0) - (begin - (debug:print-error 0 *default-log-port* "local query failed. Trying again.") - (thread-sleep! (/ (random 5000) 1000)) ;; some random delay - (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) - (begin - (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") - #f)) - (begin - ;; (rmt:update-db-stats run-id cmd params duration) - ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it - (if qry-is-write - (let ((start-time (current-seconds))) - (mutex-lock! *db-multi-sync-mutex*) -/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) - (mutex-unlock! *db-multi-sync-mutex*))))) - res)) - (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (res (handle-exceptions exn #f @@ -931,10 +705,16 @@ (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (rmt:test-get-archive-block-info archive-block-id) (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) -(set-functions rmt:send-receive remote-server-url-set! - http-transport:close-connections remote-conndat-set! - debug:print debug:print-info - remote-ro-mode remote-ro-mode-set! - remote-ro-mode-checked-set! remote-ro-mode-checked) +#;(set-functions http-transport:client-api-send-receive ;; a + http-transport:close-connections ;; b + api:execute-requests ;; c + #f + client:setup ;; e + server:kind-run ;; f + server:start-and-wait ;; g + server:check-if-running ;; h + server:ping ;; i + common:force-server? ;; j + ) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2017, Matthew Welland. +;; Copyright 2019, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -18,78 +18,100 @@ ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) +(declare (uses dbmod)) (module rmtmod * (import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) (import commonmod) - -;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time. -(define (rmt:send-receive . params) #f) -(define (http-transport:close-connections . params) #f) -;; from remote defstruct in common.scm -(define (remote-conndat-set! . params) #f) -(define (remote-server-url-set! . params) #f) -(define (remote-ro-mode . params) #f) -(define (remote-ro-mode-set! . params) #f) -(define (remote-ro-mode-checked-set! . params) #f) -(define (remote-ro-mode-checked . params) #f) -(define (debug:print . params) #f) -(define (debug:print-info . params) #f) - -(define (set-functions send-receive rsus - close-connections rcs - dbgp dbgpinfo - ro-mode ro-mode-set - ro-mode-checked-set ro-mode-checked - ) - (set! rmt:send-receive send-receive) - (set! remote-server-url-set! rsus) - (set! http-transport:close-connections close-connections) - (set! remote-conndat-set! rcs) - (set! debug:print dbgp) - (set! debug:print-info dbgpinfo) - (set! remote-ro-mode ro-mode) - (set! remote-ro-mode-set! ro-mode-set) - (set! remote-ro-mode-checked-set! ro-mode-checked-set) - (set! remote-ro-mode-checked ro-mode-checked)) - -(define (rmtmod:calc-ro-mode runremote *toppath*) - (if (and runremote - (remote-ro-mode-checked runremote)) - (remote-ro-mode runremote) - (let* ((dbfile (conc *toppath* "/megatest.db")) - (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future - (if runremote +(import dbmod) + +(use (prefix ulex ulex:)) + +(include "common_records.scm") + +(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params alldat #!key (remretries 5)) + (let* ((ro-queries (alldat-read-only-queries alldat)) + (qry-is-write (not (member cmd ro-queries))) + (db-file-path (common:get-db-tmp-area alldat)) ;; 0)) + (dbstruct-local (exec-fn 'db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) + (read-only (not (file-write-access? db-file-path))) + (start (current-milliseconds)) + (resdat (if (not (and read-only qry-is-write)) + (let ((v (exec-fn 'api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) + (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. + exn ;; This is an attempt to detect that situation and recover gracefully + (begin + (debug:print 0 log-port "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy + (if (and (vector? v) + (> (vector-length v) 1)) + (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) + newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record + (vector #t '())))) ;; we could also check that the returned types are valid + (vector #t '()))) + (success (vector-ref resdat 0)) + (res (vector-ref resdat 1)) + (duration (- (current-milliseconds) start))) + (if (and read-only qry-is-write) + (debug:print 0 log-port "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) + (if (not success) + (if (> remretries 0) + (begin + (debug:print-error 0 log-port "local query failed. Trying again.") + (thread-sleep! (/ (random 5000) 1000)) ;; some random delay + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params alldat remretries: (- remretries 1))) + (begin + (debug:print-error 0 log-port "too many retries in rmt:open-qry-close-locally, giving up") + #f)) + (begin + ;; (rmt:update-db-stats run-id cmd params duration) + ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it + #;(if qry-is-write + (let ((start-time (current-seconds))) + (mutex-lock! multi-sync-mutex) + (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) + (mutex-unlock! multi-sync-mutex))))) + res)) + + + +(define (rmtmod:calc-ro-mode areadat toppath) + (if (and areadat + (alldat-ro-mode-checked areadat)) + (alldat-ro-mode areadat) + (let* ((dbfile (conc toppath "/megatest.db")) + (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or areadat to figure this out in future + (if areadat (begin - (remote-ro-mode-set! runremote ro-mode) - (remote-ro-mode-checked-set! runremote #t) + (alldat-ro-mode-set! areadat ro-mode) + (alldat-ro-mode-checked-set! areadat #t) ro-mode) ro-mode)))) (define (extras-readonly-mode rmt-mutex log-port cmd params) - (mutex-unlock! rmt-mutex) + ;;(mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 3") (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) #f) -(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params) - (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) - (mutex-lock! *rmt-mutex*) - (remote-conndat-set! runremote #f) - (http-transport:close-connections area-dat: runremote) - (remote-server-url-set! runremote #f) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) - -(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd) +(define (extras-transport-failed log-port rmt-mutex attemptnum areadat areapath cmd rid params alldat) + (debug:print 0 log-port "WARNING: communication failed. Trying again, try num: " attemptnum) + ;;(mutex-lock! rmt-mutex) + (alldat-conndat-set! areadat #f) + (exec-fn 'http-transport:close-connections area-dat: areadat) + (alldat-server-url-set! areadat #f) + ;;(mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 9.1") + (rmt:send-receive-orig log-port areadat rmt-mutex areapath cmd rid params alldat attemptnum: (+ attemptnum 1))) + +(define (extras-transport-succeded log-port rmt-mutex attemptnum areadat areapath res params rid cmd alldat) (if (and (vector? res) (eq? (vector-length res) 2) (eq? (vector-ref res 1) 'overloaded)) ;; since we are ;; looking at the ;; data to carry the @@ -105,15 +127,214 @@ ;; server is ;; overloaded and we ;; want to ease off ;; the queries (let ((wait-delay (+ attemptnum (* attemptnum 10)))) - (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") - (mutex-lock! *rmt-mutex*) - (http-transport:close-connections area-dat: runremote) - (set! *runremote* #f) ;; force starting over - (mutex-unlock! *rmt-mutex*) + (debug:print 0 log-port "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") + ;;(mutex-lock! rmt-mutex) + (exec-fn 'http-transport:close-connections area-dat: areadat) + ;; (set! *areadat* #f) ;; force starting over + (alldat-server-url-set! areadat #f) ;; I am hoping this will force a redo on server connection. NOT TESTED + ;;(mutex-unlock! rmt-mutex) (thread-sleep! wait-delay) - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) + (rmt:send-receive-orig log-port areadat rmt-mutex areapath cmd rid params alldat attemptnum: (+ attemptnum 1))) res)) ;; All good, return res + +;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) +;; +;; add multi-sync-mutex +;; +(define (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected + + #;(common:telemetry-log (conc "rmt:"(->string cmd)) + payload: `((rid . ,rid) + (params . ,params))) + + + ;; do all the prep locked under the rmt-mutex + ;;(mutex-lock! rmt-mutex) + + ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in areadat + ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. + ;; 3. do the query, if on homehost use local access + ;; + (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value + + (readonly-mode (rmtmod:calc-ro-mode areadat toppath))) + + ;; (assert (not (pair? (alldat-hh-dat areadat)))) + + ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) + (cond + ;; give up if more than 15 attempts + ((> attemptnum 15) + (debug:print 0 log-port "ERROR: 15 tries to start/connect to server. Giving up.") + (exit 1)) + + ;; readonly mode, read request- handle it - case 2 + ((and readonly-mode + (member cmd api:read-only-queries)) + ;; (mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 2") + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat) + ) + + ;; readonly mode, write request. Do nothing, return #f + (readonly-mode (extras-readonly-mode rmt-mutex log-port cmd params)) + + ;; This block was for pre-emptively resetting the connection if there had been no communication for some time. + ;; I don't think it adds any value. If the server is not there, just fail and start a new connection. + ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout) + ;; + ;; reset the connection if it has been unused too long + ((and areadat + (alldat-conndat areadat) + (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on + (+ (http-transport:server-dat-get-last-access (alldat-conndat areadat)) + (alldat-server-timeout areadat)))) + (debug:print-info 0 log-port "Connection to " (alldat-server-url areadat) " expired due to no accesses, forcing new connection.") + (exec-fn 'http-transport:close-connections area-dat: areadat) + (alldat-conndat-set! areadat #f) ;; invalidate the connection, thus forcing a new connection. + ;; (mutex-unlock! rmt-mutex) + (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) + + + ;; on homehost and this is a read + ((and (not (alldat-force-server areadat)) ;; honor forced use of server, i.e. server NOT required + (pair? (alldat-hh-dat areadat)) + (cdr (alldat-hh-dat areadat)) ;; on homehost + (member cmd api:read-only-queries)) ;; this is a read + ;; (mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 5") + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)) + + ;; on homehost and this is a write, we already have a server, but server has died + ((and (cdr (alldat-hh-dat areadat)) ;; on homehost + (not (member cmd api:read-only-queries)) ;; this is a write + (alldat-server-url areadat) ;; have a server + (not (exec-fn 'server:ping (alldat-server-url areadat)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. + ;; (set! *areadat* (make-remote)) ;; WARNING - broken this. + (alldat-force-server-set! areadat (exec-fn 'common:force-server?)) + ;; (mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 6") + (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) + + ;; on homehost and this is a write, we already have a server + ((and (not (alldat-force-server areadat)) ;; honor forced use of server, i.e. server NOT required + (cdr (alldat-hh-dat areadat)) ;; on homehost + (not (member cmd api:read-only-queries)) ;; this is a write + (alldat-server-url areadat)) ;; have a server + ;;(mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 4.1") + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)) + + ;; on homehost, no server contact made and this is a write, passively start a server + ((and (not (alldat-force-server areadat)) ;; honor forced use of server, i.e. server NOT required + (cdr (alldat-hh-dat areadat)) ;; have homehost + (not (alldat-server-url areadat)) ;; no connection yet + (not (member cmd api:read-only-queries))) ;; not a read-only query + (debug:print-info 12 log-port "rmt:send-receive, case 8") + (let ((server-url (exec-fn 'server:check-if-running toppath))) ;; (server:read-dotserver->url toppath))) ;; (server:check-if-running toppath))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call + (if server-url + (alldat-server-url-set! areadat server-url) ;; the string can be consumed by the client setup if needed + (if (exec-fn 'common:force-server?) + (exec-fn 'server:start-and-wait toppath) + (exec-fn 'server:kind-run toppath)))) + (alldat-force-server-set! areadat (exec-fn 'common:force-server?)) + ;; (mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 8.1") + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)) + + ((or (and (alldat-force-server areadat) ;; we are forcing a server and don't yet have a connection to one + (not (alldat-conndat areadat))) + (and (not (cdr (alldat-hh-dat areadat))) ;; not on a homehost + (not (alldat-conndat areadat)))) ;; and no connection + (debug:print-info 12 log-port "rmt:send-receive, case 9, hh-dat: " (alldat-hh-dat areadat) " conndat: " (alldat-conndat areadat)) + ;;(mutex-unlock! rmt-mutex) + (if (not (exec-fn 'server:check-if-running toppath)) ;; who knows, maybe one has started up? + (exec-fn 'server:start-and-wait toppath)) + (alldat-conndat-set! areadat (rmt:get-connection-info areadat toppath)) ;; calls client:setup which calls client:setup-http + (rmt:send-receive-orig log-port areadat rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) ;; TODO: add back-off timeout as + + ;; all set up if get this far, dispatch the query + ((and (not (alldat-force-server areadat)) + (cdr (alldat-hh-dat areadat))) ;; we are on homehost + ;;(mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 10") + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd (if rid rid 0) params alldat)) + + ;; not on homehost, do server query + (else (extras-case-11 log-port rmt-mutex areadat toppath cmd params attemptnum rid alldat))))) + +(define (extras-case-11 log-port rmt-mutex areadat areapath cmd params attemptnum rid alldat) + ;; (mutex-unlock! rmt-mutex) + (debug:print-info 12 log-port "rmt:send-receive, case 9") + ;; (mutex-lock! rmt-mutex) + (let* ((conninfo (alldat-conndat areadat)) + (dat (case (alldat-transport areadat) + ((http) (condition-case ;; handling here has + ;; caused a lot of + ;; problems. However it + ;; is needed to deal with + ;; attemtped + ;; communication to + ;; servers that have gone + ;; away + (exec-fn 'http-transport:client-api-send-receive 0 conninfo cmd params) + ((commfail)(vector #f "communications fail")) + ((exn)(vector #f "other fail" (print-call-chain))))) + (else + (debug:print 0 log-port "ERROR: transport " (alldat-transport areadat) " not supported") + (exit)))) + (success (if (vector? dat) (vector-ref dat 0) #f)) + (res (if (vector? dat) (vector-ref dat 1) #f))) + (if (and (vector? conninfo) (< 5 (vector-length conninfo))) + (http-transport:server-dat-update-last-access conninfo) ;; refresh access time + (begin + (debug:print 0 log-port "INFO: Should not get here! conninfo=" conninfo) + (set! conninfo #f) + (alldat-conndat-set! areadat #f) ;; NOTE: *areadat* is global copy of areadat. Purpose: factor out global. + (exec-fn 'http-transport:close-connections area-dat: areadat))) + (debug:print-info 13 log-port "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " areadat = " areadat) + ;; (mutex-unlock! rmt-mutex) + (if success ;; success only tells us that the transport was + ;; successful, have to examine the data to see if + ;; there was a detected issue at the other end + (extras-transport-succeded log-port rmt-mutex attemptnum areadat areapath res params rid cmd alldat) + (extras-transport-failed log-port rmt-mutex attemptnum areadat areapath cmd rid params alldat) + ))) + +;; if a server is either running or in the process of starting call client:setup +;; else return #f to let the calling proc know that there is no server available +;; +(define (rmt:get-connection-info areadat areapath #!key (area-dat #f)) ;; TODO: push areapath down. + (let* (;; (areadat (or area-dat areadat)) + (cinfo (if (alldat? areadat) + (alldat-conndat areadat) + #f))) + (if cinfo + cinfo + (if (exec-fn 'server:check-if-running areapath) + (exec-fn 'client:setup areadat areapath) + #f)))) + + + +;;====================================================================== +;; ulex and steps stuff +;;====================================================================== + +(define (rmtmod:setup-ulex toppath) + (ulex:make-area + dbdir: (conc toppath "/ulexdb") + pktsdir: (conc toppath "/pkts") + )) + + + +(define (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat) + #f) + +(use trace)(trace-call-sites #t) +;; (trace member rmtmod:calc-ro-mode rmt:open-qry-close-locally) ) 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") + + +) 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 @@ -124,11 +124,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)) (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 " "") @@ -504,11 +504,11 @@ ;; (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)) (sync-cmd-core (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log)) @@ -628,11 +628,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") + + +) 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 @@ -103,11 +103,11 @@ (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) - (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path)) + (let* ((dbpath (common:get-db-tmp-area *alldat*)) ;; (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (common:file-exists? dbpath)) (write-access (file-write-access? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? @@ -283,11 +283,11 @@ ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) + (monitordbf (conc (common:get-db-tmp-area *alldat*) "/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue ADDED tasksmod.scm Index: tasksmod.scm ================================================================== --- /dev/null +++ tasksmod.scm @@ -0,0 +1,35 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit tasksmod)) +(declare (uses commonmod)) + +(module tasksmod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import commonmod) +;; (use (prefix ulex ulex:)) + +(include "common_records.scm") + + +) Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -291,11 +291,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)) (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: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -855,11 +855,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)) (keys (rmt:get-keys)) (numkeys (length keys)) (run-patt (or (args:get-arg "-run-patt") (args:get-arg "-runname") "%")) @@ -948,11 +948,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)) (keys (rmt:get-keys)) (numkeys (length keys)) (targtweaked (make-list numkeys "%")) (target-patt (string-join targtweaked "/")) (total-runs (rmt:get-num-runs "%")) @@ -979,11 +979,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)) (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 +1174,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)) (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)) 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 vgmod.scm Index: vgmod.scm ================================================================== --- /dev/null +++ vgmod.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 vgmod)) +(declare (uses 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") + + +)