Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -35,11 +35,11 @@ # MSRCFILES = # ftail.scm rmtmod.scm commonmod.scm removed MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \ cookie.scm mutils.scm mtargs.scm apimod.scm commonmod.scm \ dbmod.scm rmtmod.scm debugprint.scm mtver.scm csv-xml.scm \ - servermod.scm hostinfo.scm adjutant.scm + servermod.scm hostinfo.scm adjutant.scm # commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -130,11 +130,11 @@ (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing -(define *default-log-port* (current-error-port)) +;; (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog (define *default-area-tag* "local") ;; DATABASE (define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -57,10 +57,14 @@ ;; ;;====================================================================== (include "megatest-fossil-hash.scm") +;; Globals +;; +(define *server-loop-heart-beat* (current-seconds)) + ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) Index: ducttape/ducttape-lib.scm ================================================================== --- ducttape/ducttape-lib.scm +++ ducttape/ducttape-lib.scm @@ -49,21 +49,41 @@ *this-exe-dir* *this-exe-name* *this-exe-fullpath* ) - (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix) - (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339) + (import scheme + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.format + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.irregex + chicken.string + chicken.time + chicken.time.posix + ) + + (import regex ansi-escape-sequences test srfi-1 slice srfi-13 rfc3339) ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise (import directory-utils filepath srfi-19 ) ; linenoise ;; plugs a hole in posix-extras in latter chicken versions - (import pathname-expand chicken.file chicken.string) - (define ##sys#expand-home-path pathname-expand) - (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) )) + ;; (import pathname-expand chicken.file chicken.string) + ;; (define ##sys#expand-home-path pathname-expand) + ;; (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) )) ;;(define (realpath x) (pathname-expand (or x "/dev/null"))) + (define (realpath x) + (with-input-from-pipe (conc "readlink -f " x) read-line)) ;; (include "mimetypes.scm") ; provides ext->mimetype ;; (include "workweekdate.scm") ;; gathered from macosx: Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -46,12 +46,10 @@ (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) -(define *server-loop-heart-beat* (current-seconds)) - ;;====================================================================== ;; S E R V E R ;; ====================================================================== ;; Call this to start the actual server Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -96,10 +96,12 @@ typed-records s11n sparse-vectors sxml-serializer sxml-modifications + (prefix sxml-modifications sxml-) + sxml-transforms system-information z3 spiffy uri-common intarweb @@ -176,11 +178,11 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (include "common.scm") -(include "megatest-fossil-hash.scm") +;; (include "megatest-fossil-hash.scm") (include "configf.scm") (include "margs.scm") (include "process.scm") (include "keys.scm") @@ -216,38 +218,38 @@ ;;; ;; ;;; ;; (use sparse-vectors) ;;; ;; ;;; ;; (require-library mutils) ;;; -;;; ;; copied from egg call-with-environment-variables -;;; ;; -;;; (define (call-with-environment-variables variables thunk) -;;; ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk." -;;; ;; (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") -;;; ;; (thunk "The thunk to execute with a modified environment")) -;;; (let ((pre-existing-variables -;;; (map (lambda (var-value) -;;; (let ((var (car var-value))) -;;; (cons var (get-environment-variable var)))) -;;; variables))) -;;; (dynamic-wind -;;; (lambda () (void)) -;;; (lambda () -;;; ;; (use posix) -;;; (for-each (lambda (var-value) -;;; (setenv (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)))) -;;; pre-existing-variables))))) -;;; +;; copied from egg call-with-environment-variables +;; +(define (call-with-environment-variables variables thunk) + ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk." + ;; (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") + ;; (thunk "The thunk to execute with a modified environment")) + (let ((pre-existing-variables + (map (lambda (var-value) + (let ((var (car var-value))) + (cons var (get-environment-variable var)))) + variables))) + (dynamic-wind + (lambda () (void)) + (lambda () +;; (use posix) + (for-each (lambda (var-value) + (setenv (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)))) + pre-existing-variables))))) + ;;; ;;; ;;; (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 ;;; @@ -679,21 +681,22 @@ ;;; (if targ (setenv "MT_TARGET" targ))) ;;; ;;; ;; The watchdog is to keep an eye on things like db sync etc. ;;; ;; ;;; -;;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -;;; (define *watchdog* (make-thread -;;; (lambda () -;;; (handle-exceptions -;;; exn -;;; (begin -;;; (print-call-chain) -;;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) -;;; (common:watchdog))) -;;; "Watchdog thread")) -;;; + +;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage +(define *watchdog* (make-thread + (lambda () + (handle-exceptions + exn + (begin + (print-call-chain) + (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + (common:watchdog))) + "Watchdog thread")) + ;;; ;;(if (not (args:get-arg "-server")) ;;; ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog ;;; (let* ((no-watchdog-args ;;; '("-list-runs" ;;; "-testdata-csv" @@ -1170,52 +1173,52 @@ ;;; (json-write targets)) ;;; (else ;;; (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) ;;; (set! *didsomething* #t)))) ;;; -;;; ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig -;;; ;; -;;; (define (full-runconfigs-read) -;;; ;; in the envprocessing branch the below code replaces the further below code -;;; ;; (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")) -;;; #f)) -;;; (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) -;;; (if (and cfgf -;;; (common:file-exists? cfgf) -;;; (file-writable? cfgf) -;;; (common:use-cache?)) -;;; (configf:read-alist cfgf) -;;; (let* ((keys (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*) -;;; (if key-vals -;;; (for-each (lambda (kt) -;;; (setenv (car kt) (cadr kt))) -;;; key-vals)) -;;; ;; (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) -;;; (file-writable? rundir)) -;;; (begin -;;; (if (not (common:in-running-test?)) -;;; (configf:write-alist data cfgf)) -;;; ;; force re-read of megatest.config - this resolves circular references between megatest.config -;;; (launch:setup force-reread: #t) -;;; ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. -;;; )) ;; we can safely cache megatest.config since we have a valid runconfig -;;; data)))) + +;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig +;; +(define (full-runconfigs-read) +;; in the envprocessing branch the below code replaces the further below code +;; (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")) + #f)) + (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) + (if (and cfgf + (common:file-exists? cfgf) + (file-writable? cfgf) + (common:use-cache?)) + (configf:read-alist cfgf) + (let* ((keys (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*) + (if key-vals + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals)) + ;; (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) + (file-writable? rundir)) + (begin + (if (not (common:in-running-test?)) + (configf:write-alist data cfgf)) + ;; force re-read of megatest.config - this resolves circular references between megatest.config + (launch:setup force-reread: #t) + ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. + )) ;; we can safely cache megatest.config since we have a valid runconfig + data)))) ;;; ;;; (if (args:get-arg "-show-runconfig") ;;; (let ((tl (launch:setup))) ;;; (push-directory *toppath*) ;;; (let ((data (full-runconfigs-read))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -612,11 +612,11 @@ (calculate-off-time (lambda (work-duration duty-cycle) (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds))) (off-time min-intersync-delay) ;; adjusted in closure below. (do-a-sync (lambda () - (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) + ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) (let* ((finalres (let retry-loop ((num-tries 0)) (if (common:simple-file-lock lockfile) (begin (cond @@ -664,13 +664,13 @@ (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail") (if (file-exists? (conc mtdbfile ".backup")) (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile))) #f)))) (common:simple-file-release-lock lockfile) - (BB> "released lockfile: " lockfile) - (when (common:file-exists? lockfile) - (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) + ;; (BB> "released lockfile: " lockfile) + ;; (when (common:file-exists? lockfile) + ;; (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) res2) ;; end let );; end begin ;; else (cond (persist-until-sync @@ -682,11 +682,11 @@ (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.") 'parallel-sync-in-progress)) ) ;; end if got lockfile ) )) - (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) + ;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) finalres) ) ;; end lambda )) do-a-sync)) Index: servermod.scm ================================================================== --- servermod.scm +++ servermod.scm @@ -40,12 +40,10 @@ (define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) -(define *server-loop-heart-beat* (current-seconds)) - (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))