Index: adjutant.scm ================================================================== --- adjutant.scm +++ adjutant.scm @@ -16,16 +16,16 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit adjutant)) +;; (declare (unit adjutant)) (module adjutant * -(import scheme chicken data-structures extras files) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 +(import scheme chicken.base) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 md5 message-digest regex srfi-1) (define (adjutant-run) (print "Running the adjutant!")) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -31,32 +31,32 @@ ;; ;;====================================================================== ;; NOT CURRENTLY USED ;; -(define (archive:main linktree target runname testname itempath options) - (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt)) - (flavor 'plain) ;; type of machine to run jobs on - (maxload 1.5) ;; max allowed load for this work - (adisks (archive:get-archive-disks))) - ;; get testdir size - ;; - hand off du to job mgr - (if (and (common:file-exists? testdir) - (file-writable? testdir)) - (let* ((dused (jobrunner:run-job - flavor ;; machine type - maxload ;; max allowed load - '() ;; prevars - environment vars to set for the job - common:get-disk-space-used ;; if a proc call it, if a string it is a unix command - (list testdir))) - (apath (archive:get-archive testname itempath dused))) - (jobrunner:run-job - flavor - maxload - '() - archive:run-bup - (list testdir apath)))))) +;; (define (archive:main linktree target runname testname itempath options) +;; (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath)) +;; (flavor 'plain) ;; type of machine to run jobs on +;; (maxload 1.5) ;; max allowed load for this work +;; (adisks (archive:get-archive-disks))) +;; ;; get testdir size +;; ;; - hand off du to job mgr +;; (if (and (common:file-exists? testdir) +;; (file-writable? testdir)) +;; (let* ((dused (jobrunner:run-job +;; flavor ;; machine type +;; maxload ;; max allowed load +;; '() ;; prevars - environment vars to set for the job +;; common:get-disk-space-used ;; if a proc call it, if a string it is a unix command +;; (list testdir))) +;; (apath (archive:get-archive testname itempath dused))) +;; (jobrunner:run-job +;; flavor +;; maxload +;; '() +;; archive:run-bup +;; (list testdir apath)))))) ;; Get archive disks from megatest.config ;; (define (archive:get-archive-disks) (let ((section (configf:get-section *configdat* "archive-disks"))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -175,10 +175,11 @@ ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) (define *server-overloaded* #f) +(define *writes-total-delay* 0) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -35,10 +35,12 @@ ;; (include "db_records.scm") ;; (include "run_records.scm") ;; ;; ;;(rmt:get-test-info-by-id run-id test-id) -> testdat + +(define message-window #f) ;; TODO: deprecate me in favor of ezsteps.scm ;; (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat) (let* ((stepname (car ezstep)) ;; do stuff to run the step @@ -263,19 +265,21 @@ (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) - (message-window "ERROR: You can only re-run steps defined via ezsteps") + (if message-window + (message-window "ERROR: You can only re-run steps defined via ezsteps") + (debug:print 0 *default-log-port* "ERROR: You can only re-run steps defined via ezsteps")) (begin (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (status-sym-so-far 'pass) ;;(runflag #f) (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning (if (or (vector-ref exit-info 1) - (equal? (alist-ref 'keep-going prev-step-params) 'yes)) + (equal? (alist-ref 'keep-going the-step-params) 'yes)) (let* ((prev-step-params the-step-params) ;; need to snag this now (stepname (car ezstep)) ;; do stuff to run the step (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro"))) (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -227,11 +227,11 @@ (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (loop etime)) (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) - (close-all-connections!))) + (close-idle-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) @@ -299,11 +299,11 @@ (cons 'params sparams)) read-string)) transport: 'http) 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? - (close-all-connections!) + (close-idle-connections!) (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") @@ -522,11 +522,11 @@ (let ((curr-time (current-seconds))) (handle-exceptions exn (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn) (if (not *server-overloaded*) - (change-file-times server-log-file curr-time curr-time))))) + (set-file-times! server-log-file curr-time curr-time))))) (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port))))))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -23,10 +23,11 @@ (include "stml2/stml2.scm") (include "pkts/pkts.scm") (include "csv-xml/csv-xml.scm") (include "ducttape/ducttape-lib.scm") (include "hostinfo/hostinfo.scm") +(include "adjutant.scm") ;; (include "call-with-environment-variables/call-with-environment-variables.scm") (module megatest-main * @@ -59,10 +60,11 @@ (prefix base64 base64:) address-info csv-abnf directory-utils fmt + json matchable md5 message-digest queues regex @@ -74,11 +76,12 @@ sparse-vectors sxml-serializer sxml-modifications system-information z3 - + spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing + srfi-1 srfi-4 srfi-18 srfi-13 srfi-98 @@ -87,10 +90,11 @@ ;; local modules mutils csv-xml ducttape-lib hostinfo + adjutant ) ;; (include "common.scm") (include "megatest-version.scm") @@ -174,13 +178,13 @@ ;; (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")) + ;; @("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))) @@ -693,11 +697,11 @@ 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) + (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) (define *didsomething* #t) (exit 1)))) ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation @@ -2039,19 +2043,19 @@ ;;====================================================================== ;; Rollup into a run ;;====================================================================== -(if (args:get-arg "-rollup") - (general-run-call - "-rollup" - "rollup tests" - (lambda (target runname keys keyvals) - (runs:rollup-run keys - keyvals - (or (args:get-arg "-runname")(args:get-arg ":runname") ) - user)))) +;; (if (args:get-arg "-rollup") +;; (general-run-call +;; "-rollup" +;; "rollup tests" +;; (lambda (target runname keys keyvals) +;; (runs:rollup-run keys +;; keyvals +;; (or (args:get-arg "-runname")(args:get-arg ":runname") ) +;; user)))) ;;====================================================================== ;; Lock or unlock a run ;;====================================================================== @@ -2451,11 +2455,11 @@ (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (open-run-close db:find-and-mark-incomplete #f) + (rmt:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -909,11 +909,11 @@ ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) (begin - (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) + (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) (define (tests:readlines filename) (call-with-input-file filename (lambda (p)