Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -63,15 +63,15 @@ mofiles/archivemod.o : mofiles/launchmod.o mofiles/archivemod.o : mofiles/servermod.o mofiles/bigmod.o : mofiles/configfmod.o mofiles/bigmod.o : mofiles/dbmod.o mofiles/bigmod.o : mofiles/rmtmod.o -# mofiles/clientmod.o : mofiles/servermod.o +# mofiles/clientmod.o : mofiles/servermod.oibpq-dev +mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/commonmod.o : mofiles/configfmod.o mofiles/commonmod.o : mofiles/debugprint.o mofiles/commonmod.o : mofiles/hostinfo.o -mofiles/commonmod.o : mofiles/itemsmod.o mofiles/commonmod.o : mofiles/keysmod.o mofiles/commonmod.o : mofiles/mtargs.o mofiles/commonmod.o : mofiles/mtver.o mofiles/commonmod.o : mofiles/processmod.o mofiles/configfmod.o : mofiles/keysmod.o @@ -80,10 +80,11 @@ mofiles/dbmod.o : mofiles/csv-xml.o mofiles/dbmod.o : mofiles/keysmod.o mofiles/dbmod.o : mofiles/mtmod.o mofiles/ezstepsmod.o : mofiles/rmtmod.o mofiles/ezstepsmod.o : mofiles/subrunmod.o +mofiles/itemsmod.o : mofiles/commonmod.o mofiles/keysmod.o : mofiles/debugprint.o mofiles/launchmod.o : mofiles/bigmod.o mofiles/launchmod.o : mofiles/ezstepsmod.o mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o mofiles/mtmod.o : mofiles/debugprint.o Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -81,11 +81,10 @@ 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-tests-for-run-state-status get-test-id @@ -200,10 +199,12 @@ ;; SERVERS ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ((get-server) (api:start-server dbstruct params)) ((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) + ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) + ((get-count-servers) (apply db:get-count-servers dbstruct params)) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. @@ -229,10 +230,11 @@ ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) ;; RUNS ((register-run) (apply db:register-run dbstruct params)) + ((insert-run) (apply db:insert-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) @@ -356,11 +358,11 @@ ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) + (db:general-call dbstruct stmtname run-id realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) ;; TESTMETA @@ -409,21 +411,22 @@ (define (api:process-request dbstruct indat) ;; the $ is the request vars proc (let* ((cmd-in (alist-ref 'cmd indat)) ;; ($ 'cmd)) (cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in)) (params (alist-ref 'params indat)) (key (alist-ref 'key indat)) ;; TODO - add this back + (doprint (apply common:low-noise-print 10 params)) ) - (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key) + (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key)) (case cmd-in ((ping) #t) ;; ((quit) (exit)) (else (if (equal? key *my-signature*) ;; TODO - get real key involved (begin (set! *api-process-request-count* (+ *api-process-request-count* 1)) (let* ((res (api:execute-requests dbstruct cmd params))) - (debug:print 0 *default-log-port* "res:" res) + (if doprint (debug:print 0 *default-log-port* "res:" res)) #;(if (not success) (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) (if (> *api-process-request-count* *max-api-process-requests*) (set! *max-api-process-requests* *api-process-request-count*)) (set! *api-process-request-count* (- *api-process-request-count* 1)) Index: archivemod.scm ================================================================== --- archivemod.scm +++ archivemod.scm @@ -223,11 +223,11 @@ (if s (string->symbol s) 'bup))) (archiver-cmd (case archiver ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ") ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ") (else #f))) - (src-archive-linktree (rmt:get-var "src-archive-linktree")) + (src-archive-linktree (rmt:get-var run-id "src-archive-linktree")) (print-prefix "Running: ") ;; change to #f to turn off printing (preclean-spec (configf:get-section *configdat* "archive-preclean"))) (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree))) (rmt:set-var "src-archive-linktree" linktree)) @@ -481,11 +481,11 @@ 'old2new ) (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") (rmt:drop-all-triggers) (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) - (src-archive-linktree (rmt:get-var "src-archive-linktree"))) + (src-archive-linktree (rmt:get-var #f "src-archive-linktree"))) (if (not (equal? src-archive-linktree linktree)) (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree)) (debug:print-info 1 *default-log-port* "creating triggers after updating linktree") (rmt:create-all-triggers) )) ADDED build-assist/ck5-eggs.list Index: build-assist/ck5-eggs.list ================================================================== --- /dev/null +++ build-assist/ck5-eggs.list @@ -0,0 +1,43 @@ +address-info +ansi-escape-sequences +apropos +base64 +crypt +csv-abnf +directory-utils +filepath +fmt +format +http-client +itemsmod +json +linenoise +md5 +message-digest +nanomsg +postgresql +queues +regex +regex-case +rfc3339 +s11n +sha1 +slice +sparse-vectors +spiffy +spiffy-directory-listing +spiffy-request-vars +sql-de-lite +sqlite3 +sql-null +srfi-1 +srfi-13 +srfi-19 +sxml-modifications +sxml-serializer +sxml-transforms +system-information +test +typed-records +uri-common +z3 ADDED build-assist/debian-packages-needed Index: build-assist/debian-packages-needed ================================================================== --- /dev/null +++ build-assist/debian-packages-needed @@ -0,0 +1,5 @@ +build-essential +libnanomsg-dev +libpq-dev +libsqlite3-dev +sqlite3 ADDED build-assist/iup-compile.sh Index: build-assist/iup-compile.sh ================================================================== --- /dev/null +++ build-assist/iup-compile.sh @@ -0,0 +1,19 @@ +if [[ -z $PREFIX ]];then + echo "PREFIX required" + exit +fi + +echo "Put iup, im and cd .a and .so files in PREFIX/lib" +echo " 1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc" +echo " 2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64" +echo " 3. untar iup, im and cp tars into a clean working dir and then copy:" +echo " cp *.a *.so $PREFIX/lib" +echo " cp include/*.h $PREFIX/include" +echo " 4. run the chicken-install like this:" + +echo "If you use a wrapper (e.g. ck5) to create the chicken environment:" +echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup" +echo "else:" +echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup" +echo "Then repeat for canvas-draw" + DELETED common.scm Index: common.scm ================================================================== --- common.scm +++ /dev/null @@ -1,46 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . - -;;====================================================================== - -;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:) -;; format dot-locking csv-xml z3 udp ;; sql-de-lite -;; hostinfo md5 message-digest typed-records directory-utils stack -;; matchable regex posix (srfi 18) extras ;; tcp -;; (prefix nanomsg nmsg:) -;; (prefix sqlite3 sqlite3:) -;; pkts (prefix dbi dbi:) -;; ) -;; -;; (declare (unit common)) -;; ;; (declare (uses commonmod)) -;; ;; (import commonmod) -;; -;; (include "common_records.scm") - - -;; (require-library margs) -;; (include "margs.scm") - -;; (define old-exit exit) -;; -;; (define (exit . code) -;; (if (null? code) -;; (old-exit) -;; (old-exit code))) - Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -28,11 +28,11 @@ (declare (uses configfmod)) (declare (uses hostinfo)) (declare (uses keysmod)) ;; odd but it works? -(declare (uses itemsmod)) +;; (declare (uses itemsmod)) (module commonmod * (import scheme @@ -78,11 +78,11 @@ pkts processmod (prefix mtargs args:) configfmod keysmod - itemsmod + ;; itemsmod hostinfo ) ;;====================================================================== ;; CONTENTS @@ -108,12 +108,12 @@ (define *bdat* #f) ;; the one and only (someday) global? (defstruct bdat - (home (getenv "HOME")) - (user (getenv "USER")) + (home (get-environment-variable "HOME")) + (user (get-environment-variable "USER")) (watchdog #f) (time-to-exit #f) (task-db #f) (target #f) (this-exe-fullpath #f) @@ -153,12 +153,12 @@ (set-signal-handler! signal/term std-signal-handler) ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! bdat)) -;; (define home (getenv "HOME")) -;; (define user (getenv "USER")) +;; (define home (get-environment-variable "HOME")) +;; (define user (get-environment-variable "USER")) (define keys:config-get-fields common:get-fields) ;; Globals ;; ;;(define *server-loop-heart-beat* (current-seconds)) @@ -171,11 +171,11 @@ (define *db-keys* #f) (define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data -;; (define *configdat* #f) ;; megatest.config data ==> moved to configfmod +(define *configdat* #f) ;; megatest.config data ==> moved to configfmod (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) @@ -228,17 +228,15 @@ (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) (define *server-overloaded* #f) (define *writes-total-delay* 0) +(define *unclean-shutdown* #t) ;; flag to clear on clean shutdown ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex -;; RPC transport -(define *rpc:listener* #f) - ;; KEY info ;; (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here @@ -408,20 +406,20 @@ (dynamic-wind (lambda () (void)) (lambda () ;; (use posix) (for-each (lambda (var-value) - (setenv (car var-value) (cdr var-value))) + (set-environment-variable! (car var-value) (cdr var-value))) variables) (thunk)) (lambda () (for-each (lambda (var-value) (let ((var (car var-value)) (value (cdr var-value))) (if value - (setenv var value) - (unsetenv var)))) + (set-environment-variable! var value) + (unset-environment-variable! var)))) pre-existing-variables))))) ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock @@ -902,11 +900,11 @@ (hash-table-set! *common:denoise* key currtime) #t) #f))) (define (common:get-megatest-exe) - (or (getenv "MT_MEGATEST") "megatest")) + (or (get-environment-variable "MT_MEGATEST") "megatest")) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions @@ -991,11 +989,11 @@ (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-area-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") + (get-environment-variable "MT_TESTSUITE_NAME") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) (common:get-toppath #f))) "please-set-setup-area-name")) ;; (pathname-file (current-directory))))) @@ -1005,16 +1003,16 @@ (define (common:get-toppath areapath) (or *toppath* (if areapath (begin (set! *toppath* areapath) - (setenv "MT_RUN_AREA_HOME" areapath) + (set-environment-variable! "MT_RUN_AREA_HOME" areapath) areapath) #f) - (if (getenv "MT_RUN_AREA_HOME") + (if (get-environment-variable "MT_RUN_AREA_HOME") (begin - (set! *toppath* (getenv "MT_RUN_AREA_HOME")) + (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) *toppath*) #f) ;; last resort, look for megatest.config (let loop ((thepath (realpath "."))) (if (file-exists? (conc thepath "/megatest.config")) @@ -1255,36 +1253,27 @@ (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) -;;====================================================================== -;; Lookup a value in runconfigs based on -reqtarg or -target -;; -(define (runconfigs-get config var) - (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) - (if targ - (or (configf:lookup config targ var) - (configf:lookup config "default" var)) - (configf:lookup config "default" var)))) - (define (common:args-get-state) (or (args:get-arg "-state")(args:get-arg ":state"))) (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) - (let* (;; (tagexpr (args:get-arg "-tagexpr")) + (let* ((target (common:args-get-target)) + ;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) - (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) + (rtestpatt (if rconf (runconfigs-get rconf target testpatt-key) #f))) (cond ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf - (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key))) + (let* ((patts-from-mode-patt (runconfigs-get rconf target testpatt-key))) (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) patts-from-mode-patt) (begin (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt) #f))) ;; We do NOT fall back to "%" @@ -1334,35 +1323,35 @@ (file-writable? path-string)) path-string #f))) (define (common:get-linktree) - (or (getenv "MT_LINKTREE") + (or (get-environment-variable "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f) - (if (or *toppath* (getenv "MT_RUN_AREA_HOME")) - (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt") + (if (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) + (conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) "/lt") #f) (let* ((tp (common:get-toppath #f)) (lt (conc tp "/lt"))) (if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt)) lt))) (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") - (getenv "MT_RUNNAME")))) - ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... + (get-environment-variable "MT_RUNNAME")))) + ;; (if res (set-environment-variable! "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") - (getenv "MT_TARGET"))) + (get-environment-variable "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) (valid (if target (or (null? keys) ;; probably don't know our keys yet (and (not (null? tlist)) (eq? numkeys (length tlist)) @@ -1381,15 +1370,15 @@ ;;====================================================================== ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) - (if (getenv "MT_TEST_NAME") - (if (and (getenv "MT_ITEMPATH") - (not (equal? (getenv "MT_ITEMPATH") ""))) - (getenv "MT_TEST_NAME") - (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) + (if (get-environment-variable "MT_TEST_NAME") + (if (and (get-environment-variable "MT_ITEMPATH") + (not (equal? (get-environment-variable "MT_ITEMPATH") ""))) + (get-environment-variable "MT_TEST_NAME") + (conc (get-environment-variable "MT_TEST_NAME") "/" (get-environment-variable "MT_ITEMPATH"))) #f)) ;;====================================================================== ;; do we honor the caches of the config files? ;; @@ -1399,14 +1388,14 @@ (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") (set! res #f) (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") (set! res #t)))) (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" - (if (getenv "MT_USE_CACHE") - (if (equal? (getenv "MT_USE_CACHE") "yes") + (if (get-environment-variable "MT_USE_CACHE") + (if (equal? (get-environment-variable "MT_USE_CACHE") "yes") (set! res #t) - (if (equal? (getenv "MT_USE_CACHE") "no") + (if (equal? (get-environment-variable "MT_USE_CACHE") "no") (set! res #f)))) ;; overrides -no-cache switch res)) ;;====================================================================== ;; force use of server? @@ -2061,27 +2050,27 @@ ;; no elegance here ... ;; (define (tasks:kill-server hostname pid #!key (kill-switch "")) (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) - (setenv "TARGETHOST" hostname) + (set-environment-variable! "TARGETHOST" hostname) (let* ((logdir (if (directory-exists? "logs") "logs/" "")) (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f)) (gzfile (if logfile (conc logfile ".gz")))) - (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) + (set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log")) (system (conc "nbfake kill "kill-switch" "pid)) (when logfile (thread-sleep! 0.5) (if (file-exists? gzfile) (delete-file gzfile)) (system (conc "gzip " logfile)) - (unsetenv "TARGETHOST_LOGF") - (unsetenv "TARGETHOST")))) + (unset-environment-variable! "TARGETHOST_LOGF") + (unset-environment-variable! "TARGETHOST")))) (define (server:get-logs-list area-path) (let* (;; (server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log")) ;; (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string)))) (server-logs (glob (conc area-path"/logs/server-*-*.log"))) @@ -2713,11 +2702,11 @@ (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val (safe-setenv var (->string val)) - (unsetenv var)))) + (unset-environment-variable! var)))) lst) res) '())) ;;====================================================================== @@ -2737,17 +2726,17 @@ x)) envvars)))) (define (common:with-orig-env proc) (let ((current-env (get-environment-variables))) - (for-each (lambda (x) (unsetenv (car x))) current-env) - (for-each (lambda (x) (setenv (car x) (cdr x))) (bdat-orig-env *bdat*)) + (for-each (lambda (x) (unset-environment-variable! (car x))) current-env) + (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) (bdat-orig-env *bdat*)) (let ((rv (cond ((string? proc)(system proc)) (proc (proc))))) - (for-each (lambda (x) (unsetenv (car x))) (bdat-orig-env *bdat*)) - (for-each (lambda (x) (setenv (car x) (cdr x))) current-env) + (for-each (lambda (x) (unset-environment-variable! (car x))) (bdat-orig-env *bdat*)) + (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env) rv))) (define (common:without-vars proc . var-patts) (let ((vars (make-hash-table))) (for-each @@ -2756,20 +2745,20 @@ (lambda (var-patt) (if (string-match var-patt (car vardat)) (let ((var (car vardat)) (val (cdr vardat))) (hash-table-set! vars var val) - (unsetenv var)))) + (unset-environment-variable! var)))) var-patts)) (get-environment-variables)) (cond ((string? proc)(system proc)) (proc (proc))) (hash-table-for-each vars (lambda (var val) - (setenv var val))) + (set-environment-variable! var val))) vars)) (define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) @@ -3576,38 +3565,10 @@ ((null? res) #f) ((string? (cdr res)) (cdr res)) ;; it is a pair ((string? (cadr res))(cadr res)) ;; it is a list (else cadr res)))))) -;; return items given config -;; -(define (tests:get-items tconfig) - (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 - (itemstable (hash-table-ref/default tconfig "itemstable" #f))) - ;; if either items or items table is a proc return it so test running - ;; process can know to call items:get-items-from-config - ;; if either is a list and none is a proc go ahead and call get-items - ;; otherwise return #f - this is not an iterated test - (cond - ((procedure? items) - (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") - items) ;; calc later - ((procedure? itemstable) - (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") - itemstable) ;; calc later - ((filter (lambda (x) - (let ((val (car x))) - (if (procedure? val) val #f))) - (append (if (list? items) items '()) - (if (list? itemstable) itemstable '()))) - 'have-procedure) - ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) - (items:get-items-from-config tconfig)) - (else #f)))) ;; not iterated - (define (tests:get-tests-search-path cfgdat) (let ((paths (let ((section (if cfgdat (configf:get-section cfgdat "tests-paths") #f))) (if section @@ -3649,11 +3610,11 @@ (define (server:expiration-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) - 600))) ;; default is ten minutes + 60))) ;; default is one minute (define (runs:get-mt-env-alist run-id runname target testname itempath) ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") `(("MT_TEST_NAME" . ,testname) Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -22,11 +22,41 @@ (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses keysmod)) (module configfmod - * + ( + common:get-fields + common:nice-path + common:read-link-f + common:with-env-vars + configf:config->ini + configf:alist->config + configf:assoc-safe-add + configf:config->alist + configf:find-and-read-config + configf:get-section + configf:lookup + configf:lookup-number + configf:map-all-hier-alist + configf:read-alist + configf:read-config + configf:read-refdb + configf:section-var-set! + configf:section-vars + configf:set-section-var + configf:var-is? + configf:write-alist + configf:write-config + find-config + nice-path + process:cmd-run->list + runconfig:read + runconfigs-get + safe-setenv + configf:eval-string-in-environment + ) (import scheme chicken.base chicken.condition @@ -35,10 +65,11 @@ chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context + chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.eval @@ -66,12 +97,10 @@ typed-records z3 ) -(define *configdat* #f) - (define getenv get-environment-variable) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) ;;====================================================================== @@ -953,14 +982,81 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== ;; convert to param? -(define configf:std-imports "") ;;(import configfmod commonmod)") - +(define configf:std-imports "(import configfmod commonmod)") +(define (configf:process-one matchdat l ht allow-system env-to-use linenum) + (let* ((prestr (list-ref matchdat 1)) + (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv + (cmd (list-ref matchdat 3)) + (quotedcmd (conc "\""cmd"\"")) + (poststr (list-ref matchdat 4)) + (result #f) + (start-time (current-seconds)) + (cmdsym (string->symbol cmdtype)) + (fullcmd + (if (member cmdsym '(scheme scm)) + `(eval-needed + ,(conc configf:std-imports + "(import chicken.process-context.posix chicken.process-context)" + "(define setenv set-environment-variable)" + (conc "(lambda (ht)" cmd ")"))) + (case cmdsym + ((system) `(noeval-needed ,(conc (configf:system ht quotedcmd)))) + ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " ")))) + ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd)))) + ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd)))) + ;; ((mtrah) (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\")))) + ((get g) + (match + (string-split cmd) + ((sect var)(configf:lookup ht sect var)) + (else + (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") + '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed."))))) + ((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + (else `(#f ,(conc "cmd: " cmd " not recognised"))))))) + (match + fullcmd + (('eval-needed newres) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", fullcmd="fullcmd", exn=" exn) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) + (if (or allow-system + (not (member cmdtype '("system" "shell" "sh")))) + (with-input-from-string newres + (lambda () + (set! result (if env-to-use + ((eval (read) env-to-use) ht) + ((eval (read)) ht) + )))) + (set! result (conc "#{(" cmdtype ") " cmd "}"))))) + (('noeval-needed newres)(set! result newres)) + ((#f errres) + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"."))) + ;; we process as a result + (let ((delta (- (current-seconds) start-time))) + (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)) + (conc prestr result poststr))) + (define (configf:process-line l ht allow-system env-to-use #!key (linenum #f)) (let loop ((res l)) + (if (string? res) + (let ((matchdat (string-search configf:var-expand-regex res))) + (if matchdat + (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum))) + (loop result)) + res)) + res))) + +(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f)) + (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv @@ -969,10 +1065,12 @@ (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (conc configf:std-imports + "(import chicken.process-context.posix)" + "(define setenv set-environment-variable)" (case cmdsym ((scheme scm) (conc "(lambda (ht)" cmd ")")) ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) @@ -1016,11 +1114,21 @@ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) - +;;====================================================================== +;; Lookup a value in runconfigs based on -reqtarg or -target +;; +(define (runconfigs-get config target var) + (let ((targ target #;(common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) + (if targ + (or (configf:lookup config targ var) + (configf:lookup config "default" var)) + (configf:lookup config "default" var)))) + + ;; pathenvvar will set the named var to the path of the config (define (configf:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(env-to-use #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -18,25 +18,26 @@ ;; ;;====================================================================== (use format) +(declare (uses ducttape-lib)) (require-library iup) (import (prefix iup iup:)) -(use canvas-draw) -(import canvas-draw-iup) -(use ducttape-lib) +(import canvas-draw) +;; (import canvas-draw-iup) +(import ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) -(declare (uses common)) -(declare (uses margs)) -(declare (uses keys)) -(declare (uses items)) -(declare (uses db)) -(declare (uses configf)) +(declare (uses commonmod)) +(declare (uses mtargs)) +;; (declare (uses keys)) +(declare (uses itemsmod)) +(declare (uses dbmod)) +(declare (uses configfmod)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) @@ -45,18 +46,26 @@ (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) ;; (declare (uses dashboard-main)) (declare (uses mt)) +(declare (uses mtver)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") -(include "megatest-version.scm") +;; (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") + +(import commonmod + mtargs + itemsmod + dbmod + configfmod + ) (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -102,17 +102,17 @@ (last-sync 0) (last-write (current-seconds)) (run-id #f) (fname #f)) -;; Returns the dbdat for a particular run-id from dbstruct +;; Returns the dbdat for a particular dbfile inside the area ;; -(define (dbr:dbstruct-get-dbdat v run-id) - (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f)) +(define (dbr:dbstruct-get-dbdat dbstruct dbfile) + (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f)) -(define (dbr:dbstruct-dbdat-put! v run-id db) - (hash-table-set! (dbr:dbstruct-dbdats v) run-id db)) +(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db) + (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db)) (define (db:run-id->first-num run-id) (let* ((s (number->string run-id)) (l (string-length s))) (substring s (- l 1) l))) @@ -155,15 +155,14 @@ ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-dbdat dbstruct apath dbfile) - (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id))) + (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) (if dbdat dbdat - (let* (;; (dbfile (db:run-id->path apath run-id)) - (newdbdat (db:open-dbdat apath dbfile db:initialize-db))) + (let* ((newdbdat (db:open-dbdat apath dbfile db:initialize-db))) (dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat) newdbdat)))) ;; get the inmem db for actual db operations ;; @@ -178,21 +177,33 @@ ;; open or create the disk db file ;; create and fill the inmemory db ;; assemble into dbr:dbdat struct and return ;; (define (db:open-dbdat apath dbfile dbinit-proc) - (let* (;; (dbfile (db:run-id->path apath run-id)) - (db (db:open-run-db dbfile dbinit-proc)) - (inmem (db:open-inmem-db dbinit-proc)) + (let* ((db (db:open-run-db dbfile dbinit-proc)) + ;; (inmem (db:open-inmem-db dbinit-proc)) (dbdat (make-dbr:dbdat - db: db - inmem: inmem + db: #f ;; db + inmem: db ;; inmem ;; run-id: run-id ;; no can do, there are many run-id values that point to single db fname: dbfile))) ;; now sync the disk file data into the inmemory db - (db:sync-tables (db:sync-all-tables-list) #f db inmem) + ;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem) + ;; (sqlite3:finalize! db) ;; open and close every sync dbdat)) +;; (define (db:open-dbdat apath dbfile dbinit-proc) +;; (let* ((db (db:open-run-db dbfile dbinit-proc)) +;; (inmem (db:open-inmem-db dbinit-proc)) +;; (dbdat (make-dbr:dbdat +;; db: #f ;; db +;; inmem: inmem +;; ;; run-id: run-id ;; no can do, there are many run-id values that point to single db +;; fname: dbfile))) +;; ;; now sync the disk file data into the inmemory db +;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem) +;; (sqlite3:finalize! db) ;; open and close every sync +;; dbdat)) ;; open the disk database file ;; NOTE: May need to add locking to file create process here ;; returns an sqlite3 database handle ;; @@ -202,11 +213,11 @@ (create-directory parent-dir #t)) (let* ((exists (file-exists? dbfile)) (db (sqlite3:open-database dbfile)) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) - (db:set-sync db) + ;; (db:set-sync db) ;; we don't mind that this is slow? (if (not exists) (dbinit-proc db)) db))) ;; open and initialize the inmem db @@ -216,10 +227,25 @@ (let* ((db (sqlite3:open-database ":memory:")) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db) db)) + +;; ;; for debugging we have a local mode. these routines support that mode +;; (define *dbcache* (make-hash-table)) +;; +;; (define (db:cache-get-dbstruct rid apath) +;; (let* ((dbname (db:run-id->dbname rid)) +;; (dbfile (db:dbname->path apath dbname))) +;; (or (hash-table-ref/default *dbcache* dbfile #f) +;; (let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db))) +;; (hash-table-set! *dbcache* dbfile dbstruct) +;; dbstruct)))) +;; +;; (define (db:finalize-all-cache-dbstruct) +;; #f) +;; ;; get and initalize dbstruct for a given run-id ;; ;; - uses db:initialize-db to create the schema ;; @@ -226,14 +252,13 @@ ;; Make the dbstruct, call for main db at least once ;; sync disk db to inmem ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; -(define (db:setup run-id) +(define (db:setup db-file) ;; run-id) (assert *toppath* "FATAL: db:setup called before toppath is available.") - (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))) - (db-file (db:run-id->path *toppath* run-id))) + (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))) (db:get-dbdat dbstruct *toppath* db-file) (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct)) dbstruct)) ;;====================================================================== @@ -252,11 +277,11 @@ (db:get-iam-server-lock dbh dbfile)))) (define (db:with-lock-db dbfile proc) (let* ((dbh (db:open-run-db dbfile db:initialize-db)) (res (proc dbh dbfile))) - (sqlite3:finalize! dbh) + ;; (sqlite3:finalize! dbh) res)) ;; called before db is open? ;; (define (db:get-iam-server-lock dbh dbfname) @@ -415,29 +440,33 @@ ;; NOTE: touched logic is disabled/not done ;; sync run to disk if touched ;; (define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f)) - (let* ((dbdat (db:get-dbdat dbstruct apath dbfile)) - (db (dbr:dbdat-db dbdat)) - (inmem (dbr:dbdat-inmem dbdat)) - (start-t (current-seconds)) - (last-update (dbr:dbdat-last-write dbdat)) - (last-sync (dbr:dbdat-last-sync dbdat))) - (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile) - (mutex-lock! *db-multi-sync-mutex*) - (let* ((update_info (cons (if force-sync 0 last-update) "last_update")) - (need-sync (or force-sync (>= last-update last-sync)))) - (if need-sync - (db:sync-tables (db:sync-all-tables-list) update_info inmem db) - (debug:print 0 *default-log-port* "Skipping sync as nothing touched."))) - (dbr:dbdat-last-sync-set! dbdat start-t) - (mutex-unlock! *db-multi-sync-mutex*))) + #f) ;; disabled +;; (let* ((dbdat (db:get-dbdat dbstruct apath dbfile)) +;; (dbfullname (conc apath "/" dbfile)) +;; (db (db:open-run-db dbfullname db:initialize-db)) ;; (dbr:dbdat-db dbdat)) +;; (inmem (dbr:dbdat-inmem dbdat)) +;; (start-t (current-seconds)) +;; (last-update (dbr:dbdat-last-write dbdat)) +;; (last-sync (dbr:dbdat-last-sync dbdat))) +;; (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync) +;; (mutex-lock! *db-multi-sync-mutex*) +;; (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;; "last_update")) +;; (need-sync (or force-sync (>= last-update last-sync)))) +;; (if need-sync +;; (begin +;; (db:sync-tables (db:sync-all-tables-list) update_info inmem db) +;; (dbr:dbdat-last-sync-set! dbdat start-t)) +;; (debug:print 0 *default-log-port* "Skipping sync as nothing touched."))) +;; (sqlite3:finalize! db) +;; (mutex-unlock! *db-multi-sync-mutex*))) ;; TODO: Add final sync to this ;; -(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) +#;(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) (if (<= try-num 0) #f (handle-exceptions exn (begin @@ -451,11 +480,11 @@ (sqlite3:finalize! db) #t) #f)))) ;; close all opened run-id dbs -(define (db:close-all dbstruct) +#;(define (db:close-all dbstruct) (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.") (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn) @@ -643,38 +672,23 @@ (sqlite3:execute db "vacuum;"))) (sqlite3:finalize! db) #t)))))) +;; last-update is *always* a pair ( fieldname|#f . last-update-seconds|#f) (define (db:sync-one-table fromdb todb tabledat last-update numrecs) + (assert (pair? last-update) "FATAL: last-update must always be a pair.") (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (has-last-update (member "last_update" fields)) - (use-last-update (cond - ((and has-last-update - (member "last_update" fields)) - #t) ;; if given a number, just use it for all fields - ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table - ((and (pair? last-update) - (member (car last-update) ;; last-update field name - (map car fields))) - #t) - (last-update - (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields - #f) - (else - #f))) - (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for - (if (number? last-update) - last-update - (cdr last-update)) - #f)) - (last-update-field (if use-last-update - (if (number? last-update) + (last-update-field (or (car last-update) + (if has-last-update "last_update" - (car last-update)) - #f)) + #f))) + (has-field (member last-update-field fields)) + (last-update-value (cdr last-update)) + (use-last-update (and has-field last-update-field last-update-value)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) ;; BBHERE (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria @@ -757,10 +771,11 @@ (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin + (debug:print 0 *default-log-port* "applying data "fromrow"to table "tablename", numrecs="numrecs) (apply sqlite3:execute stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)))) fromdats) (sqlite3:finalize! stmth) @@ -773,11 +788,11 @@ ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; (define (db:sync-tables tbls last-update fromdb todb) - + (assert (pair? last-update) "FATAL: last-update must always be a pair") ;; NOTE: I'm moving all the checking OUT of this routine. Check for read/write access, existance, etc ;; BEFORE calling this sync (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) @@ -798,11 +813,11 @@ (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) (if (> count 0) - (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) + (if should-print (debug:print 0 *default-log-port* " "tblname" "count))))) ;; (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count)) (define (db:patch-schema-rundb frundb) ;; @@ -1177,24 +1192,24 @@ BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ))) -(define (db:create-all-triggers dbstruct) +(define (db:create-all-triggers dbstruct run-id) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (db:create-triggers db)))) (define (db:create-triggers db) (for-each (lambda (key) (sqlite3:execute db (cadr key))) db:trigger-list)) -(define (db:drop-all-triggers dbstruct) +(define (db:drop-all-triggers dbstruct run-id) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (db:drop-triggers db)))) (define (db:is-trigger-dropped db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") @@ -1623,11 +1638,11 @@ (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 72000))) ;; twenty hours (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; @@ -1706,11 +1721,11 @@ ) (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (let* ((stmth1 (db:get-cache-stmth dbstruct db "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) @@ -1828,11 +1843,11 @@ ))))))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) - (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) + (db:general-call dbstruct 'top-test-set-per-pf-counts run-id (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1978,18 +1993,18 @@ ;; dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== - + ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; -(define (db:get-var dbstruct var) +(define (db:get-var dbstruct run-id var) (let* ((res #f)) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (val) (set! res val)) db @@ -1998,17 +2013,17 @@ (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) res)))) -(define (db:inc-var dbstruct var) - (db:with-db dbstruct #f #t +(define (db:inc-var dbstruct run-id var) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var)))) -(define (db:dec-var dbstruct var) - (db:with-db dbstruct #f #t +(define (db:dec-var dbstruct run-id var) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var)))) ;; This was part of db:get-var. It was used to estimate the load on ;; the database files. @@ -2020,22 +2035,22 @@ ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin ;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) -(define (db:set-var dbstruct var val) - (db:with-db dbstruct #f #t +(define (db:set-var dbstruct run-id var val) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) -(define (db:add-var dbstruct var val) - (db:with-db dbstruct #f #t +(define (db:add-var dbstruct run-id var val) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var)))) -(define (db:del-var dbstruct var) - (db:with-db dbstruct #f #t +(define (db:del-var dbstruct run-id var) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers @@ -2089,11 +2104,11 @@ (if newres newres res)) res))) -(define (db:no-sync-close-db db stmt-cache) +#;(define (db:no-sync-close-db db stmt-cache) (db:safely-close-sqlite3-db db stmt-cache)) ;; transaction protected lock aquisition ;; either: ;; fails returns (#f . lock-creation-time) @@ -2245,10 +2260,45 @@ (db:with-db dbstruct #f #f (lambda (db) (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") + allvals) + (apply sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) + qry) + qryvals) + (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + res))) + (begin + (debug:print-error 0 *default-log-port* "Called without all necessary keys") + #f)))) + +;; register a run with the db +;; +(define (db:insert-run dbstruct run-id keyvals runname state status user contour-in) + (let* ((keys (map car keyvals)) + (keystr (keys->keystr keys)) + (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. + (comma (if (> (length keys) 0) "," "")) + (andstr (if (> (length keys) 0) " AND " "")) + (valslots (keys->valslots keys)) ;; ?,?,? ... + (allvals (append (list runname state status user contour) (map cadr keyvals))) + (qryvals (append (list runname) (map cadr keyvals))) + (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") + (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" + (db:with-db + dbstruct run-id #f + (lambda (db) + (let ((res #f)) + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");") + run-id allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db @@ -2466,11 +2516,11 @@ ;; (define (db:update-run-stats dbstruct run-id stats) ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct - #f + run-id #f (lambda (db) ;; remove previous data @@ -3023,14 +3073,14 @@ ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) - (db:general-call dbstruct 'delete-test-step-records (list test-id)) - (db:general-call dbstruct 'delete-test-data-records (list test-id)) + (db:general-call dbstruct 'delete-test-step-records run-id (list test-id)) + (db:general-call dbstruct 'delete-test-data-records run-id (list test-id)) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))) ;; (define (db:delete-old-deleted-test-records dbstruct) @@ -3085,31 +3135,25 @@ test-ids)) ;; ;; speed up for common cases with a little logic ;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id ;; +;; NOTE: processing triggers was called here - moved upstream +;; ;; NOTE: run-id is not used ;; ;; -(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment) - (db:with-db - dbstruct - ;; run-id - #f - #t - (lambda (db) - (cond - ((and newstate newstatus newcomment) - (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) - test-id)) - ((and newstate newstatus) - (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) - (else - (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) - (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) - (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) - test-id)))))) - (mt:process-triggers dbstruct run-id test-id newstate newstatus)) +(define (db:test-set-state-status db run-id test-id newstate newstatus newcomment) + (cond + ((and newstate newstatus newcomment) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) + test-id)) + ((and newstate newstatus) + (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) + (else + (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) + (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) + (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) ;; fastmode) (let* ((qry ;; (if fastmode @@ -3562,13 +3606,13 @@ db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db - (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id)) + (db:general-call dbstruct 'pass-fail-counts run-id (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) + (db:general-call dbstruct 'test_data-pf-rollup run-id (list test-id test-id test-id test-id)))))) ;; each section is a rule except "final" which is the final result ;; ;; [rule-5] ;; operator in @@ -3869,40 +3913,44 @@ (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (if tl-testdat (db:test-get-id tl-testdat) #f))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call dbstruct 'set-test-start-time (list test-id))) - (mutex-lock! *db-transaction-mutex*) + (db:general-call dbstruct 'set-test-start-time run-id (list test-id))) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction - (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status + ;; this call sets the item state/status + (db:test-set-state-status db run-id test-id state status comment) (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test (state-stauses (db:roll-up-rules state-status-counts state status)) (newstate (car state-stauses)) (newstatus (cadr state-stauses))) (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " (apply conc (map (lambda (x) (conc - (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) - state-status-counts))); end debug:print - + (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) + state-status-counts))); end debug:print + (if tl-test-id (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct )))))) - (mutex-unlock! *db-transaction-mutex*) + ;; (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) - tr-res))))) + tr-res))) + ;; this was moved out of test-set-state-status + (mt:process-triggers dbstruct run-id test-id state status))) + (define (db:roll-up-rules state-status-counts state status) (let* ((running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) @@ -3957,11 +4005,11 @@ ;; NB// Pass the db so it is part of the transaction (list newstate newstatus))) (define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status) - (mutex-lock! *db-transaction-mutex*) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f (lambda (db) (let ((tr-res (sqlite3:with-transaction @@ -3971,11 +4019,11 @@ (state-stauses (db:roll-up-rules state-status-counts #f #f )) (newstate (car state-stauses)) (newstatus (cadr state-stauses))) (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) - (mutex-unlock! *db-transaction-mutex*) + ;; (mutex-unlock! *db-transaction-mutex*) tr-res)))) (define (db:get-all-state-status-counts-for-run dbstruct run-id) (let* ((test-count-recs (db:with-db @@ -4233,18 +4281,18 @@ (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call dbstruct stmtname params) +(define (db:general-call dbstruct stmtname run-id params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (apply sqlite3:execute db query params) #t)))) ;; get a summary of state and status counts to calculate a rollup @@ -5156,11 +5204,11 @@ actual-state " " actual-status " " event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) - (setenv "NBFAKE_LOG" (conc (cond + (set-environment-variable! "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) (file-writable? test-rundir)) test-rundir) ((and (directory-exists? *toppath*) (file-writable? *toppath*)) @@ -5171,12 +5219,12 @@ ;; (call-with-environment-variables ;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname))) ;; (lambda () (process-run fullcmd) (if prev-nbfake-log - (setenv "NBFAKE_LOG" prev-nbfake-log) - (unsetenv "NBFAKE_LOG")) + (set-environment-variable! "NBFAKE_LOG" prev-nbfake-log) + (unset-environment-variable! "NBFAKE_LOG")) )) ;; )) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) @@ -5248,16 +5296,16 @@ (if (and (common:file-exists? tconfig-file) (file-readable? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE")) (bigmodenv (module-environment 'bigmod))) - (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) + (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path)) (let ((newtcfg (configf:read-config tconfig-file #f #f env-to-use: bigmodenv))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree - (setenv "MT_LINKTREE" old-link-tree) - (unsetenv "MT_LINKTREE")) + (set-environment-variable! "MT_LINKTREE" old-link-tree) + (unset-environment-variable! "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) @@ -5537,10 +5585,30 @@ (begin (sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" host port servkey pid ipaddr apath dbname) (db:get-server-info dbstruct apath dbname))))))))) +;; run this one in a transaction where first check if host:port is taken +(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname) + (db:with-db + dbstruct + #f #f + (lambda (db) + (sqlite3:with-transaction + db + (lambda () + (let* ((sinfo (db:get-server-info dbstruct apath dbname))) + (if (not sinfo) + (begin + (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port) + #f) ;; server already deregistered + (begin + (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" + ;; host port servkey pid ipaddr + apath dbname) + #;(db:get-server-info dbstruct apath dbname))))))))) + (define (db:get-server-info dbstruct apath dbname) (db:with-db dbstruct #f #f (lambda (db) @@ -5549,7 +5617,20 @@ (list host port servkey pid ipaddr apath dbpath)) #f db "SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;" apath dbname)))) + +(define (db:get-count-servers dbstruct apath) + (db:with-db + dbstruct + #f #f + (lambda (db) + (sqlite3:fold-row + (lambda (res count) + (max res count)) + 0 + db + "SELECT count(*) FROM servers WHERE apath=?;" + apath)))) ) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -19,25 +19,28 @@ ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) -(use canvas-draw) -(import canvas-draw-iup) +(import canvas-draw) +;; (import canvas-draw-iup) (use regex typed-records matchable) (declare (unit dcommon)) (declare (uses gutils)) (declare (uses db)) +(declare (uses mtver)) ;; (declare (uses synchash)) -(include "megatest-version.scm") +;; (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") + +(import mtver) ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) (define dashboard:update-servers-table #f) Index: docs/manual/server.dot ================================================================== --- docs/manual/server.dot +++ docs/manual/server.dot @@ -17,61 +17,65 @@ digraph G { subgraph cluster_1 { node [style=filled,shape=box]; - check_available_queue -> remove_entries_over_10s_old; - remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; - remove_entries_over_10s_old -> exit [label="num_avail > 2"]; - - set_available -> delay_2s; - delay_2s -> check_place_in_queue; - - check_place_in_queue -> "http:transport-launch" [label="at head"]; - check_place_in_queue -> exit [label="not at head"]; - - "client:login" -> "server:shutdown" [label="login failed"]; - "server:shutdown" -> exit; - - subgraph cluster_2 { - "http:transport-launch" -> "http:transport-run"; - "http:transport-launch" -> "http:transport-keep-running"; - - "http:transport-keep-running" -> "tests running?"; - "tests running?" -> "client:login" [label=yes]; - "tests running?" -> "server:shutdown" [label=no]; - "client:login" -> delay_5s [label="login ok"]; - delay_5s -> "http:transport-keep-running"; - } - - // start_server -> "server_running?"; - // "server_running?" -> set_available [label="no"]; - // "server_running?" -> delay_2s [label="yes"]; - // delay_2s -> "still_running?"; - // "still_running?" -> ping_server [label=yes]; - // "still_running?" -> set_available [label=no]; - // ping_server -> exit [label=alive]; - // ping_server -> remove_server_record [label=dead]; - // remove_server_record -> set_available; - // set_available -> avail_delay [label="delay 3s"]; - // avail_delay -> "first_in_queue?"; - // - // "first_in_queue?" -> set_running [label=yes]; - // set_running -> get_next_port -> handle_requests; - // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; - // "dead_entry_in_queue?" -> "server_running?" [label=no]; - // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; - // remove_dead_entries -> "server_running?"; - // - // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; - // handle_requests -> shutdown_request; - // start_shutdown -> shutdown_delay; - // shutdown_request -> shutdown_delay; - // shutdown_delay -> exit; - - label = "server:launch"; - color=brown; + rmt:send-receive -> "init-*remote* if needed" -> rmt:general-open-connection -> + rmt:send-receive-real; + + +// check_available_queue -> remove_entries_over_10s_old; +// remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; +// remove_entries_over_10s_old -> exit [label="num_avail > 2"]; +// +// set_available -> delay_2s; +// delay_2s -> check_place_in_queue; +// +// check_place_in_queue -> "http:transport-launch" [label="at head"]; +// check_place_in_queue -> exit [label="not at head"]; +// +// "client:login" -> "server:shutdown" [label="login failed"]; +// "server:shutdown" -> exit; +// +// subgraph cluster_2 { +// "http:transport-launch" -> "http:transport-run"; +// "http:transport-launch" -> "http:transport-keep-running"; +// +// "http:transport-keep-running" -> "tests running?"; +// "tests running?" -> "client:login" [label=yes]; +// "tests running?" -> "server:shutdown" [label=no]; +// "client:login" -> delay_5s [label="login ok"]; +// delay_5s -> "http:transport-keep-running"; +// } +// +// // start_server -> "server_running?"; +// // "server_running?" -> set_available [label="no"]; +// // "server_running?" -> delay_2s [label="yes"]; +// // delay_2s -> "still_running?"; +// // "still_running?" -> ping_server [label=yes]; +// // "still_running?" -> set_available [label=no]; +// // ping_server -> exit [label=alive]; +// // ping_server -> remove_server_record [label=dead]; +// // remove_server_record -> set_available; +// // set_available -> avail_delay [label="delay 3s"]; +// // avail_delay -> "first_in_queue?"; +// // +// // "first_in_queue?" -> set_running [label=yes]; +// // set_running -> get_next_port -> handle_requests; +// // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; +// // "dead_entry_in_queue?" -> "server_running?" [label=no]; +// // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; +// // remove_dead_entries -> "server_running?"; +// // +// // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; +// // handle_requests -> shutdown_request; +// // start_shutdown -> shutdown_delay; +// // shutdown_request -> shutdown_delay; +// // shutdown_delay -> exit; +// +// label = "server:launch"; +// color=brown; } // client_start_server -> start_server; // handle_requests -> read_write; // read_write -> handle_requests; Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -141,11 +141,11 @@ ;; (print "COMMON: " (string-intersperse common-parts "\n ")) (string-intersperse final separator))) (define (env:process-path-envvar varname separator patha pathb) (let ((newpath (env:merge-path-envvar separator patha pathb))) - (setenv varname newpath))) + (set-environment-variable! varname newpath))) (define (env:have-context db context) (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) 0)) Index: ezstepsmod.scm ================================================================== --- ezstepsmod.scm +++ ezstepsmod.scm @@ -132,11 +132,11 @@ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (common:file-exists? logpro-file))) - (setenv "MT_STEP_NAME" stepname) + (set-environment-variable! "MT_STEP_NAME" stepname) (hash-table-set! all-steps-dat stepname `((params . ,paramparts))) (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) (if (and tconfig-logpro @@ -203,11 +203,11 @@ (processloop (+ i 1)))) ))))) (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) ;; now run logpro if needed (if logpro-used - (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro")) + (let* ((logpro-exe (or (get-environment-variable "LOGPRO_EXE") "logpro")) (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'")))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code) Index: itemsmod.scm ================================================================== --- itemsmod.scm +++ itemsmod.scm @@ -20,10 +20,11 @@ (declare (unit itemsmod)) (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses configfmod)) +(declare (uses commonmod)) (module itemsmod * (import scheme @@ -164,14 +165,14 @@ (set! res (append res (list item))) (loop (+ indx 1) '() #f))) res))) - ;; Nope, not now, return null as of 6/6/2011 - -(define (items:check-valid-items class item) - (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class))) +;; Nope, not now, return null as of 6/6/2011 + +(define (items:check-valid-items valid-values class item) + (let ((valid-values (let ((s valid-values)) ;; (configf:lookup *configdat* "validvalues" class))) (if s (string-split s) #f)))) (if valid-values (if (member item valid-values) item #f) item))) Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -125,11 +125,11 @@ (debug:print 0 *default-log-port* "keep-going=" keep-going) (and keep-going (equal? (car keep-going) "yes"))))) ;; if handed a string, process it, else look for MT_CMDINFO (define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) - (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) + (let ((enccmd (if encoded-cmd encoded-cmd (get-environment-variable "MT_CMDINFO")))) (if enccmd (common:read-encoded-string enccmd) '()))) (define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m) @@ -218,11 +218,11 @@ ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) (let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)) (stepname (car ezstep)) (stepparms (hash-table-ref all-steps-dat stepname))) - (setenv "MT_STEP_NAME" stepname) + (set-environment-variable! "MT_STEP_NAME" stepname) (pp (hash-table->alist all-steps-dat)) ;; if logpro-used read in the stepname.dat file (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) (launch:load-logpro-dat run-id test-id stepname)) (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms) @@ -286,11 +286,11 @@ (set! kill-job? #f))) (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync) (launch:handle-zombie-tests run-id) (when do-sync - ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append) + ;;(with-output-to-file (conc (get-environment-variable "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append) ;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes))))) ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds))) (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds))) ) @@ -355,11 +355,11 @@ (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) - (setenv "MT_CMDINFO" encoded-cmd) + (set-environment-variable! "MT_CMDINFO" encoded-cmd) ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) @@ -434,31 +434,31 @@ (launch:test-copy testpath work-area)))) ;; one more time, change to the work-area directory (change-directory work-area))) ) ;; let* - (if contour (setenv "MT_CONTOUR" contour)) + (if contour (set-environment-variable! "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) + (set-environment-variable! "MT_TESTSUITENAME" areaname) + (set-environment-variable! "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) + (set-environment-variable! "MT_TEST_RUN_DIR" work-area) (launch:setup) ;; should be properly in the run area home now - (if contour (setenv "MT_CONTOUR" contour)) + (if contour (set-environment-variable! "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) + (set-environment-variable! "MT_TESTSUITENAME" areaname) + (set-environment-variable! "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) + (set-environment-variable! "MT_TEST_RUN_DIR" work-area) (launch:setup) ;; should be properly in the run area home now (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path (let ((sighand (lambda (signum) @@ -592,19 +592,19 @@ (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") - (setenv var val))))) + (set-environment-variable! var val))))) varpairs))) ;;(bb-check-path msg: "launch:execute post block 2") (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val - (setenv var val) + (set-environment-variable! var val) (begin (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) @@ -616,11 +616,11 @@ (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (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))) + (if mt-bindir-path (set-environment-variable! "PATH" (conc (get-environment-variable "PATH") ":" mt-bindir-path))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -635,11 +635,11 @@ (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) (if blacklist (let ((vars (string-split blacklist))) (save-environment-as-files "megatest" ignorevars: vars) (for-each (lambda (var) - (unsetenv var)) + (unset-environment-variable! var)) vars)) (save-environment-as-files "megatest"))) ;;(bb-check-path msg: "launch:execute post block 44") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) @@ -768,11 +768,11 @@ (args:get-arg "-execute"))) (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target exit-if-bad: #t)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname") - (getenv "MT_RUNNAME"))) + (get-environment-variable "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree (begin @@ -921,16 +921,16 @@ (set! toppath *toppath*) (if (not *toppath*) (begin (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (common:list-or-null (rmt:get-keys) message: "Failed to retrieve keys in launch.scm. Please report this to the developers.")) (key-vals (keys:target->keyval keys target)) - (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + (linktree (common:get-linktree)) ;; (or (get-environment-variable "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) ; (if *configdat* ; (configf:lookup *configdat* "setup" "linktree") ; (conc *toppath* "/lt")))) (second-pass (configf:find-and-read-config mtconfig @@ -938,11 +938,11 @@ given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME" env-to-use: (module-environment 'bigmod))) (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) + (set-environment-variable! (car kt) (cadr kt))) key-vals) (configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... sections: sections))) (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) @@ -1018,12 +1018,12 @@ (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") ))) (if (and *toppath* (directory-exists? *toppath*)) (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITENAME" (common:get-area-name))) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "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)) @@ -1299,21 +1299,21 @@ (define (launch:handle-zombie-tests run-id) (let* ((key (conc "zombiescan-runid-"run-id)) (now (current-seconds)) (threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120)))) - (val (rmt:get-var key)) + (val (rmt:get-var run-id key)) (do-scan? (cond ((not val) #t) ((< val threshold) #t) (else #f)))) (when do-scan? (debug:print 1 *default-log-port* "INFO: search and mark zombie tests") - (rmt:set-var key (current-seconds)) + (rmt:set-var run-id key (current-seconds)) (runs:find-and-mark-incomplete-and-check-end-of-run run-id #f)))) @@ -1888,29 +1888,29 @@ ;; 0 RUNNING ==> this is actually the first condition, should not get here (define (runs:end-of-run-check run-id ) (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id)) (running-cnt (rmt:get-count-tests-running-for-run-id run-id)) - (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) + (all-test-launched (rmt:get-var run-id (conc "lunch-complete-" run-id))) (current-state (rmt:get-run-state run-id)) (current-status (rmt:get-run-status run-id))) ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing (debug:print 0 *default-log-port* "Running test cnt :" running-cnt) (rmt:set-state-status-and-roll-up-run run-id current-state current-status) (runs:update-junit-test-reporter-xml run-id) (cond ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" )) - (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) + (if (and (equal? (rmt:get-var run-id (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) (begin - (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id))) + (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var run-id (conc "end-of-run-" run-id))) (debug:print 0 *default-log-port* "End of Run Detected.") (rmt:set-var (conc "end-of-run-" run-id) "yes") ;(thread-sleep! 10) (runs:run-post-hook run-id) - (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id))) + (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var run-id (conc "end-of-run-" run-id))) (common:simple-unlock (conc "endOfRun" run-id))) - (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id))))) + (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var run-id (conc "end-of-run-" run-id))))) ((> running-cnt 3) (debug:print 0 *default-log-port* "There are " running-cnt " tests running." )) ((> running-cnt 0) (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" ) (let ((kill-cnt (launch:kill-tests-if-dead run-id))) @@ -1968,11 +1968,11 @@ #f ;; get full data (not 'shortlist) 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time 'dashboard) '())) (log-dir (conc *toppath* "/logs")) - (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (log-file (conc "post-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log")) (full-log-fname (conc log-dir "/" log-file))) (if run-post-hook ;; (if (null? existing-tests) ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run."))))) (let* ((use-log-dir (if (not (directory-exists? log-dir)) @@ -1998,11 +1998,11 @@ (define (runs:rerun-hook test-id new-test-path testdat rerunlst) (let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook")) (log-dir (conc *toppath* "/reruns/logs")) - (target (getenv "MT_TARGET")) + (target (get-environment-variable "MT_TARGET")) (runname (common:args-get-runname)) (rundir (db:test-get-rundir testdat)) (tarfiledir (conc *toppath* "/reruns")) (status (db:test-get-status testdat)) (comment (conc "\"" (db:test-get-comment testdat) "\"" )) @@ -2053,14 +2053,14 @@ (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir - (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) + (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME"))) #f)) (xml-ts-name (if xml-dir - (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME")) + (conc (get-environment-variable "MT_TESTSUITENAME")"."(string-translate (get-environment-variable "MT_TARGET") "/" ".") "." (get-environment-variable "MT_RUNNAME")) #f)) (keyname (if xml-ts-name (common:get-signature xml-ts-name) #f)) (xml-path (if xml-dir (conc xml-dir "/" keyname ".xml") #f)) @@ -2141,11 +2141,11 @@ (testsuite))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) - (setenv (car item) (cadr item))) + (set-environment-variable! (car item) (cadr item))) itemdat)) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) @@ -2155,16 +2155,16 @@ (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (common:get-fields *configdat*) #;(rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) + (if testname (set-environment-variable! "MT_TEST_NAME" testname)) + (if itempath (set-environment-variable! "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree - (setenv "MT_LINKTREE" link-tree) + (set-environment-variable! "MT_LINKTREE" link-tree) (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) @@ -2180,11 +2180,11 @@ (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) - (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) + (if (not (get-environment-variable "MT_TARGET"))(set-environment-variable! "MT_TARGET" target)) ;; we had a case where there was an exception generated by the hash-table-ref ;; due to *configdat* being #f Adding a handle and exit (let fatal-loop ((count 0)) (handle-exceptions exn @@ -2217,22 +2217,22 @@ (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname - (setenv "MT_RUNNAME" runname) + (set-environment-variable! "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) + (if testname (set-environment-variable! "MT_TEST_NAME" testname)) + (if itempath (set-environment-variable! "MT_ITEMPATH" itempath)) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") (if (and testname link-tree) - (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") + (set-environment-variable! "MT_TEST_RUN_DIR" (conc (get-environment-variable "MT_LINKTREE") "/" + (get-environment-variable "MT_TARGET") "/" + (get-environment-variable "MT_RUNNAME") "/" + (get-environment-variable "MT_TEST_NAME") (if (and itempath (not (equal? itempath ""))) (conc "/" itempath) "")))))) @@ -2244,12 +2244,12 @@ ;; (if (eq? *configstatus* 'fulldata) ;; *runconfigdat* ;; (begin ;; (launch:setup) ;; *runconfigdat*))) - (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) - (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) + (let* ((rundir (if (and (get-environment-variable "MT_LINKTREE")(get-environment-variable "MT_TARGET")(get-environment-variable "MT_RUNNAME")) + (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf (file-exists? cfgf) (file-writable? cfgf) @@ -2258,14 +2258,14 @@ (let* ((keys (common:get-fields *configdat*)) ;; (rmt:get-keys)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) + (set-environment-variable! (car kt) (cadr kt))) key-vals)) ;; (configf:read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) @@ -2289,13 +2289,16 @@ (dbfile (args:get-arg "-db")) (apath *toppath*)) (let loop () (thread-sleep! 5) ;; add control / setting for this (if am-server - (if (not *dbstruct-db*) + (if (not *dbstruct-db*) ;; skip syncing until db is setup (loop) - (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile)))))) + (begin + ;; (debug:print-info 0 *default-log-port* "syncing "apath" "dbfile" at "(current-seconds)) + ;; (db:sync-inmem->disk *dbstruct-db* apath dbfile) + (loop))))))) ;; ;; (let ((dbstruct ;; (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) ;; (cond Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -128,11 +128,10 @@ ;; local modules autoload adjutant csv-xml - ducttape-lib hostinfo mtver mutils cookie csv-xml @@ -169,13 +168,13 @@ ;; (include "key_records.scm") ;; (include "db_records.scm") (include "run_records.scm") ;; (include "test_records.scm") -(include "common.scm") +;; (include "common.scm") (include "db.scm") -(include "server.scm") +;; (include "server.scm") (include "tests.scm") (include "genexample.scm") (include "tdb.scm") (include "env.scm") (include "diff-report.scm") @@ -182,20 +181,20 @@ (include "ods.scm") (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file - ;;====================================================================== - ;; Test commands (i.e. for use inside tests) - ;;====================================================================== - - (define (megatest:step step state status logfile msg) - (if (not (getenv "MT_CMDINFO")) - (begin +;;====================================================================== +;; Test commands (i.e. for use inside tests) +;;====================================================================== + +(define (megatest:step step state status logfile msg) + (if (not (get-environment-variable "MT_CMDINFO")) + (begin (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) - (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (let* ((cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) @@ -215,18 +214,18 @@ (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") (exit 6)))))) - ;;====================================================================== - ;; full run - ;;====================================================================== - - (define (handle-run-requests target runname keys keyvals need-clean) - (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct - ;; For rerun-clean do we or do we not support the testpatt? - (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") +;;====================================================================== +;; full run +;;====================================================================== + +(define (handle-run-requests target runname keys keyvals need-clean) + (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct + ;; For rerun-clean do we or do we not support the testpatt? + (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) (hash-table-set! args:arg-hash "-preclean" #t) (runs:operate-on 'set-state-status @@ -244,13 +243,13 @@ ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;; state: states status: statuses new-state-status: "NOT_STARTED,n/a"))) - ;; RERUN ALL - (if (args:get-arg "-rerun-all") ;; first set states/statuses correct - (let* ((rconfig (full-runconfigs-read))) + ;; RERUN ALL + (if (args:get-arg "-rerun-all") ;; first set states/statuses correct + (let* ((rconfig (full-runconfigs-read))) (hash-table-set! args:arg-hash "-preclean" #t) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") @@ -263,80 +262,80 @@ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") ;; state: states status: #f new-state-status: "NOT_STARTED,n/a"))) - (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) + (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (rerun-cnt (if config-reruns config-reruns 1))) - - (runs:run-tests target + + (runs:run-tests target runname #f ;; (common:args-get-testpatt #f) ;; (or (args:get-arg "-testpatt") ;; "%") (bdat-user *bdat*) args:arg-hash run-count: rerun-cnt))) - ;; csv processing record - (define (make-refdb:csv) - (vector - (make-sparse-array) - (make-hash-table) - (make-hash-table) - 0 - 0)) - (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) - (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) - (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) - (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) - (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) - (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) - (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) - (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) - (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) - (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) - - (define (get-dat results sheetname) - (or (hash-table-ref/default results sheetname #f) - (let ((tmp-vec (make-refdb:csv))) +;; csv processing record +(define (make-refdb:csv) + (vector + (make-sparse-array) + (make-hash-table) + (make-hash-table) + 0 + 0)) +(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) +(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) +(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) +(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) +(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) +(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) +(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) +(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) +(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) +(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) + +(define (get-dat results sheetname) + (or (hash-table-ref/default results sheetname #f) + (let ((tmp-vec (make-refdb:csv))) (hash-table-set! results sheetname tmp-vec) tmp-vec))) - - ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions - (define (open-logfile logpath-in) - (condition-case - (let* ((log-dir (or (pathname-directory logpath-in) ".")) + +;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions +(define (open-logfile logpath-in) + (condition-case + (let* ((log-dir (or (pathname-directory logpath-in) ".")) (fname (pathname-strip-directory logpath-in)) (logpath (if (> (string-length fname) 250) (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) newlogf) logpath-in))) - (if (not (directory-exists? log-dir)) - (system (conc "mkdir -p " log-dir))) - (open-output-file logpath)) - (exn () - (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) - (define *didsomething* #t) - (exit 1)))) + (if (not (directory-exists? log-dir)) + (system (conc "mkdir -p " log-dir))) + (open-output-file logpath)) + (exn () + (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) + (define *didsomething* #t) + (exit 1)))) (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") - (getenv "MT_DEBUG_MODE")))) + (get-environment-variable "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr 'q)) (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 (and (not (args:get-arg "-debug-noprop")) (or (args:get-arg "-debug") - (not (getenv "MT_DEBUG_MODE")))) - (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) + (not (get-environment-variable "MT_DEBUG_MODE")))) + (set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) @@ -349,11 +348,11 @@ ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys ;; -daemonize : fork into background and disconnect from stdin/out - + (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2017 @@ -773,24 +772,24 @@ ;; before doing anything else change to the start-dir if provided ;; (if (args:get-arg "-start-dir") (if (common:file-exists? (args:get-arg "-start-dir")) (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) + (set-environment-variable! "PWD" fullpath) (change-directory fullpath)) (begin (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) - (if targ (setenv "MT_TARGET" targ))) + (if targ (set-environment-variable! "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; -(init-watchdog) +;; (init-watchdog) ;; (define (debug:debug-mode n) ;; (cond ;; ((and (number? *verbosity*) ;; number number ;; (number? n)) @@ -912,22 +911,23 @@ (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (if (args:get-arg "-runtests") (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) - - (on-exit std-exit-procedure) + + (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable") + ;; (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== ;; TODO: Restore this functionality #; (if (and (args:get-arg "-cache-db") (args:get-arg "-source-db")) - (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) + (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_"))))) (target-db (conc temp-dir "/cached.db")) (source-db (args:get-arg "-source-db"))) (db:cache-for-read-only source-db target-db) (set! *didsomething* #t))) @@ -1263,12 +1263,12 @@ (set! *didsomething* #t) (pop-directory) (bdat-time-to-exit-set! *bdat* #t))) (if (args:get-arg "-show-cmdinfo") - (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) - (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) + (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")) + (let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) @@ -2059,13 +2059,13 @@ ;; Get paths to tests ;;====================================================================== ;; Get test paths matching target, runname, and testpatt (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data - (if (getenv "MT_CMDINFO") + (if (get-environment-variable "MT_CMDINFO") (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) @@ -2226,16 +2226,16 @@ (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") (args:get-arg "-runstep") (args:get-arg "-summarize-items")) - (if (not (getenv "MT_CMDINFO")) + (if (not (get-environment-variable "MT_CMDINFO")) (begin (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) @@ -2452,11 +2452,11 @@ (args:get-arg "-diff-html") (args:get-arg "-diff-email")) (set! *didsomething* #t) (exit 0))) - (if (or (getenv "MT_RUNSCRIPT") + (if (or (get-environment-variable "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup))) ;; (dbstruct (if (and toppath @@ -2463,11 +2463,11 @@ ;; #;(common:on-homehost?)) ;; (db:setup #f) ;; sets up main.db ;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if *toppath* (cond - ((getenv "MT_RUNSCRIPT") + ((get-environment-variable "MT_RUNSCRIPT") ;; How to run megatest scripts ;; ;; #!/bin/bash ;; ;; export MT_RUNSCRIPT=yes ADDED nng-trial/Makefile Index: nng-trial/Makefile ================================================================== --- /dev/null +++ nng-trial/Makefile @@ -0,0 +1,5 @@ +nng-test : nng-test.scm + csc nng-test.scm + +test : nng-test + ./nng-test do-test ADDED nng-trial/nng-test.scm Index: nng-trial/nng-test.scm ================================================================== --- /dev/null +++ nng-trial/nng-test.scm @@ -0,0 +1,153 @@ +(import (chicken io) + (chicken file) + (chicken file posix) + (chicken string) + (chicken process-context) + (chicken process-context posix) + miscmacros + nng + srfi-18 + srfi-69 + test + matchable + typed-records + system-information + directory-utils + ) + +(define help "Usage: nng-test COMMAND + where COMMAND is one of: + dotest : run the basic req/rep test +") + +(define address-tcp-1 "tcp://localhost:5555") +(define address-tcp-2 "tcp://localhost:6666") + +(define address-inproc-1 "inproc://local1") +(define address-inproc-2 "inproc://local2") + +;;; +;;; Req-Rep +;;; +(define (make-listening-reply-socket address) + (let ((socket (make-rep-socket))) + (socket-set! socket 'nng/recvtimeo 2000) + (nng-listen socket address) + socket)) + +(define (make-dialed-request-socket address) + (let ((socket (make-req-socket))) + (socket-set! socket 'nng/recvtimeo 2000) + (nng-dial socket address) + socket)) + +(define (req-rep-test address) + (let ((rep (make-listening-reply-socket address)) + (req (make-dialed-request-socket address))) + (nng-send req "message 1") + (nng-recv rep) + (nng-send rep "message") + (begin0 + (nng-recv req) + (nng-close! rep)))) + +(define (do-test) + (test-group "nng" + (test "tcp req-rep" + "message" + (req-rep-test address-tcp-1)) + (test "inproc req-rep" + "message" + (req-rep-test address-inproc-1))) + (test-exit)) + +;; talking to self here... +;; +(define (send-n-messages n srvdat) + (let* ((name (srv-name srvdat))) + (let loop ((i 0)) + (if (< i n) + (begin + (nng-send (srv-req srvdat) (conc name "-" i)) + (print "received: "(nng-recv (srv-rep srvdat))) + (loop (+ i 1))))))) + +;; this should be run in a thread +(define (run-listener-responder socket myaddr) + (let loop ((status 'running)) + (let* ((msg (nng-recv socket)) + (response (process-message msg))) + (if (not (eq? response 'done)) + (begin + (nng-send socket response) + (loop status)))))) + +(define *channels* (make-hash-table)) + +(define (call channels msg addr) + (let* ((csocket (hash-table-ref/default channels addr #f)) + (socket (or csocket (make-dialed-request-socket addr)))) + (nng-send socket msg) + (print "Sent: "msg", received: "(nng-recv socket)) + (if (not (hash-table-exists? channels addr)) + (hash-table-set! channels addr socket)))) + +;; start => hello 0 +;; hello 0 => hello 1 +;; hello 1 => hello 2 +;; ... +;; hello 11 => 'done +;; +(define (process-message mesg) + (let ((parts (string-split mesg))) + (match + parts + ((msg c) + (let ((count (string->number c))) + (if (> count 10) + 'done + (conc msg " " (if count count 0))))) + ((msg) + (conc msg " 0")) + (else + "hello 0")))) + +(define (close-srv srvdat) + (nng-close! (srv-rep srvdat))) + +(match + (command-line-arguments) + (("do-test")(do-test)) + ((run myaddr) + ;; start listener + ;; put myaddr into file by host-pid in .runners + ;; for 1 minute + ;; get all in .runners + ;; call each with a message + ;; + (let* ((socket (make-listening-reply-socket myaddr)) + (rfile (conc ".runners/"(get-host-name)"-"(current-process-id))) + (th1 (make-thread (lambda () + (run-listener-responder socket myaddr) + (delete-file* rfile) + (exit)) + "responder"))) + (if (not (and (file-exists? ".runners") + (directory? ".runners"))) + (create-directory ".runners" #t)) + (with-output-to-file rfile + (lambda () + (print myaddr))) + (thread-start! th1) + (let loop ((entries '())) + (if (null? entries) + (loop (glob ".runners/*")) + (let* ((entry (car entries)) + (destaddr (with-input-from-file entry read-line))) + (call *channels* (conc "hello-from-"destaddr) destaddr) + (thread-sleep! 0.25) + (loop (cdr entries))))))) + ((cmd)(print "ERROR: command "cmd", not recognised.\n\n"help)) + (else + (print help))) + Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -62,10 +62,11 @@ ;; http-client ;; intarweb matchable md5 message-digest + nng ;; nanomsg (prefix base64 base64:) (prefix sqlite3 sqlite3:) regex s11n ;; spiffy @@ -75,11 +76,11 @@ srfi-13 srfi-18 srfi-69 stack system-information - tcp6 + ;; tcp6 typed-records uri-common z3 apimod @@ -119,10 +120,11 @@ ;; (defstruct servdat (host #f) (port #f) (uuid #f) + (rep #f) (dbfile #f) (api-url #f) (api-uri #f) (api-req #f) (status 'starting) @@ -243,15 +245,16 @@ (start-main-srv)))) ;; NB// remote is a rmt:remote struct ;; (define (rmt:general-open-connection remote apath dbname #!key (num-tries 5)) - (let ((mdbname (db:run-id->dbname #f))) + (let* ((mdbname (db:run-id->dbname #f)) + (mconn (rmt:get-conn remote apath mdbname))) (cond - ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main? + ((or (not mconn) ;; no channel open to main? + (< (rmt:conn-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease (rmt:open-main-connection remote apath) - (thread-sleep! 2) (rmt:general-open-connection remote apath mdbname)) ((not (rmt:get-conn remote apath dbname)) ;; no channel open to dbname? (let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname)))) (case res ((server-started) @@ -262,27 +265,60 @@ (begin (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname) (exit 1)))) (else (if (list? res) ;; server has been registered and the info was returned. pass it on. - res + (begin ;; ("192.168.0.9" 53817 + ;; "5e34239f48e8973b3813221e54701a01" "24310" + ;; "192.168.0.9" + ;; "/home/matt/data/megatest/tests/simplerun" + ;; ".db/1.db") + (match + res + ((host port servkey pid ipaddr apath dbname) + (debug:print-info 0 *default-log-port* "got "res) + (hash-table-set! (rmt:remote-conns remote) + dbname + (make-rmt:conn + apath: apath + dbname: dbname + hostport: (conc host":"port) + ipaddr: ipaddr + port: port + srvkey: servkey + lastmsg: (current-seconds) + expires: (+ (current-seconds) 60)))) + (else + (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res))) + res) (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) - res))))))))) + res)))))) + + + ))) ;;====================================================================== +;; FOR DEBUGGING SET TO #t +(define *localmode* #t) +(define *dbstruct* (make-dbr:dbstruct)) ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) - (let* ((apath *toppath*) - (conns *rmt:remote*) - (dbname (db:run-id->dbname rid))) - (rmt:general-open-connection conns apath dbname) - (rmt:send-receive-real conns apath dbname cmd params))) + (let* ((apath *toppath*) + (conns *rmt:remote*) + (dbname (db:run-id->dbname rid))) + (if *localmode* + (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname)) + (indat `((cmd . ,cmd)(params . ,params)))) + (api:process-request *dbstruct* indat)) + (begin + (rmt:general-open-connection conns apath dbname) + (rmt:send-receive-real conns apath dbname cmd params))))) #;(define (rmt:send-receive-setup conn) (if (not (rmt:conn-inport conn)) (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) (rmt:conn-port conn)))) @@ -293,31 +329,19 @@ ;; sometime in the future ;; (define (rmt:send-receive-real remote apath dbname cmd params) (let* ((conn (rmt:get-conn remote apath dbname))) (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened") - (pp (rmt:conn->alist conn)) - ;; (rmt:send-receive-setup conn) - (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) - (rmt:conn-port conn)))) - (let* ((key #f) - (payload `((cmd . ,cmd) - (key . ,(rmt:conn-srvkey conn)) - (params . ,params))) - (res (begin - (write payload o) ;; (rmt:conn-outport conn)) - (with-input-from-port - i ;; (rmt:conn-inport conn) - read)))) - (close-input-port i) - (close-output-port o) - res)))) -;; (if (string? res) -;; (string->sexpr res) -;; res)))) - - + (let* ((key #f) + (host (rmt:conn-ipaddr conn)) + (port (rmt:conn-port conn)) + (payload `((cmd . ,cmd) + (key . ,(rmt:conn-srvkey conn)) + (params . ,params))) + (res (open-send-receive-nn (conc host":"port) + (sexpr->string payload)))) + (string->sexpr res)))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future. ;; ;; Purpose - call the main.db server and request a server be started @@ -332,11 +356,11 @@ ;; read-string))) ;; (string->sexpr res)))) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" - (debug:print 18 *default-log-port* "DB Stats\n========") + (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================") (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) @@ -677,12 +701,11 @@ ;; first register in main.db (thus the #f) (let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))) ;; now register in the run db itself ;; NEED A RECORD INSERT INCLUDING SETTING id - (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour)) - + (rmt:send-receive 'insert-run run-id (list run-id keyvals runname state status user contour)) run-id)) (define (rmt:get-run-name-from-id run-id) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) @@ -738,27 +761,27 @@ ) ;; ) (define (rmt:get-main-run-stats run-id) (rmt:send-receive 'get-main-run-stats #f (list run-id))) -(define (rmt:get-var varname) - (rmt:send-receive 'get-var #f (list varname))) - -(define (rmt:del-var varname) - (rmt:send-receive 'del-var #f (list varname))) - -(define (rmt:set-var varname value) - (rmt:send-receive 'set-var #f (list varname value))) - -(define (rmt:inc-var varname) - (rmt:send-receive 'inc-var #f (list varname))) - -(define (rmt:dec-var varname) - (rmt:send-receive 'dec-var #f (list varname))) - -(define (rmt:add-var varname value) - (rmt:send-receive 'add-var #f (list varname value))) +(define (rmt:get-var run-id varname) + (rmt:send-receive 'get-var run-id (list run-id varname))) + +(define (rmt:del-var run-id varname) + (rmt:send-receive 'del-var run-id (list run-id varname))) + +(define (rmt:set-var run-id varname value) + (rmt:send-receive 'set-var run-id (list run-id varname value))) + +(define (rmt:inc-var run-id varname) + (rmt:send-receive 'inc-var #f (list run-id varname))) + +(define (rmt:dec-var run-id varname) + (rmt:send-receive 'dec-var run-id (list run-id varname))) + +(define (rmt:add-var run-id varname value) + (rmt:send-receive 'add-var run-id (list run-id varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== @@ -816,12 +839,13 @@ ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) - (let* ((state (items:check-valid-items "state" state-in)) - (status (items:check-valid-items "status" status-in))) + (let* ((valid-values (configf:lookup *configdat* "validvalues" "state")) + (state (items:check-valid-items valid-values "state" state-in)) + (status (items:check-valid-items valid-values "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) @@ -1396,18 +1420,18 @@ ;;====================================================================== ;; from metadat lookup MEGATEST_VERSION ;; (define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB - (rmt:get-var "MEGATEST_VERSION")) + (rmt:get-var #f "MEGATEST_VERSION")) (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) - (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) + (rmt:set-var #f "MEGATEST_VERSION" (common:version-signature))) ;;====================================================================== ;; faux-lock is deprecated. Please use simple-lock below ;; (define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) @@ -1443,10 +1467,57 @@ (common:version-signature)))) (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) + +(define (rmt:server-shutdown) + (let ((dbfile (servdat-dbfile *server-info*))) + (debug:print-info 0 *default-log-port* "dbfile is "dbfile) + (if dbfile + (let* ((am-server (args:get-arg "-server")) + (dbfile (args:get-arg "-db")) + (apath *toppath*) + (dbdat (db:get-dbdat *dbstruct-db* apath dbfile)) + (db (dbr:dbdat-db dbdat)) + (inmem (dbr:dbdat-db dbdat)) + ) + ;; do a final sync here + (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) + (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) + ;; let's finalize here + (debug:print-info 0 *default-log-port* "Finalizing db and inmem") + (sqlite3:finalize! db) + (sqlite3:finalize! inmem) + (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete") + (if am-server + (if (string-match ".*/main.db$" dbfile) + (let ((pkt-file (conc (get-pkts-dir *toppath*) + "/" (servdat-uuid *server-info*) + ".pkt"))) + (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) + (delete-file* pkt-file) + (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) + (db:with-lock-db (servdat-dbfile *server-info*) + (lambda (dbh dbfile) + (db:release-lock dbh dbfile)))) + (let* ((sdat *server-info*) ;; we have a run-id server + (host (servdat-host sdat)) + (port (servdat-port sdat)) + (uuid (servdat-uuid sdat))) + (if (not (string-match ".db/main.db" (args:get-arg "-db"))) + (let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*? + *toppath* + (servdat-host *server-info*) ;; iface + (servdat-port *server-info*) + (servdat-uuid *server-info*) + (current-process-id) + ))) + (debug:print-info 0 *default-log-port* "deregistered-server, res="res))) + + (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid) + ))))))) (define (std-exit-procedure) ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) @@ -1456,56 +1527,40 @@ (bdat-time-to-exit-set! *bdat* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) - (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (if *server-info* - (let ((pkt-file (conc (get-pkts-dir *toppath*) - "/" (servdat-uuid *server-info*) - ".pkt")) - (dbfile (servdat-dbfile *server-info*))) - (if dbfile - (begin - - ;; do a final sync here - - (if (string-match ".*/main.db$" dbfile) - (begin - (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) - (delete-file* pkt-file) - (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) - (db:with-lock-db (servdat-dbfile *server-info*) - (lambda (dbh dbfile) - (db:release-lock dbh dbfile)))) - (let* ((sdat *server-info*)) ;; we have a run-id server - (rmt:send-receive-real *rmt:remote* *toppath* - (db:run-id->dbname #f) - 'deregister-server - `(,(servdat-uuid sdat) - ,(current-process-id) - ,(servdat-host sdat) ;; iface - ,(servdat-port sdat))))))))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated - (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db - (let ((db (cdr (bdat-task-db *bdat*)))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t) - (bdat-task-db-set! *bdat* #f))))) - #;(http-client#close-idle-connections!) - (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")) + (let ((th1 (make-thread + (lambda () ;; thread for cleaning up, give it five seconds + (let* ((start-time (current-seconds))) + (if (and *server-info* + *unclean-shutdown*) + (begin + (debug:print-info 0 *default-log-port* "Unclean server exit, calling server-shtudown") + (rmt:server-shutdown))) + (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds")) + ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated + #;(if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db + (let ((db (cdr (bdat-task-db *bdat*)))) + (if (sqlite3:database? db) + (begin + (debug:print-info 0 *default-log-port* "Closing down task db "db) + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (bdat-task-db-set! *bdat* #f))))) + #;(http-client#close-idle-connections!) + (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...") + (debug:print 4 *default-log-port* "Attempting clean exit. Mode="(if no-hurry "no-hurry" "normal") + " Please be patient and wait a few seconds...") (if no-hurry (begin (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff (begin - (thread-sleep! 2))) + (thread-sleep! 2))) (debug:print 4 *default-log-port* " ... done") ) "clean exit"))) (thread-start! th1) (thread-start! th2) @@ -1539,38 +1594,13 @@ ;;====================================================================== ;; S E R V E R ;; ====================================================================== -;; NOTE: http-transport:launch is the entry point -;; -> http-transport:run -;; -> http-transport:try-start-server -> http-transport:try-start-server (until success) - (define (http-get-function fnkey) (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet"))) -#;(define (rmt:launch-server hostn port) - (if *server-info* - (begin - (servdat-host-set! *server-info* hostn) - (servdat-port-set! *server-info* port) - (servdat-status-set! *server-info* 'trying-port) - (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) - (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) - (let* ((l (tcp-listen port)) - (dbstruct #f)) - (let-values (((i o) (tcp-accept l))) - ;; (write-line "Hello!" o) - (let loop ((indat (read i))) - (let* ((res (api:process-request dbstruct indat))) - (case res - ((quit) - (close-input-port i) - (close-output-port o)) - (else - (write res o)))))))) - (define (rmt:run hostn) ;; ;; Configurations for server ;; (tcp-buffer-size 2048) ;; (max-connections 2048) (debug:print 2 *default-log-port* "Attempting to start the server ...") @@ -1581,73 +1611,111 @@ (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (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)) #;(start-file (conc tmp-area "/.server-start"))) (debug:print-info 0 *default-log-port* "portlogger recommended port: " port) (if *server-info* (begin (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* port) (servdat-status-set! *server-info* 'trying-port) (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: port))) - (let* ((l (rmt:try-start-server ipaddrstr port))) - (let oloop () - (let-values (((i o) (tcp-accept l))) - ;; (write-line "Hello!" o) - (let loop ((indat (read i))) - (if (eof-object? indat) - (begin - (close-input-port i) - (close-output-port o) - (oloop)) - (let* ((res (api:process-request *dbstruct-db* indat))) - (set! *db-last-access* (current-seconds)) - (write res o) - (loop (read i)))))))) + (let* ((rep (rmt:try-start-server ipaddrstr port))) + (let loop ((instr (nng-recv rep))) + (let* ((data (string->sexpr instr)) + (res (case data + ((quit) 'quit) + (else (api:process-request *dbstruct-db* data)))) + (resdat (sexpr->string res))) + (if (not (eq? res 'quit)) + (begin + (set! *db-last-access* (current-seconds)) + (nng-send rep resdat) + (loop (nng-recv rep))))))) + (debug:print-info 0 *default-log-port* "After server, should never see this") + ;; server exit stuff here (let* ((portnum (servdat-port *server-info*))) (portlogger:open-run-close portlogger:set-port portnum "released") - (debug:print 1 *default-log-port* "INFO: server has been stopped")))) + (rmt:server-shutdown) + ;; (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up + (portlogger:open-run-close portlogger:set-port port "released") ;; done in rmt:run + ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) + ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*) + ;; (debug:print-info 0 *default-log-port* "Average cached write time " + ;; (if (eq? *number-of-writes* 0) + ;; "n/a (no writes)" + ;; (/ *writes-total-delay* + ;; *number-of-writes*)) + ;; " ms") + ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*) + ;; (debug:print-info 0 *default-log-port* "Average non-cached time " + ;; (if (eq? *number-non-write-queries* 0) + ;; "n/a (no queries)" + ;; (/ *total-non-write-delay* + ;; *number-non-write-queries*)) + ;; " ms") + + (db:print-current-query-stats) + (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") + ))) (define (rmt:try-start-server ipaddrstr portnum) - (if *server-info* + (if *server-info* ;; update the server info as we might be trying next port (begin (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* portnum) (servdat-status-set! *server-info* 'trying-port) - (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) + (servdat-trynum-set! *server-info* + (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (debug:print-info 0 *default-log-port* "rmt:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum) - (handle-exceptions - exn - (begin - (print-error-message exn) - (if (< portnum 64000) - (begin - (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (portlogger:open-run-close portlogger:set-failed portnum) - (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") - ;; (thread-sleep! 0.1) - (rmt:try-start-server ipaddrstr - (portlogger:open-run-close portlogger:find-port))) - (begin - (print "ERROR: Tried and tried but could not start the server")))) - ;; any error in following steps will result in a retry - (if *server-info* - (servdat-status-set! *server-info* 'starting) - (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) - - (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) - (tcp-listen portnum))) + (if (is-port-in-use portnum) + (begin + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") + ;; (thread-sleep! 0.1) + (rmt:try-start-server ipaddrstr + (portlogger:open-run-close + portlogger:find-port))) + (begin + (if (not *server-info*) + (set! *server-info* (make-servdat + host: ipaddrstr + port: portnum))) + (servdat-status-set! *server-info* 'starting) + (servdat-port-set! *server-info* portnum) + (if (not (servdat-rep *server-info*)) + (let ((rep (make-rep-socket))) + (servdat-rep-set! *server-info* rep) + (socket-set! rep 'nng/recvtimeo 2000))) + (let* ((rep (servdat-rep *server-info*))) + (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) + (handle-exceptions + exn + (begin + (print-error-message exn) + (if (< portnum 64000) + (begin + (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") + ;; (thread-sleep! 0.1) + (rmt:try-start-server ipaddrstr + (portlogger:open-run-close portlogger:find-port))) + (begin + (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum)))) + (nng-listen rep (conc "tcp://*:" portnum)) + rep))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -1796,31 +1864,33 @@ (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) (define (server-ready? host port key) ;; server-address is host:port - (let-values (((i o)(handle-exceptions - exn - (values #f #f) - (tcp-connect host port)))) - (if (and i o) - (begin - (write `((cmd . ping) - (key . ,key) - (params . ())) o) - (let ((res (with-input-from-port i - read))) - (close-output-port o) - (close-input-port i) - res)) +;; (let-values (((i o)(handle-exceptions +;; exn +;; (values #f #f) +;; (tcp-connect host port)))) +;; (if (and i o) + (let* ((data (sexpr->string `((cmd . ping) + (key . ,key) + (params . ())))) + (res (open-send-receive-nn (conc host ":" port) data))) + (string->sexpr res))) + +;; (let ((res (with-input-from-port i +;; read))) +;; (close-output-port o) +;; (close-input-port i) +;; res)) ;; (if (string? res) ;; (string->sexpr res) ;; res))) - (begin ;; connection failed - (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.") - #f)))) - +;; (begin ;; connection failed +;; (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.") +;; #f)))) + ;; (define (loop-test host port data) ;; server-address is host:port ;; ;; ping the server and ask it ;; ;; if it ready ;; ;; (let* ((sdat (servdat-init #f host port #f))) ;; ;; (http-transport:send-receive sdat "abc" 'ping '()))) @@ -1970,18 +2040,38 @@ (equal? sdat last-sdat) sdat)))))))) (define (rmt:register-server remote apath iface port server-key dbname) (rmt:open-main-connection remote apath) ;; we need a channel to main.db - (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath - (db:run-id->dbname #f) 'register-server `(,iface - ,port - ,server-key - ,(current-process-id) - ,iface - ,apath - ,dbname))) + (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath + (db:run-id->dbname #f) + 'register-server `(,iface + ,port + ,server-key + ,(current-process-id) + ,iface + ,apath + ,dbname))) + +(define (rmt:get-count-servers remote apath) + (rmt:open-main-connection remote apath) ;; we need a channel to main.db + (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath + (db:run-id->dbname #f) + 'get-count-servers `(,apath + ))) + +(define (rmt:deregister-server remote apath iface port server-key dbname) + (rmt:open-main-connection remote apath) ;; we need a channel to main.db + (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath + (db:run-id->dbname #f) + 'deregister-server `(,iface + ,port + ,server-key + ,(current-process-id) + ,iface + ,apath + ,dbname))) (define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100)) ;; wait until *server-info* stops changing (let* ((stime (current-seconds))) (let loop ((last-host #f) @@ -2040,15 +2130,16 @@ (http-transport:wait-for-server pkts-dir dbname server-key) (http-transport:wait-for-stable-interface)) ;; this is our forever loop (let* ((iface (servdat-host *server-info*)) (port (servdat-port *server-info*))) - (let loop ((count 0) + (let loop ((count 0) (bad-sync-count 0) (start-time (current-milliseconds))) - (if (not is-main) + (if (and (not is-main) + (common:low-noise-print 60 "servdat-status")) (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*))) ;; set up the database handle (mutex-lock! *heartbeat-mutex*) (if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate @@ -2068,20 +2159,28 @@ (exit))))) (debug:print 0 *default-log-port* "SERVER: running, db "dbname" opened, megatest version: " (common:get-full-version)) ;; start the watchdog - (if watchdog + + ;; is this really needed? + + #;(if watchdog (if (not (member (thread-state watchdog) '(ready running blocked sleeping dead))) (begin (debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")") (thread-start! watchdog)) (debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")")) (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it.")) - #;(loop (+ count 1) bad-sync-count start-time))) + #;(loop (+ count 1) bad-sync-count start-time) + )) + + (debug:print-info 0 *default-log-port* "syncing "*toppath*" "dbname" at "(current-seconds)) + (db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t) + (mutex-unlock! *heartbeat-mutex*) ;; when things go wrong we don't want to be doing the various ;; queries too often so we strive to run this stuff only every ;; four seconds or so. @@ -2103,64 +2202,37 @@ (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((and *server-run* (> (+ last-access server-timeout) - (current-seconds))) + (current-seconds)) + (if is-main + (> (rmt:get-count-servers *rmt:remote* *toppath*) 1) + #t)) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) (loop 0 bad-sync-count (current-milliseconds))) (else + (set! *unclean-shutdown* #f) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) - (http-transport:server-shutdown port)))))))) - -(define (http-transport:server-shutdown port) - (begin - ;;(BB> "http-transport:server-shutdown called") - (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) - ;; - ;; start_shutdown - ;; - - ;; deregister the server - - - (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up - (portlogger:open-run-close portlogger:set-port port "released") - (thread-sleep! 1) - - ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) - ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*) - ;; (debug:print-info 0 *default-log-port* "Average cached write time " - ;; (if (eq? *number-of-writes* 0) - ;; "n/a (no writes)" - ;; (/ *writes-total-delay* - ;; *number-of-writes*)) - ;; " ms") - ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*) - ;; (debug:print-info 0 *default-log-port* "Average non-cached time " - ;; (if (eq? *number-non-write-queries* 0) - ;; "n/a (no queries)" - ;; (/ *total-non-write-delay* - ;; *number-non-write-queries*)) - ;; " ms") - - (db:print-current-query-stats) - (common:save-pkt `((action . exit) - (T . server) - (pid . ,(current-process-id))) - *configdat* #t) - (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") - (exit))) + (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) + (rmt:server-shutdown) + (portlogger:open-run-close portlogger:set-port port "released") + (exit) + #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: " + (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown + (sexpr->string 'quit))) + ))))))) ;; Call this to start the actual server ;; ;; all routes though here end in exit ... ;; ;; This is the point at which servers are started ;; (define (rmt:server-launch dbname) + (debug:print-info 0 *default-log-port* "Entered rmt:server-launch") (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (rmt:run (if (args:get-arg "-server") (args:get-arg "-server") "-") @@ -2172,12 +2244,13 @@ (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) - (exit)) - + (thread-join! th3) + ;; (exit)) + ) #f ) ;; Generate a unique signature for this process, used at both client and ;; server side @@ -2192,10 +2265,112 @@ (define (rmt:get-signature) (if *my-signature* *my-signature* (let ((sig (rmt:mk-signature))) (set! *my-signature* sig) *my-signature*))) + +;;====================================================================== +;; Nanomsg transport +;;====================================================================== + +(define (is-port-in-use port-num) + (let* ((ret #f)) + (let-values (((inp oup pid) + (process "netstat" (list "-tulpn" )))) + (let loop ((inl (read-line inp))) + (if (not (eof-object? inl)) + (begin + (if (string-search (regexp (conc ":" port-num)) inl) + (begin + ;(print "Output: " inl) + (set! ret #t)) + (loop (read-line inp))))))) + ret)) + +;;start a server, returns the connection +;; +(define (start-nn-server portnum ) + (let ((rep (make-rep-socket))) ;; (nn-socket 'rep))) + (socket-set! rep 'nng/recvtimeo 2000) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + (print "ERROR: Failed to start server \"" emsg "\"") + (exit 1)) + + (nng-dial #;nn-bind rep (conc "tcp://*:" portnum))) + rep)) + +;; open connection to server, send message, close connection +;; +(define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds + (let ((req (make-req-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f) + ;; (contacts (alist-ref 'contact attrib)) + ;; (mode (alist-ref 'mode attrib)) + ) + (socket-set! req 'nng/recvtimeo 2000) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) + #f) + (nng-dial req uri) + ;; (print "Connected to the server " ) + (nng-send req msg) + ;; (print "Request Sent") + (let* ((th1 (make-thread (lambda () + (let ((resp (nng-recv req))) + (nng-close! req) + (set! res (if (equal? resp "ok") + #t + #f)))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) + +(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds + (let ((req (make-req-socket)) + (uri (conc "tcp://" host-port)) + (res #f) + ;; (contacts (alist-ref 'contact attrib)) + ;; (mode (alist-ref 'mode attrib)) + ) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn) + #f) + (nng-dial req uri) + ;; (print "Connected to the server " ) + (nng-send req msg) + ;; (print "Request Sent") + ;; receive code here + ;;(print (nn-recv req)) + (let* ((th1 (make-thread (lambda () + (let ((resp (nng-recv req))) + (nng-close! req) + (print resp) + (set! res resp))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -298,11 +298,11 @@ #f ;; get full data (not 'shortlist) 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time 'dashboard) '())) (log-dir (conc *toppath* "/logs")) - (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (log-file (conc "pre-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log")) (full-log-fname (conc log-dir "/" log-file))) (if run-pre-hook (if (null? existing-tests) (let* ((use-log-dir (if (not (directory-exists? log-dir)) (handle-exceptions @@ -345,11 +345,11 @@ (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) - (dbfile (conc *toppath* "/megatest.db")) + (dbfile (conc *toppath* "/.db/main.db")) (readonly-mode (not (file-writable? dbfile))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) @@ -498,19 +498,19 @@ ;; run the run prehook if there are no tests yet run for this run: ;; (runs:run-pre-hook run-id) ;; mark all test launched flag as false in the meta table - (rmt:set-var (conc "lunch-complete-" run-id) "no") + (rmt:set-var run-id (conc "lunch-complete-" run-id) "no") (debug:print-info 1 *default-log-port* "Setting end-of-run to no") (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (config-rerun-cnt (if config-reruns config-reruns 1))) (if (eq? config-rerun-cnt run-count) - (rmt:set-var (conc "end-of-run-" run-id) "no"))) + (rmt:set-var run-id (conc "end-of-run-" run-id) "no"))) (rmt:set-run-state-status run-id "new" "n/a") ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data @@ -522,11 +522,11 @@ (if (not (null? test-names)) ;; BEGIN test-names loop (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. - (setenv "MT_TEST_NAME" hed) ;; + (set-environment-variable! "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry)) ;; NOTE: Have the config - can extract [waitons] section ((hed-mode) @@ -813,12 +813,12 @@ (and (member 'toplevel testmode) (null? non-completed))) (debug:print-info 4 *default-log-port* "cond branch - " "ei-2") (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) + (set-environment-variable! "MT_TEST_NAME" test-name) ;; + (set-environment-variable! "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) @@ -1705,11 +1705,11 @@ (else (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9") (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; end loop on sorted test names ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched - (rmt:set-var (conc "lunch-complete-" run-id) "yes") + (rmt:set-var run-id (conc "lunch-complete-" run-id) "yes") ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle @@ -1827,13 +1827,13 @@ "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) - ;; (setenv "MT_TEST_NAME" test-name) ;; - ;; (setenv "MT_ITEMPATH" item-path) - ;; (setenv "MT_RUNNAME" runname) + ;; (set-environment-variable! "MT_TEST_NAME" test-name) ;; + ;; (set-environment-variable! "MT_ITEMPATH" item-path) + ;; (set-environment-variable! "MT_RUNNAME" runname) (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; @@ -2740,17 +2740,17 @@ (process-signal pid signal/int) (thread-sleep! 5) (if (process:alive? pid) (process-signal pid signal/kill))))) ;; (call-with-environment-variables - (let ((old-targethost (getenv "TARGETHOST"))) - (setenv "TARGETHOST" hostname) - (setenv "TARGETHOST_LOGF" "server-kills.log") + (let ((old-targethost (get-environment-variable "TARGETHOST"))) + (set-environment-variable! "TARGETHOST" hostname) + (set-environment-variable! "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) - (if old-targethost (setenv "TARGETHOST" old-targethost)) - (unsetenv "TARGETHOST") - (unsetenv "TARGETHOST_LOGF")))) + (if old-targethost (set-environment-variable! "TARGETHOST" old-targethost)) + (unset-environment-variable! "TARGETHOST") + (unset-environment-variable! "TARGETHOST_LOGF")))) (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) records))) (define (task:get-run-times) (let* ( DELETED server.scm Index: server.scm ================================================================== --- server.scm +++ /dev/null @@ -1,51 +0,0 @@ -;; Copyright 2006-2017, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . -;; - -;; (require-extension (srfi 18) extras tcp s11n) -;; -;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest -;; directory-utils posix-extras matchable) -;; -;; (use spiffy uri-common intarweb http-client spiffy-request-vars) -;; -;; (declare (unit server)) -;; -;; (declare (uses common)) -;; (declare (uses db)) -;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; ;; (declare (uses synchash)) -;; (declare (uses http-transport)) -;; ;;(declare (uses rpc-transport)) -;; (declare (uses launch)) -;; ;; (declare (uses daemon)) -;; -;; (include "common_records.scm") -;; (include "db_records.scm") - -;;====================================================================== -;; P K T S S T U F F -;;====================================================================== - -;; ??? - -;;====================================================================== -;; P K T S S T U F F -;;====================================================================== - -;; ??? - Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -63,11 +63,11 @@ ;; (rmt:conn-port *main*) tdat))) ;; (list 'a ;; '(a "b" 123 1.23 ))) (test #f #t (rmt:send-receive 'ping #f 'hello)) -(define *db* (db:setup #f)) +(define *db* (db:setup ".db/main.db")) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") (define remote *rmt:remote*) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -32,490 +32,51 @@ ;; rmt:send-receive-real ;; rmt:send-receive ;; sexpr->string ;; server-ready? ;; rmt:register-server + ;; rmt:deregister-server ;; rmt:open-main-connection ;; rmt:general-open-connection - ;; rmt:get-conny + ;; rmt:get-conn ;; common:watchdog ;; rmt:find-main-server ;; get-all-server-pkts ;; get-viable-servers ;; get-best-candidate ;; api:run-server-process + ;; api:process-request ;; rmt:run ;; rmt:try-start-server ) -(define *db* (db:setup #f)) +(define *db* (db:setup ".db/main.db")) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") (define remote *rmt:remote*) (define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) (test #f #t (rmt:open-main-connection remote apath)) +(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))) (test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))) (test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname))) (thread-sleep! 2) (test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db"))) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) (test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f))) (print "Got here.") -(test #t 1 (rmt:send-receive 'register-run 1 (list keyvals "run2" "new" "n/a" "justme" #f))) - -(test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) - -;; (delete-file* "logs/1.log") -;; (define run-id 1) - -;; (test "setup for run" #t (begin (launch:setup) -;; (string? (getenv "MT_RUN_AREA_HOME")))) -;; -;; (test #f #t (and (server:kind-run *toppath*) #t)) -;; -;; -;; (define user (current-user-name)) -;; (define runname "mytestrun") -;; (define keys (rmt:get-keys)) -;; (define runinfo #f) -;; (define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) -;; (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) -;; -;; ;; Setup -;; ;; -;; ;; (test #f #f (not (client:setup run-id))) -;; ;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) -;; -;; ;; Login -;; ;; -;; (test #f'(#t "successful login") -;; (rmt:login run-id)) -;; -;; ;; Keys -;; ;; -;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) -;; -;; ;; No data in db -;; ;; -;; (test #f '() (rmt:get-all-run-ids)) -;; (test #f #f (rmt:get-run-name-from-id run-id)) -;; (test #f -;; (vector -;; header -;; (vector #f #f #f #f)) -;; (rmt:get-run-info run-id)) -;; -;; ;; Insert data into db -;; ;; -;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) -;; ;; (test #f #f (rmt:get-runs-by-patt keys runname)) -;; (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) -;; (define test-one-id #f) -;; (test #f 1 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) -;; (set! test-one-id test-id) -;; test-id)) -;; (define test-one-rec #f) -;; (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) -;; (set! test-one-rec test-rec) -;; (vector-ref test-rec 2))) -;; -;; ;; With data in db -;; ;; -;; (print "Using runame=" runname) -;; (test #f '(1) (rmt:get-all-run-ids)) -;; (test #f runname (rmt:get-run-name-from-id run-id)) -;; (test #f -;; runname -;; (let ((run-info (rmt:get-run-info run-id))) -;; (db:get-value-by-header (db:get-rows run-info) -;; (db:get-header run-info) -;; "runname"))) -;; -;; ;; test killing server -;; ;; -;; (for-each -;; (lambda (run-id) -;; (test #f #t (and (tasks:kill-server-run-id run-id) #t)) -;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) -;; (list 0 1)) -;; -;; ;; Tests to assess reading/writing while servers are starting/stopping -;; ;; NO LONGER APPLICABLE -;; -;; ;; Server tests go here -;; (define (server-tests-dont-run-right-now) -;; (for-each -;; (lambda (run-id) -;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) -;; (server:kind-run run-id) -;; (test "did server start within 20 seconds?" -;; #t -;; (let loop ((remtries 20) -;; (running (tasks:server-running-or-starting? (db:delay-if-busy -;; (tasks:open-db)) -;; run-id))) -;; (if running -;; (> running 0) -;; (if (> remtries 0) -;; (begin -;; (thread-sleep! 1) -;; (loop (- remtries 1) -;; (tasks:server-running-or-starting? (db:delay-if-busy -;; (tasks:open-db)) -;; run-id))))))) -;; -;; (test "did server become available" #t -;; (let loop ((remtries 10) -;; (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) -;; (if res -;; (vector? res) -;; (begin -;; (if (> remtries 0) -;; (begin -;; (thread-sleep! 1.1) -;; (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) -;; res))))) -;; ) -;; (list 0 1))) -;; -;; (define start-time (current-seconds)) -;; (define (reading-writing-while-server-starting-stopping-dont-run-now) -;; (let loop ((test-state 'start)) -;; (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id)) -;; (first-dat (if (not (null? server-dats)) -;; (car server-dats) -;; #f))) -;; (map (lambda (dat) -;; (apply print (intersperse (vector->list dat) ", "))) -;; server-dats) -;; (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id)) -;; (thread-sleep! 1) -;; (case test-state -;; ((start) -;; (print "Trying to start server") -;; (server:kind-run run-id) -;; (loop 'server-started)) -;; ((server-started) -;; (case (if first-dat (vector-ref first-dat 0) 'blah) -;; ((running) -;; (print "Server appears to be running. Now ask it to shutdown") -;; (rmt:kill-server run-id) -;; (loop 'server-shutdown)) -;; ((shutting-down) -;; (loop test-state)) -;; (else (print "Don't know what to do if get here")))) -;; ((server-shutdown) -;; (loop test-state))))) -;; ) - -;;====================================================================== -;; END OF TESTS -;;====================================================================== - - -;; (test #f #f (client:setup run-id)) - -;; (set! *transport-type* 'http) -;; -;; (test "setup for run" #t (begin (launch:setup-for-run) -;; (string? (getenv "MT_RUN_AREA_HOME")))) -;; -;; (test "server-register, get-best-server" #t (let ((res #f)) -;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) -;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) -;; (number? (vector-ref res 3)))) -;; -;; (test "de-register server" #f (let ((res #f)) -;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) -;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) -;; -;; (define server-pid #f) -;; -;; ;; Not sure how the following should work, replacing it with system of megatest -server -;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () -;; ;; ;; (daemon:ize) -;; ;; (server:launch 'http))))) -;; ;; (set! server-pid pid) -;; ;; (number? pid))) -;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &") -;; -;; (let loop ((n 10)) -;; (thread-sleep! 1) ;; need to wait for server to start. -;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) -;; (print "tasks:get-best-server returned " res) -;; (if (and (not res) -;; (> n 0)) -;; (loop (- n 1))))) -;; -;; (test "get-best-server" #t (begin -;; (client:launch) -;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) -;; (vector? dat)))) -;; -;; (define *keys* (keys:config-get-fields *configdat*)) -;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) -;; -;; (test #f #t (string? (car *runremote*))) -;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -;; -;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test -;; -;; ;; RUNS -;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) -;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) -;; (vector-ref (vector-ref rinfo 1) 3))) -;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) -;; -;; ;; TESTS -;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) -;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) -;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) -;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) -;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) -;; (test "get keys" #t (list? (rmt:get-keys))) -;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) -;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) -;; (db:test-get-comment trec))) -;; -;; ;; MORE RUNS -;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) -;; (header (vector-ref runs 0)) -;; (data (vector-ref runs 1))) -;; (and (list? header) -;; (list? data) -;; (vector? (car data))))) -;; -;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) -;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) -;; -;; ;;====================================================================== -;; ;; D B -;; ;;====================================================================== -;; -;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) -;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) -;; (+ (db:test-get-pass_count dat) -;; (db:test-get-fail_count dat)))) -;; -;; (define testregistry (make-hash-table)) -;; (for-each -;; (lambda (tname) -;; (for-each -;; (lambda (itempath) -;; (let ((tkey (conc tname "/" itempath)) -;; (rpass (random 10)) -;; (rfail (random 10))) -;; (hash-table-set! testregistry tkey (list tname itempath)) -;; (rmt:general-call 'register-test 1 tname itempath) -;; (let* ((tid (rmt:get-test-id 1 tname itempath)) -;; (tdat (rmt:get-test-info-by-id tid))) -;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) -;; (let* ((resdat (rmt:get-test-info-by-id tid))) -;; (test "set/get pass fail counts" (list rpass rfail) -;; (list (db:test-get-pass_count resdat) -;; (db:test-get-fail_count resdat))))))) -;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) -;; (list "test1" "test2" "test3" "test4" "test5")) -;; -;; -;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) -;; + +(test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f))) + +(test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) +;; (test #f 2 (rmt:deregister-server *rmt:remote* *toppath* iface port server-key dbname + +(test #f 2 (rmt:get-count-servers *rmt:remote* *toppath*)) + +(test #f "run2" (rmt:get-run-name-from-id 2)) ;; (exit) - -;; all old stuff below - - - - -(delete-file* "logs/1.log") -(define run-id 1) - -(test "setup for run" #t (begin (launch:setup-for-run) - (string? (getenv "MT_RUN_AREA_HOME")))) - -;; Insert data into db -;; -(define user (current-user-name)) -(define runname "mytestrun") -(define keys (rmt:get-keys)) -(define runinfo #f) -(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) -(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) - -(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) -;; (test #f #f (rmt:get-runs-by-patt keys runname)) -(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) -(define test-one-id #f) -(test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) - (set! test-one-id test-id) - test-id)) -(define test-one-rec #f) -(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) - (set! test-one-rec test-rec) - (vector-ref test-rec 2))) - -(use trace) -(import trace) -;; (trace -;; rmt:send-receive -;; rmt:open-qry-close-locally -;; ) - -;; Tests to assess reading/writing while servers are starting/stopping -(define start-time (current-seconds)) -(let loop ((test-state 'start)) - (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id)) - (first-dat (if (not (null? server-dats)) - (car server-dats) - #f)) - (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat))) - (if first-dat - (map (lambda (dat) - (apply print (intersperse (vector->list dat) ", "))) - server-dats) - (print "No server")) - (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id)) - (thread-sleep! 1) - (case test-state - ((start) - (print "Trying to start server") - (server:kind-run run-id) - (loop 'server-started)) - ((server-started) - (case server-state - ((running) - (print "Server appears to be running. Now ask it to shutdown") - (rmt:kill-server run-id) - ;; (trace rmt:open-qry-close-locally rmt:send-receive) - (loop 'shutdown-started)) - ((available) - (loop test-state)) - ((shutting-down) - (loop test-state)) - ((no-dat) - (loop test-state)) - (else (print "Don't know what to do if get here")))) - ((shutdown-started) - (case server-state - ((no-dat) - (print "Server appears to have shutdown, ending this test")) - (else - (loop test-state))))))) - -(exit) - -;; (set! *transport-type* 'http) -;; -;; (test "setup for run" #t (begin (setup-for-run) -;; (string? (getenv "MT_RUN_AREA_HOME")))) -;; -;; (test "server-register, get-best-server" #t (let ((res #f)) -;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) -;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) -;; (number? (vector-ref res 3)))) -;; -;; (test "de-register server" #f (let ((res #f)) -;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) -;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) -;; -;; (define server-pid #f) -;; -;; ;; Not sure how the following should work, replacing it with system of megatest -server -;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () -;; ;; ;; (daemon:ize) -;; ;; (server:launch 'http))))) -;; ;; (set! server-pid pid) -;; ;; (number? pid))) -;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") -;; -;; (let loop ((n 10)) -;; (thread-sleep! 1) ;; need to wait for server to start. -;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) -;; (print "tasks:get-best-server returned " res) -;; (if (and (not res) -;; (> n 0)) -;; (loop (- n 1))))) -;; -;; (test "get-best-server" #t (begin -;; (client:launch) -;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) -;; (vector? dat)))) -;; -;; (define *keys* (keys:config-get-fields *configdat*)) -;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) -;; -;; (test #f #t (string? (car *runremote*))) -;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -;; -;; (test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test -;; -;; ;; RUNS -;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) -;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) -;; (vector-ref (vector-ref rinfo 1) 3))) -;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) -;; -;; ;; TESTS -;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -;; (test "register test" #t (rmt:general-call 'register-test 1 1 "test1" "")) -;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) -;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) -;; -;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) -;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) -;; -;; (test "get keys" #t (list? (rmt:get-keys))) -;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t)) -;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1))) -;; (db:test-get-comment trec))) -;; -;; ;; MORE RUNS -;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) -;; (header (vector-ref runs 0)) -;; (data (vector-ref runs 1))) -;; (and (list? header) -;; (list? data) -;; (vector? (car data))))) -;; -;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2)) -;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) -;; -;; ;;====================================================================== -;; ;; D B -;; ;;====================================================================== -;; -;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) -;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) -;; (+ (db:test-get-pass_count dat) -;; (db:test-get-fail_count dat)))) -;; -;; (define testregistry (make-hash-table)) -;; (for-each -;; (lambda (tname) -;; (for-each -;; (lambda (itempath) -;; (let ((tkey (conc tname "/" itempath)) -;; (rpass (random 10)) -;; (rfail (random 10))) -;; (hash-table-set! testregistry tkey (list tname itempath)) -;; (rmt:general-call 'register-test 1 tname itempath) -;; (let* ((tid (rmt:get-test-id 1 tname itempath)) -;; (tdat (rmt:get-test-info-by-id tid))) -;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) -;; (let* ((resdat (rmt:get-test-info-by-id tid))) -;; (test "set/get pass fail counts" (list rpass rfail) -;; (list (db:test-get-pass_count resdat) -;; (db:test-get-fail_count resdat))))))) -;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) -;; (list "test1" "test2" "test3" "test4" "test5")) -;; -;; -;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) -;; Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -113,10 +113,43 @@ (include "js-path.scm") (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) + +;; pulled from commonmod +;; + +;; return items given config +;; +(define (tests:get-items tconfig) + (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 + (itemstable (hash-table-ref/default tconfig "itemstable" #f))) + ;; if either items or items table is a proc return it so test running + ;; process can know to call items:get-items-from-config + ;; if either is a list and none is a proc go ahead and call get-items + ;; otherwise return #f - this is not an iterated test + (cond + ((procedure? items) + (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") + items) ;; calc later + ((procedure? itemstable) + (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") + itemstable) ;; calc later + ((filter (lambda (x) + (let ((val (car x))) + (if (procedure? val) val #f))) + (append (if (list? items) items '()) + (if (list? itemstable) itemstable '()))) + 'have-procedure) + ((or (list? items)(list? itemstable)) ;; calc now + (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" + " items: " items " itemstable: " itemstable) + (items:get-items-from-config tconfig)) + (else #f)))) ;; not iterated + + ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; @@ -411,11 +444,11 @@ ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. (rmt:csv->test-data run-id test-id dat) ;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start" ;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue. - (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) + ;; (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) ;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server. ))) ;; need to update the top test record if PASS or FAIL and this is a subtest ;;;;;; (if (not (equal? item-path "")) @@ -996,22 +1029,22 @@ ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) - (if (and (getenv "MT_LINKTREE") - (getenv "MT_TARGET") - (getenv "MT_RUNNAME") - (getenv "MT_TEST_NAME") - (getenv "MT_ITEMPATH")) - (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") - (if (and (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")) + (if (and (get-environment-variable "MT_LINKTREE") + (get-environment-variable "MT_TARGET") + (get-environment-variable "MT_RUNNAME") + (get-environment-variable "MT_TEST_NAME") + (get-environment-variable "MT_ITEMPATH")) + (conc (get-environment-variable "MT_LINKTREE") "/" + (get-environment-variable "MT_TARGET") "/" + (get-environment-variable "MT_RUNNAME") "/" + (get-environment-variable "MT_TEST_NAME") + (if (and (get-environment-variable "MT_ITEMPATH") + (not (string=? "" (get-environment-variable "MT_ITEMPATH")))) + (conc "/" (get-environment-variable "MT_ITEMPATH")) "")) #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" @@ -1046,13 +1079,13 @@ dat ;; no cached data available (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) - (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" + (let* ((local-tcdir (conc (get-environment-variable "MT_LINKTREE") "/" + (get-environment-variable "MT_TARGET") "/" + (get-environment-variable "MT_RUNNAME") "/" test-name "/" item-path)) (local-tcfg (conc local-tcdir "/testconfig"))) (if (common:file-exists? local-tcfg) local-tcdir #f)) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -16,29 +16,33 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use format) -(require-library iup) +(import format) +;; (import iup) (import (prefix iup iup:)) -(use canvas-draw) +(import canvas-draw) -(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import sqlite3 srfi-1 + chicken.file.posix + regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit tree)) -(declare (uses margs)) +(declare (uses mtargs)) +(declare (uses mtver)) (declare (uses launch)) ;; (declare (uses megatest-version)) (declare (uses gutils)) -(declare (uses db)) -(declare (uses server)) +(declare (uses dbmod)) +(declare (uses servermod)) ;; (declare (uses synchash)) (declare (uses dcommon)) -(include "megatest-version.scm") +(import mtver) +;; (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") ;;======================================================================