Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -163,10 +163,15 @@ chmod a+x $@ deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm + make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) + +mtest-reaper: $(PREFIX)/bin/mtest-reaper # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard @@ -177,10 +182,11 @@ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm ext-tests/.fslckout : $(MTQA_FOSSIL) @@ -282,5 +288,6 @@ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -6,10 +6,12 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== + +(use srfi-69 posix) (declare (unit api)) (declare (uses rmt)) (declare (uses db)) (declare (uses tasks)) @@ -39,10 +41,11 @@ get-run-status get-run-stats get-targets get-target ;; register-run + get-tests-tags get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs @@ -61,21 +64,23 @@ synchash-get )) (define api:write-queries '( + get-keys-write ;; dummy "write" query to force server start + ;; SERVERS start-server kill-server ;; TESTS test-set-state-status-by-id delete-test-records delete-old-deleted-test-records - test-set-status-state + test-set-state-status test-set-top-process-pid - roll-up-pass-fail-counts + set-state-status-and-roll-up-items update-pass-fail-counts top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") ;; RUNS register-run @@ -111,169 +116,179 @@ ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t - (let ((cmd (vector-ref dat 0)) - (params (vector-ref dat 1))) - (case (if (symbol? cmd) - cmd - (string->symbol cmd)) - - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) - ;; ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - - ;; MISC - ((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:with-db dbstruct run-id #t ;; these are all for modifying the db - (lambda (db) - (db:general-call db stmtname realparams))))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)))))))) - + (let* ((cmd-in (vector-ref dat 0)) + (cmd (if (symbol? cmd-in) + cmd-in + (string->symbol cmd-in))) + (params (vector-ref dat 1)) + (start-t (current-milliseconds)) + (res + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) + ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + + ;; RUNS + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + + ;; MISC + ((sync-inmem->db) (let ((run-id (car params))) + (db:sync-touched dbstruct run-id force-sync: #t))) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + + ;; TESTMETA + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) + + ;; TASKS + ((tasks-add) (apply tasks:add dbstruct params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) + + ;; ARCHIVES + ;; ((archive-get-allocations) + ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) + ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + + ;;====================================================================== + ;; READ ONLY QUERIES + ;;====================================================================== + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-target) (apply db:get-target dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) + + ;; ARCHIVES + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) + + ;; STEPS + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + + ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:general-call dbstruct stmtname realparams))) + ((sdb-qry) (apply sdb:qry params)) + ((ping) (current-process-id)) + + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))))) + (let ((delta-t (- (current-milliseconds) + start-t))) + (hash-table-set! *db-api-call-time* cmd + (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) + res))))) ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc + (set! *api-process-request-count* (+ *api-process-request-count* 1)) (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj)) (resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result ) (res (vector-ref resdat 1))) - + (if (> *api-process-request-count* *max-api-process-requests*) + (set! *max-api-process-requests* *api-process-request-count*)) + (set! *api-process-request-count* (- *api-process-request-count* 1)) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds ;; (rmt:dat->json-str ;; (if (or (string? res) ;; (list? res) ;; (number? res) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -197,19 +197,19 @@ (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (if (> remaining-tries 8) (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time - (server:try-running run-id) + (server:try-running *toppath*) (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (if (< num-available 2) - (server:try-running run-id)) + (server:try-running *toppath*)) (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) ;; keep this as a function to ease future (define (client:start run-id server-info) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -90,19 +90,21 @@ (define *db-stats-mutex* (make-mutex)) ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server (define *db-write-access* #t) ;; db sync -(define *db-last-write* 0) ;; used to record last touch of db (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another -(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* and *db-last-write* +(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) +(define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) +(define *db-with-db-mutex* (make-mutex)) +(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold @@ -115,10 +117,12 @@ (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) +(define *api-process-request-count* 0) +(define *max-api-process-requests* 0) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport @@ -135,10 +139,18 @@ (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) +(defstruct remote + (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) + (server-url (if *toppath* (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*) #f)) + (last-server-check 0) ;; last time we checked to see if the server was alive + (conndat #f) + (transport *transport-type*) + (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds + ;; launching and hosts (defstruct host (reachable #f) (last-update 0) (last-used 0) @@ -531,47 +543,59 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) - (let ((ohh (common:on-homehost?)) - (srv (args:get-arg "-server"))) - ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) (and (common:on-homehost?) - (args:get-arg "-server")))) + (args:get-arg "-server"))) + +;; (let ((ohh (common:on-homehost?)) +;; (srv (args:get-arg "-server"))) +;; (and ohh srv))) + ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps (define (common:sync-to-megatest.db dbstruct) (let ((start-time (current-seconds)) (res (db:multi-db-sync dbstruct 'new2old))) (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds") + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds"))) + (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)))) res)) + + + +(define *wdnum* 0) +(define *wdnum*mutex (make-mutex)) ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; (define (common:watchdog) + (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds))) - (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync) - (if legacy-sync + (last-time (current-seconds)) + (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) + ) + (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) + (if (and legacy-sync (not *time-to-exit*)) (let ((dbstruct (db:setup))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () + ;;(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) - (let* ((need-sync (>= *db-last-write* *db-last-sync*)) ;; no sync since last write + (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write (sync-in-progress *db-sync-in-progress*) - (should-sync (> (- (current-seconds) *db-last-sync*) 5)) ;; sync every five seconds minimum + (should-sync (and (not *time-to-exit*) + (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum (will-sync (and (or need-sync should-sync) (not sync-in-progress))) (start-time (current-seconds))) ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) (if will-sync (set! *db-sync-in-progress* #t)) @@ -599,55 +623,71 @@ ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) + ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + (if (and (not *time-to-exit*) (< count 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) - (loop))) + (if (not *time-to-exit*) (loop)))) (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) (define (std-exit-procedure) + (on-exit (lambda () 0)) + ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #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 *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated + (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) - (close-output-port *default-log-port*) + (if (and *runremote* + (remote-conndat *runremote*)) + (begin + (http-client#close-all-connections!))) ;; for http-client + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry - (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff - (thread-sleep! 2)) - (debug:print 4 *default-log-port* " ... done") - ) + (begin + (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff + (begin + (thread-sleep! 2))) + (debug:print 4 *default-log-port* " ... done") + ) "clean exit"))) (thread-start! th1) (thread-start! th2) - (thread-join! th1)))) + (thread-join! th1) + ) + ) + + 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) + ;;(BB> "got signal "signum) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C @@ -779,20 +819,24 @@ (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) - (let* ((rtestpatt (if rconf (runconfigs-get rconf "TESTPATT") #f)) - (args-testpatt (or (args:get-arg "-testpatt") - (args:get-arg "-runtests") - "%")) - (testpatt (or (and (equal? args-testpatt "%") - rtestpatt) - args-testpatt))) - (if rtestpatt (debug:print-info 0 *default-log-port* "TESTPATT from runconfigs: " rtestpatt)) - testpatt)) - + (let* ((tagexpr (args:get-arg "-tagexpr")) + (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) + (testpatt-key (if (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))) + (cond + (tags-testpatt + (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) + tags-testpatt) + ((and (equal? args-testpatt "%") rtestpatt) + (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) + rtestpatt) + (else args-testpatt)))) + (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree")))) @@ -921,10 +965,20 @@ #f ;; better than an exception for my needs (fold (lambda (a b) (if (comp a b) a b)) (car lst) lst))) + +;; get min or max, use > for max and < for min, this works around the limits on apply +;; +(define (common:sum lst) + (if (null? lst) + 0 + (fold (lambda (a b) + (+ a b)) + (car lst) + lst))) ;; path list to hash-table tree ;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) ;; (define (common:list->htree lst) @@ -1033,10 +1087,24 @@ (define (common:lazy-modification-time fpath) (handle-exceptions exn 0 (file-modification-time fpath))) + +;; find timestamp of newest file associated with a sqlite db file +(define (common:lazy-sqlite-db-modification-time fpath) + (let* ((glob-list (handle-exceptions + exn + '("/no/such/file") + (glob (conc fpath "*")))) + (file-list (if (eq? 0 (length glob-list)) + '("/no/such/file") + glob-list))) + (apply max + (map + common:lazy-modification-time + file-list)))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? @@ -1084,11 +1152,12 @@ (lambda ()(list (read)(read)(read))))) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read)))))) ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads -;; returns list (normalized-proc-load normalized-core-load 1m 5m 15m ncores nthreads) +;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. +;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; (define (common:get-normalized-cpu-load remote-host) (let ((data (if remote-host (with-input-from-pipe (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") @@ -1143,51 +1212,89 @@ (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; -(define (common:get-least-loaded-host hosts-raw) +;; return list of +;; ( reachable? cpuload update-time ) +(define (common:get-host-info hostname) + (let* ((loadinfo (rmt:get-latest-host-load hostname)) + (load (car loadinfo)) + (load-sample-time (cdr loadinfo)) + (load-sample-age (- (current-seconds) load-sample-time)) + (loadinfo-timeout-seconds 20) + (host-last-update-timeout-seconds 10) + (host-rec (hash-table-ref/default *host-loads* hostname #f)) + ) + (cond + ((< load-sample-age loadinfo-timeout-seconds) + (list #t + load-sample-time + load)) + ((and host-rec + (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds))) + (list #t + (host-last-update host-rec) + (host-last-cpuload host-rec ))) + ((common:unix-ping hostname) + (list #t + (current-seconds) + (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) + (else + (list #f 0 -1))))) + +(define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw))) - (if (null? hosts) - #f - ;; - ;; stategy: - ;; sort by last-used and normalized-load - ;; if last-updated > 15 seconds then re-update - ;; take the host with the lowest load with the lowest last-used (i.e. not used for longest time) - ;; - (let ((best-host #f) - (curr-time (current-seconds))) - (for-each - (lambda (hostname) - (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) - (if h - h - (let ((h (make-host))) - (hash-table-set! *host-loads* hostname h) - h)))) - ;; if host hasn't been pinged in 15 sec update it's data - (ping-good (if (< (- curr-time (host-last-update rec)) 15) - (host-reachable rec) - (or (host-reachable rec) - (begin - (host-reachable-set! rec (common:unix-ping hostname)) - (host-last-update-set! rec curr-time) - (host-last-cpuload-set! rec (common:get-normalized-cpu-load hostname)) - (host-reachable rec)))))) - (cond - ((not best-host) - (set! best-host hostname)) - ((and ping-good - (< (alist-ref 'adj-core-load (host-last-cpuload rec)) - (alist-ref 'adj-core-load - (host-last-cpuload (hash-table-ref *host-loads* best-host))))) - (set! best-host hostname))))) - hosts) - best-host)))) + (for-each + (lambda (hostname) + (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (host-info (common:get-host-info hostname)) + (is-reachable (car host-info)) + (last-reached-time (cadr host-info)) + (load (caddr host-info))) + (host-reachable-set! rec is-reachable) + (host-last-update-set! rec last-reached-time) + (host-last-cpuload-set! rec load))) + hosts))) + +(define (common:get-least-loaded-host hosts-raw) + (let* ((hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw)) + (best-host #f) + (best-load 99999) + (curr-time (current-seconds))) + (common:update-host-loads-table hosts) + (for-each + (lambda (hostname) + (let* ((rec + (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (reachable (host-reachable rec)) + (load (host-last-cpuload rec))) + (cond + ((not reachable) #f) + ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut + (+ best-load (/ (random 250) 1000)) ) + (set! best-load load) + (set! best-host hostname))))) + hosts) + best-host)) + + + (define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -121,10 +121,11 @@ (db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) +(define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) (location #f)) (for-each (lambda (frame) @@ -131,12 +132,59 @@ (let* ((this-loc (vector-ref frame 0)) (this-func (cadr (string-split this-loc " ")))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) - (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args))) + (let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) in-args))) (apply debug:print dp-args)))) + +(define *BBpp_custom_expanders_list* (make-hash-table)) + + + +;; register hash tables with BBpp. +(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: + (cons hash-table? hash-table->alist)) + +;; test name converter +(define (BBpp_custom_converter arg) + (let ((res #f)) + (for-each + (lambda (custom-type-name) + (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) + (custom-type-test (car custom-type-info)) + (custom-type-converter (cdr custom-type-info))) + (when (and (not res) (custom-type-test arg)) + (set! res (custom-type-converter arg))))) + (hash-table-keys *BBpp_custom_expanders_list*)) + (if res (BBpp_ res) arg))) + +(define (BBpp_ arg) + (cond + ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) + ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) + ((hash-table? arg) + (let ((al (hash-table->alist arg))) + (BBpp_ (cons HASH_TABLE: al)))) + ((null? arg) '()) + ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) + ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) + (else (BBpp_custom_converter arg)))) + +;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp +(define (BBpp arg) + (pp (BBpp_ arg))) + +;(use define-macro) +(define-syntax inspect + (syntax-rules () + [(_ x) + ;; (with-output-to-port (current-error-port) + (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) + ;; ) + ] + [(_ x y ...) (begin (inspect x) (inspect y ...))])) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -271,13 +271,14 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (let ((txtbox (iup:textbox #:action (lambda (val a b) - (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (rmt:test-set-state-status run-id test-id #f #f b) ;; IDEA: Just set a variable with the proc to call? - (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL"))) (set! wtxtbox txtbox) txtbox)) @@ -287,11 +288,11 @@ (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) - (rmt:roll-up-pass-fail-counts run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected + (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -321,11 +322,11 @@ (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) - (rmt:roll-up-pass-fail-counts run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected + (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -402,11 +403,12 @@ (let ((comment (iup:attribute comnt "VALUE")) (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin - (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status-by run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" @@ -473,11 +475,11 @@ (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn - (tests:get-testconfig (db:test-get-testname testdat) test-registry #f) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dashboard-tests:run-html-viewer logfile) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -290,10 +290,21 @@ ;; runs summary view tests-tree ;; used in newdashboard ) +;; register tabdat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle +(hash-table-set! *BBpp_custom_expanders_list* TABDAT: + (cons dboard:tabdat? + (lambda (tabdat-item) + (filter + (lambda (alist-entry) + (member (car alist-entry) + '(allruns-by-id allruns))) ;; FIELDS OF INTEREST + (dboard:tabdat->alist tabdat-item))))) + (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:tabdat-test-patts-use vec) @@ -355,15 +366,29 @@ rowsused ;; hash of lists covering what areas used - replace with quadtree hierdat ;; put hierarchial sorted list here tests ;; hash of id => testdat ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals - ((last-update 0) : fixnum) ;; last query to db got records from before last-update - ((data-changed #f) : boolean) - ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items - (db-path #f) - ) + ((last-update 0) : number) ;; last query to db got records from before last-update + ((last-db-time 0) : number) ;; last timestamp on megatest.db + ((data-changed #f) : boolean) + ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items + (db-path #f)) + +;; register dboard:rundat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle +(hash-table-set! *BBpp_custom_expanders_list* RUNDAT: + (cons dboard:rundat? + (lambda (tabdat-item) + (filter + (lambda (alist-entry) + (member (car alist-entry) + '(run run-data-offset ))) ;; FIELDS OF INTEREST + (dboard:rundat->alist tabdat-item))))) + + + (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began (make-dboard:rundat run: run tests: (or tests (make-hash-table)) @@ -490,78 +515,87 @@ ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (num-to-get - (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get"))) - (if num-tests-from-config - (begin - (BB> "override num-tests 100 -> "num-tests-from-config) - (string->number num-tests-from-config)) - 100))) - (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) - (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab - (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab - (sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) + (let* ((start-time (current-seconds)) + (access-mode (dboard:tabdat-access-mode tabdat)) + (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") + "200"))) + (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) + (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) + (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab + (sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) ;; note: the rundat is normally created in "update-rundat". - (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) - (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) - rd))) + (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) + (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) + rd))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) - (last-update - (if do-not-use-query-timestamps - 0 - (dboard:rundat-last-update run-dat) - ;;(hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0) - )) - - (db-path (or (dboard:rundat-db-path run-dat) - (let* ((db-dir (tasks:get-task-db-path)) - (db-pth (conc db-dir "/" run-id ".db"))) - (dboard:rundat-db-path-set! run-dat db-pth) - db-pth))) - (tmptests (if (or do-not-use-db-file-timestamps - (>= (common:lazy-modification-time db-path) last-update)) - (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run - run-id testnamepatt states statuses ;; run-id testpatt states statuses - (dboard:rundat-run-data-offset run-dat) - num-to-get - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) ;; last-update - *dashboard-mode*) ;; use dashboard mode - '())) + (last-update (if (or do-not-use-query-timestamps + (dboard:tabdat-filters-changed tabdat)) + 0 + (dboard:rundat-last-update run-dat))) + (last-db-time (if do-not-use-db-file-timestamps + 0 + (dboard:rundat-last-db-time run-dat))) + (db-path (or (dboard:rundat-db-path run-dat) + (let* ((db-dir (common:get-db-tmp-area)) + (db-pth (conc db-dir "/megatest.db"))) + (dboard:rundat-db-path-set! run-dat db-pth) + db-pth))) + (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) + (db-modified (>= db-mod-time last-db-time)) + (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress + (tmptests (if (or do-not-use-db-file-timestamps + (dboard:tabdat-filters-changed tabdat) + db-modified) + (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run + run-id testnamepatt states statuses ;; run-id testpatt states statuses + (dboard:rundat-run-data-offset run-dat) ;; query offset + num-to-get + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + #f ;; 'shortlist ;; qrytype + last-update ;; last-update + *dashboard-mode*) ;; use dashboard mode + '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) ht) - (dboard:rundat-tests run-dat)))) - ;;(start-time (current-seconds))) + (dboard:rundat-tests run-dat))) + (got-all (< (length tmptests) num-to-get)) ;; got all for this round + ) + + ;; if we saw the db modified, reset it (the signal has already been used) + (if (and got-all ;; (not multi-get) + db-modified) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset - (dboard:rundat-run-data-offset-set! - run-dat - (if (< (length tmptests) num-to-get) - 0 - (let ((newval (+ num-to-get (dboard:rundat-run-data-offset run-dat)))) - ;; (print "Incremental get, offset=" (dboard:rundat-run-data-offset run-dat) " retrieved: " (length tmptests) " newval: " newval) - newval))) - + ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the + ;; data has been read + ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above + ;; + ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) + (if got-all + (begin + (dboard:rundat-last-update-set! run-dat (- start-time 2)) + (dboard:rundat-run-data-offset-set! run-dat 0)) + (begin + (dboard:rundat-run-data-offset-set! run-dat + (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) + (for-each (lambda (tdat) (let ((test-id (db:test-get-id tdat)) (state (db:test-get-state tdat))) (dboard:rundat-data-changed-set! run-dat #t) @@ -568,22 +602,10 @@ (if (equal? state "DELETED") (hash-table-delete! tests-ht test-id) (hash-table-set! tests-ht test-id tdat)))) tmptests) - ;; set last-update to 0 if still getting data incrementally - - (if (> (dboard:rundat-run-data-offset run-dat) 0) - (begin - ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0") - ;; (dboard:rundat-last-update-set! run-dat 0) - (dboard:rundat-last-update-set! run-dat 0)) - ;; (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- start-time 3)) - - (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured. - - ;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht)) tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data ;; @@ -623,10 +645,12 @@ (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) + ;;(BB> "In update-rundat") + ;;(inspect allruns runs-hash) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; @@ -740,11 +764,17 @@ (run-struct (or run-struct (dboard:rundat-make-init run: run tests: tests-ht key-vals: key-vals))) - (new-res (if (null? all-test-ids) res (cons run-struct res))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (db:get-value-by-header (dboard:rundat-run b) header "id")))))) (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) @@ -2659,11 +2689,11 @@ (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "TIME" 300 ) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) @@ -3391,10 +3421,13 @@ ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) + ;;(BB> "dashboard:runs-tab-updater") + ;;(inspect tabdat) + (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -13,11 +13,11 @@ ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc -(require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension? +(use (srfi 18) extras tcp stack) ;; RADT => use of require-extension? (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; RADT => prefix?? (declare (unit db)) @@ -42,11 +42,12 @@ ;; each db entry is a pair ( db . dbfilepath ) ;; I propose this record evolves into the area record ;; (defstruct dbr:dbstruct - (tmpdb #f) + ;; (tmpdb #f) + (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet ) ;; goal is to converge on one struct for an area but for now it is too confusing @@ -91,12 +92,17 @@ ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct . blah) ;; run-id) - (or (dbr:dbstruct-tmpdb dbstruct) +(define (db:get-db dbstruct) ;; run-id) + (if (stack? (dbr:dbstruct-dbstack dbstruct)) + (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) + (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) + ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) + newdb) + (stack-pop! (dbr:dbstruct-dbstack dbstruct))) (db:open-db dbstruct))) ;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) @@ -125,24 +131,35 @@ ;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) - (let* ((dbdat (if (dbr:dbstruct? dbstruct) - (db:get-db dbstruct run-id) - (begin - (print-call-chain) - (print "db:with-db called with dbdat instead of dbstruct, FIXME!!") - dbstruct))) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) + (let* ((have-struct (dbr:dbstruct? dbstruct)) + (dbdat (if have-struct + (db:get-db dbstruct) + #f)) + (db (if have-struct + (db:dbdat-get-db dbdat) + dbstruct)) + (use-mutex (> *api-process-request-count* 25))) + (if (and use-mutex + (common:low-noise-print 120 "over-50-parallel-api-requests")) + (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) + (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) + (debug:print-info 0 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) (handle-exceptions exn (begin + (print-call-chain (current-error-port)) (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port))) + ;; there is no recovering at this time. exit + (exit 50)) + (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let ((res (apply proc db params))) + (if use-mutex (mutex-unlock! *db-with-db-mutex*)) ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)) res)))) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== @@ -171,30 +188,19 @@ ;; (was planned to be; zeroth db with name=main.db) ;; ;; If run-id is #f return to create and retrieve the path where the db will live. ;; (define (db:dbfile-path . junk) ;; run-id) - (let* ((dbdir (common:get-db-tmp-area))) ;; (db:get-dbdir)) -;; (fname (if run-id -;; (if (eq? run-id 0) "main.db" (conc run-id ".db")) -;; #f))) + (let* ((dbdir (common:get-db-tmp-area))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) - dbdir)) ;; (if fname -;; (conc dbdir "/" fname) -;; dbdir))) - -;; Returns the database location as specified in config file -;; -;; (define db:get-dbdir common:get-db-tmp-area) -;; (or (configf:lookup *configdat* "setup" "dbdir") -;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) - + dbdir)) + (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) ;; open an sql database inside a file lock @@ -264,14 +270,13 @@ ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct #!key (areapath #f)) - (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct - (if tmpdb - tmpdb - ;; (mutex-lock! *rundb-mutex*) + (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct + (if (stack? tmpdb-stack) + (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((dbpath (db:dbfile-path)) ;; 0)) (dbexists (file-exists? dbpath)) (dbfexists (file-exists? (conc dbpath "/megatest.db"))) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (mtdb (db:open-megatest-db)) @@ -278,11 +283,12 @@ (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (dbr:dbstruct-mtdb-set! dbstruct mtdb) - (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) ;; olddb is already a (cons db path) + (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) (dbr:dbstruct-refndb-set! dbstruct refndb) ;; (mutex-unlock! *rundb-mutex*) (if (and (not dbfexists) write-access) ;; *db-write-access*) ;; did not have a prior db and do have write access (begin @@ -324,11 +330,11 @@ (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct)) + (let ((tmpdb (db:get-db dbstruct)) (mtdb (dbr:dbstruct-mtdb dbstruct)) (refndb (dbr:dbstruct-refndb dbstruct)) (start-t (current-seconds))) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) (mutex-lock! *db-multi-sync-mutex*) @@ -335,21 +341,24 @@ (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) (mutex-unlock! *db-multi-sync-mutex*) (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-sync* start-t) - (mutex-unlock! *db-multi-sync-mutex*))) + (set! *db-last-access* start-t) + (mutex-unlock! *db-multi-sync-mutex*) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) (begin ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. - (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) + (let ((tdbs (map db:dbdat-get-db + (stack->list (dbr:dbstruct-dbstack dbstruct)))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (if tdb (sqlite3:finalize! tdb)) + (map sqlite3:finalize! tdbs) (if mdb (sqlite3:finalize! mdb)) (if rdb (sqlite3:finalize! rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) @@ -625,11 +634,11 @@ ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) (stmth (sqlite3:prepare db full-ins))) - ;; (db:delay-if-busy targdb) ;; NO WAITING + (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () @@ -813,11 +822,11 @@ ;; (define (db:multi-db-sync dbstruct . options) (if (not (launch:setup)) (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (dbr:dbstruct-tmpdb dbstruct)) + (tmpdb (db:get-db dbstruct)) (refndb (dbr:dbstruct-refndb dbstruct)) (allow-cleanup #t) ;; (if run-ids #f #t)) (tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (data-synced 0)) ;; count of changed records (I hope) @@ -942,10 +951,11 @@ ;; (delete-file fullname))))) ;; dead-runs)))) ;; ;; (db:close-all dbstruct) ;; (sqlite3:finalize! mdb) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) data-synced))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) @@ -1138,11 +1148,11 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; @@ -1210,11 +1220,11 @@ ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; (define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) @@ -1241,11 +1251,11 @@ ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) @@ -1255,25 +1265,27 @@ (if res ;; record exists, update df and return id (begin (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) @@ -1370,62 +1382,63 @@ ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== (define (db:have-incompletes? dbstruct run-id ovr-deadtime) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (incompleted '()) + (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - (if (and (null? incompleted) - (null? oldlaunched) - (null? toplevels)) - #f - #t))) + (db:with-db + dbstruct #f #f + (lambda (db) + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" + run-id) + + (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (if (and (null? incompleted) + (null? oldlaunched) + (null? toplevels)) + #f + #t))))) ;; given a launch delay (minimum time from last launch) return amount of time to wait ;; ;; (define (db:launch-delay-left dbstruct run-id launch-delay) @@ -1434,96 +1447,103 @@ ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (incompleted '()) + (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - - ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. - ;; - ;; (db:delay-if-busy dbdat) - (let* (;; (min-incompleted (filter (lambda (x) - ;; (let* ((testpath (cadr x)) - ;; (tdatpath (conc testpath "/testdat.db")) - ;; (dbexists (file-exists? tdatpath))) - ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete - ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim - ;; incompleted)) - (min-incompleted-ids (map car incompleted)) ;; do 'em all - (all-ids (append min-incompleted-ids (map car oldlaunched)))) - (if (> (length all-ids) 0) - (begin - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (sqlite3:execute - db - (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" - (string-intersperse (map conc all-ids) ",") - ");") - run-id)))) - - ;; Now do rollups for the toplevel tests - ;; - ;; (db:delay-if-busy dbdat) - (for-each - (lambda (toptest) - (let ((test-name (list-ref toptest 3))) -;; (run-id (list-ref toptest 5))) - (db:top-test-set-per-pf-counts dbstruct run-id test-name))) - toplevels))) + (db:with-db + dbstruct #f #f + (lambda (db) + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" + run-id) + + (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + ;; (db:delay-if-busy dbdat) + (let* (;; (min-incompleted (filter (lambda (x) + ;; (let* ((testpath (cadr x)) + ;; (tdatpath (conc testpath "/testdat.db")) + ;; (dbexists (file-exists? tdatpath))) + ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete + ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim + ;; incompleted)) + (min-incompleted-ids (map car incompleted)) ;; do 'em all + (all-ids (append min-incompleted-ids (map car oldlaunched)))) + (if (> (length all-ids) 0) + (begin + (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (for-each + (lambda (test-id) + (db:test-set-state-status dbstruct run-id test-id "COMPLETE" "DEAD" "Test failed to complete")) + all-ids)))))))) + +;; ALL REPLACED BY THE BLOCK ABOVE +;; +;; (sqlite3:execute +;; db +;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" +;; (string-intersperse (map conc all-ids) ",") +;; ");") +;; run-id)))) +;; +;; ;; Now do rollups for the toplevel tests +;; ;; +;; ;; (db:delay-if-busy dbdat) +;; (for-each +;; (lambda (toptest) +;; (let ((test-name (list-ref toptest 3))) +;; ;; (run-id (list-ref toptest 5))) +;; (db:top-test-set-per-pf-counts dbstruct run-id test-name))) +;; toplevels))) ;; 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 (db:get-db dbstruct run-id) '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 (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: ;; ;; 1. Look at test records either deleted or part of deleted run: @@ -1664,23 +1684,24 @@ ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; (define (db:get-var dbstruct var) - (let* ((res #f) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - "SELECT val FROM metadat WHERE var=?;" var) - ;; convert to number if can - (if (string? res) - (let ((valnum (string->number res))) - (if valnum (set! res valnum)))) - res)) + (let* ((res #f)) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + "SELECT val FROM metadat WHERE var=?;" var) + ;; convert to number if can + (if (string? res) + (let ((valnum (string->number res))) + (if valnum (set! res valnum)))) + res)))) ;; This was part of db:get-var. It was used to estimate the load on ;; the database files. ;; ;; scale by 10, average with current value. @@ -1691,16 +1712,15 @@ ;; (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) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) (define (db:del-var dbstruct var) - ;; (db:delay-if-busy) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;; use a global for some primitive caching, it is just silly to @@ -1796,13 +1816,11 @@ ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (keys (map car keyvals)) + (let* ((keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) @@ -1809,26 +1827,25 @@ (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" - (let ((res #f)) - ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") - allvals) - ;; (db:delay-if-busy dbdat) - (apply sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 *default-log-port* "qry: " qry) - qry) - qryvals) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) - res) + (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" 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)))) ;; replace header and keystr with a call to runs:get-std-run-fields @@ -1946,23 +1963,26 @@ (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db - "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" + "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;" run-id)))) ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; (define (db:update-run-stats dbstruct run-id stats) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f + (lambda (db) ;; remove previous data + (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) (res (sqlite3:with-transaction db @@ -1972,10 +1992,11 @@ (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) (apply sqlite3:execute stmt2 run-id dat)) stats))))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2) + ;; (mutex-unlock! *db-transaction-mutex*) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct @@ -1987,10 +2008,25 @@ (cons (list state status count) res)) '() db "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" run-id)))) + +(define (db:print-current-query-stats) + ;; generate stats from *db-api-call-time* + (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*) + (lambda (a b) + (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a))) + (sum-b (common:sum (hash-table-ref *db-api-call-time* b)))) + (> sum-a sum-b)))))) + (for-each + (lambda (cmd-key) + (let* ((dat (hash-table-ref *db-api-call-time* cmd-key)) + (avg (if (> (length dat) 0) + (/ (common:sum dat)(length dat))))) + (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat)))) + ordered-keys))) (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f @@ -2007,23 +2043,23 @@ ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... (define (db:get-run-stats dbstruct) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (totals (make-hash-table)) + (let* ((totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (run-id runname) - (set! runs-info (cons (list run-id runname) runs-info))) - db - "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (run-id runname) + (set! runs-info (cons (list run-id runname) runs-info))) + db + "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run (let* ((run-id (car run-info)) @@ -2039,11 +2075,12 @@ (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) db - "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;" + run-id) ;; add the per run counts to res (for-each (lambda (state) (set! res (cons (list run-name state (hash-table-ref curr state)) res))) (sort (hash-table-keys curr) string>=)) (set! curr (make-hash-table)))))) @@ -2102,70 +2139,61 @@ ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (res (vector #f #f #f #f)) + (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (apply vector a x))) - db - (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") - run-id) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (apply vector a x))) + db + (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") + run-id))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run dbstruct run-id comment) (db:with-db - dbstruct - #f - #f + dbstruct #f #f (lambda (db) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) - ;; First set any related tests to DELETED - (let* ((rdbdat (db:get-db dbstruct run-id)) - (rdb (db:dbdat-get-db rdbdat)) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - ;; (db:delay-if-busy rdbdat) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) + ;; (db:delay-if-busy dbdat) + (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db - dbstruct - #f - #t + dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db - dbstruct - #f - #t + dbstruct #f #t (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe @@ -2173,23 +2201,21 @@ (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - ;; (db:delay-if-busy dbdat) - (if msg - (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) - (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) + (db:with-db + dbstruct #f #f + (lambda (db) + (if msg + (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) + (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db - dbstruct - #f - #f + dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (status) (set! res status)) db @@ -2203,39 +2229,40 @@ ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) - (res '()) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (list key key-val) res))) - db qry run-id))) - keys) - (reverse res))) + (res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons (list key key-val) res))) + db qry run-id))) + keys))) + (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) - (res '()) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) + (res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys))) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often @@ -2250,18 +2277,22 @@ (let* ((keyvals (rmt:get-key-val-pairs run-id)) (kvalues (map cadr keyvals)) (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) - (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db - (lambda (db) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) - prev-run-ids))) + (if (null? keyvals) + '() + (begin + (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db + (lambda (db) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") + (append kvalues (list run-id))))) + prev-run-ids))))) ;;====================================================================== ;; T E S T S ;;====================================================================== @@ -2428,16 +2459,16 @@ ;; 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) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat))) - (db:general-call dbdat 'delete-test-step-records (list test-id)) - ;; (db:delay-if-busy) - (db:general-call dbdat 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE 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:with-db + dbstruct #f #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) (let (;; (run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past @@ -2466,26 +2497,25 @@ (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) (for-each (lambda (testname) (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " (if currstate (conc "state='" currstate "' AND ") "") (if currstatus (conc "status='" currstatus "' AND ") "") - " run_id=? AND testname LIKE ?;"))) + " run_id=? AND testname LIKE ?;")) + (test-id (db:get-test-id dbstruct run-id testname ""))) (db:with-db dbstruct run-id #t (lambda (db) - (let ((test-id (db:get-test-id dbstruct run-id testname ""))) - (sqlite3:execute db qry newstate newstatus run-id testname) - (if test-id (mt:process-triggers run-id test-id newstate newstatus))) - )))) + (sqlite3:execute db qry newstate newstatus run-id testname))) + (if test-id (mt:process-triggers dbstruct run-id test-id newstate newstatus)))) testnames)) -;; 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 -;; -(define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) +;; ;; 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 +;; ;; +(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment) (db:with-db dbstruct run-id #t (lambda (db) @@ -2497,12 +2527,12 @@ (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 run-id test-id newstate newstatus)))) + test-id)))))) + (mt:process-triggers dbstruct run-id test-id newstate newstatus)) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) (db:with-db @@ -2558,23 +2588,23 @@ (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname)))) (define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (testname) - (set! testnames (cons testname testnames))) - db - "SELECT testname FROM test_meta WHERE jobgroup=?" - jobgroup) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (testname) + (set! testnames (cons testname testnames))) + db + "SELECT testname FROM test_meta WHERE jobgroup=?" + jobgroup))) ;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS? (if (not (null? testnames)) (db:with-db dbstruct run-id @@ -2584,14 +2614,14 @@ db (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('" (string-intersperse testnames "','") "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ??? )) - 0))))) - ;; DEBUG FIXME - need to merge this v.155 query correctly - ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?) - ;; AND NOT (uname = 'n/a' AND item_path = '');" + 0)))) + +;; tags: '("tag%" "tag2" "%ag6") +;; ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING (define (db:estimated-tests-remaining dbstruct run-id) (db:with-db @@ -2662,24 +2692,22 @@ ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) - (let* ((dbdat (if (vector? dbstruct) - (db:get-db dbstruct run-id) - dbstruct)) ;; still settling on when to use dbstruct or dbdat - (db (db:dbdat-get-db dbdat)) - (res '())) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - res))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") - run-id) + (let* ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) + res))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") + run-id))) res)) (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (db) @@ -2858,27 +2886,27 @@ ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (fail-count 0) + (let* ((fail-count 0) (pass-count 0)) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (fcount pcount) - (set! fail-count fcount) - (set! pass-count pcount)) - db - "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (fcount pcount) + (set! fail-count fcount) + (set! pass-count pcount)) + 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 dbdat 'pass-fail-counts (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 dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) + 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)) + ;; 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)))))) ;; each section is a rule except "final" which is the final result ;; ;; [rule-5] ;; operator in @@ -2959,105 +2987,107 @@ ;; faz,bar, 10, 8mA, , ,"this is a comment" ;; EOF (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) - (for-each - (lambda (csvrow) - (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) - (category (list-ref padded-row 0)) - (variable (list-ref padded-row 1)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (if (>= value expected) "pass" "fail")) - ((<=) (if (<= value expected) "pass" "fail")) - (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type))) - csvlist))) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((csvlist (csv->list (make-csv-reader + (open-input-string csvdata) + '((strip-leading-whitespace? #t) + (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) + (for-each + (lambda (csvrow) + (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) + (category (list-ref padded-row 0)) + (variable (list-ref padded-row 1)) + (value (any->number-if-possible (list-ref padded-row 2))) + (expected (any->number-if-possible (list-ref padded-row 3))) + (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number + (units (list-ref padded-row 5)) + (comment (list-ref padded-row 6)) + (status (let ((s (list-ref padded-row 7))) + (if (and (string? s)(or (string-match (regexp "^\\s*$") s) + (string-match (regexp "^n/a$") s))) + #f + s))) ;; if specified on the input then use, else calculate + (type (list-ref padded-row 8))) + ;; look up expected,tol,units from previous best fit test if they are all either #f or '' + (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) + + (if (and (or (not expected)(equal? expected "")) + (or (not tol) (equal? expected "")) + (or (not units) (equal? expected ""))) + (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) + (set! expected new-expected) + (set! tol new-tol) + (set! units new-units))) + + (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; calculate status if NOT specified + (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers + (if (number? tol) ;; if tol is a number then we do the standard comparison + (let* ((max-val (+ expected tol)) + (min-val (- expected tol)) + (result (and (>= value min-val)(<= value max-val)))) + (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result) + (set! status (if result "pass" "fail"))) + (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. + (case (string->symbol tol) ;; tol should be >, <, >=, <= + ((>) (if (> value expected) "pass" "fail")) + ((<) (if (< value expected) "pass" "fail")) + ((>=) (if (>= value expected) "pass" "fail")) + ((<=) (if (<= value expected) "pass" "fail")) + (else (conc "ERROR: bad tol comparator " tol)))))) + (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; (db:delay-if-busy dbdat) + (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units (if comment comment "") status type))) + csvlist))))) ;; This routine moved from tdb.scm, tdb:read-test-data ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (res '())) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - db - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (reverse res))) + (let* ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + db + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) + (reverse res))))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (row-ids '()) - (keystr (string-intersperse - (map (lambda (key val) - (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) - (sqlite3:for-each-row - (lambda (rid) - (set! row-ids (cons rid row-ids))) - runsqry) - (sqlite3:finalize! runsqry) - row-ids)) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((row-ids '()) + (keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + ;; (testqry (tests:match->sqlqry testpatt)) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + (sqlite3:for-each-row + (lambda (rid) + (set! row-ids (cons rid row-ids))) + runsqry) + (sqlite3:finalize! runsqry) + row-ids)))) ;; finds latest matching all patts for given run-id ;; (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) @@ -3126,140 +3156,111 @@ (print-call-chain (current-error-port)) msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) ;; rpc -;; This is to be the big daddy call - -(define (db:test-set-status-state dbstruct run-id test-id status state msg) - (let ((dbdat (db:get-db dbstruct run-id))) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call dbdat 'set-test-start-time (list test-id))) - ;; (if msg - ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) - ;; (db:general-call dbdat 'state-status (list state status test-id))) - (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) - ;; process the test_data table - (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup dbstruct run-id test-id status)) - (mt:process-triggers run-id test-id state status))) +;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items +;; ; +;; define (db:test-set-state-status dbstruct run-id test-id state status msg) +;; (let ((dbdat (db:get-db dbstruct run-id))) +;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) +;; (db:general-call dbdat 'set-test-start-time (list test-id))) +;; ;; (if msg +;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) +;; ;; (db:general-call dbdat 'state-status (list state status test-id))) +;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) +;; ;; process the test_data table +;; (if (and test-id state status (equal? status "AUTO")) +;; (db:test-data-rollup dbstruct run-id test-id status)) +;; (mt:process-triggers dbstruct run-id test-id state status))) ;; state is the priority rollup of all states ;; status is the priority rollup of all completed statesfu ;; ;; if test-name is an integer work off that instead of test-name test-path ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test - (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) - (testdat (if (number? test-name) + (let* ((testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id (db:get-test-info dbstruct run-id test-name item-path))) (test-id (db:test-get-id testdat)) (test-name (if (number? test-name) (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (db:test-get-id tl-testdat))) - (sqlite3:with-transaction - db - (lambda () - (db:test-set-state-status-by-id dbstruct 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 db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test - (running (length (filter (lambda (x) - (member (dbr:counts-state x) *common:running-states*)) - state-status-counts))) - (bad-not-started (length (filter (lambda (x) - (and (equal? (dbr:counts-state x) "NOT_STARTED") - (not (member (dbr:counts-status x) - *common:not-started-ok-statuses*)))) - state-status-counts))) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (cons state (map dbr:counts-state state-status-counts))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort ;; worst -> best - (delete-duplicates - (cons status (map dbr:counts-status state-status-counts))) - *common:std-statuses* >)) - (newstate (if (> running 0) - "RUNNING" - (if (> bad-not-started 0) - "COMPLETED" - (car all-curr-states)))) - (newstatus (if (> bad-not-started 0) - "CHECK" - (car all-curr-statuses)))) - ;; (print "Setting toplevel to: " newstate "/" newstatus) - (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f))))))) - -(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items) - -;; call with state = #f to roll up with out accounting for state/status of this item -;; -;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) -;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update -;; (let* ((dbdat (db:get-db dbstruct run-id)) -;; (toptestdat (db:get-test-info dbstruct run-id test-name item-path)) -;; (currtopstate (db:test-get-state toptestdat)) -;; (currtopstatus (db:test-get-status toptestdat)) -;; (nextss (common:apply-state-status currtopstate currtopstatus state status)) -;; (newtopstate (car nextss)) ;; #f or a symbol -;; (newtopstatus (cdr nextss))) ;; #f or a symbol -;; (if (not newtopstate) ;; need to calculate it -;; -;; ;; We rely on the toplevel to track status as state varies. I.e. preserve an ABORT -;; -;; -;; ;; (db (db:dbdat-get-db dbdat))) -;; (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) -;; (db:top-test-set-per-pf-counts dbstruct run-id test-name)))) -;; -;; ;; (case (string->symbol status) -;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) -;; -;; ;; (if (or (not state) -;; ;; (not (equal? item-path ""))) -;; ;; ;; just do a rollup -;; ;; (begin -;; ;; (db:top-test-set-per-pf-counts dbdat run-id test-name) -;; ;; #f) -;; ;; (begin -;; ;; ;; NOTE: No else clause needed for this case -;; ;; (case (string->symbol status) -;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) -;; ;; #f) -;; ;; ))) - -(define (db:get-all-state-status-counts-for-test db run-id test-name item-path) - (sqlite3:map-row - (lambda (state status count) - (make-dbr:counts state: state status: status count: count)) - db - "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" - run-id test-name item-path)) - - -(define (db:get-all-item-states db run-id test-name) - (sqlite3:map-row - (lambda (a) a) - db - "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" - run-id test-name)) - -(define (db:get-all-item-statuses db run-id test-name) - (sqlite3:map-row - (lambda (a) a) - db - "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" - run-id test-name)) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call dbstruct 'set-test-start-time (list test-id))) + (mutex-lock! *db-transaction-mutex*) + (db:with-db + dbstruct #f #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) + (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)) ;; item-path is used to exclude current state/status of THIS test + (running (length (filter (lambda (x) + (member (dbr:counts-state x) *common:running-states*)) + state-status-counts))) + (bad-not-started (length (filter (lambda (x) + (and (equal? (dbr:counts-state x) "NOT_STARTED") + (not (member (dbr:counts-status x) + *common:not-started-ok-statuses*)))) + state-status-counts))) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (cons state (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (cons status (map dbr:counts-status state-status-counts))) + *common:std-statuses* >)) + (newstate (if (> running 0) + "RUNNING" + (if (> bad-not-started 0) + "COMPLETED" + (car all-curr-states)))) + (newstatus (if (> bad-not-started 0) + "CHECK" + (car all-curr-statuses)))) + ;; NB// Pass the db so it is part of the transaction + (db:test-set-state-status db run-id tl-test-id newstate newstatus #f))))))) + (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))))) + +(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" + run-id test-name item-path)))) + +;; (define (db:get-all-item-states db run-id test-name) +;; (sqlite3:map-row +;; (lambda (a) a) +;; db +;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" +;; run-id test-name)) +;; +;; (define (db:get-all-item-statuses db run-id test-name) +;; (sqlite3:map-row +;; (lambda (a) a) +;; db +;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" +;; run-id test-name)) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id @@ -3317,11 +3318,11 @@ '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);") '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") - ;; stuff for roll-up-pass-fail-counts + ;; stuff for set-state-status-and-roll-up-items '(update-pass-fail-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id @@ -3425,11 +3426,11 @@ (let ((q (alist-ref qry-name db:queries))) (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail - ;; db:roll-up-pass-fail-counts ;; WHY NOT!? + ;; db:set-state-status-and-roll-up-items ;; WHY NOT!? login immediate flush sync set-verbosity @@ -3446,38 +3447,50 @@ (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call dbdat stmtname params) +(define (db:general-call dbstruct stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) - #t)) + (db:with-db + dbstruct #f #f + (lambda (db) + (apply sqlite3:execute db query params) + #t)))) ;; get a summary of state and status counts to calculate a rollup ;; -;; NOTE: takes a db, not a dbstruct -;; -(define (db:get-state-status-summary db run-id testname) +(define (db:get-state-status-summary dbstruct run-id testname) (let ((res '())) - (sqlite3:for-each-row - (lambda (state status count) - (set! res (cons (vector state status count) res))) - db - "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" - run-id testname) - res)) + (db:with-db + dbstruct #f #f + (sqlite3:for-each-row + (lambda (state status count) + (set! res (cons (vector state status count) res))) + db + "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" + run-id testname) + res))) + +(define (db:get-latest-host-load dbstruct raw-hostname) + (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) + (res (cons -1 0))) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (cpuload update-time) (set! res (cons cpuload update-time))) + db + "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" + hostname))) res )) (define (db:set-top-level-from-items dbstruct run-id testname) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (summ (db:get-state-status-summary db run-id testname)) + (let* ((summ (db:get-state-status-summary dbstruct run-id testname)) (find (lambda (state status) (if (null? summ) #f (let loop ((hed (car summ)) (tal (cdr summ))) @@ -3502,32 +3515,35 @@ ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; (define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (keys (db:get-keys dbstruct)) + (let* ((keys (db:get-keys dbstruct)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . b) + (set! keyvals (cons a b))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id))) (if (not keyvals) '() (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + (db:with-db + dbstruct #f #f + (lambda (db) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))))) ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null @@ -3609,10 +3625,30 @@ res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== + +;; returns a hash table of tags to tests +;; +(define (db:get-tests-tags dbstruct) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((res (make-hash-table))) + (sqlite3:for-each-row + (lambda (testname tags-in) + (let ((tags (string-split tags-in ","))) + (for-each + (lambda (tag) + (hash-table-set! res tag + (delete-duplicates + (cons testname (hash-table-ref/default res tag '()))))) + tags))) + db + "SELECT testname,tags FROM test_meta") + res)))) ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (db:with-db @@ -3796,11 +3832,11 @@ (define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) - (dbdat (db:get-db dbstruct #f)) + (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist ADDED diff-report.scm Index: diff-report.scm ================================================================== --- /dev/null +++ diff-report.scm @@ -0,0 +1,279 @@ +;; #!/bin/bash + +;; #;; rmt:get-tests-for-run + + +;; #;; (let* ((dbstruct (db:get-db + + +;; #;; (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) + +;; #;; (rmt:get-test-info-by-id run-id test-id) +;; #;; (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) + +;; megatest -repl << EOF + +;; TODO:dashboard not on homehost message exit + +(use matchable) +(use ducttape-lib) +(define css "") + +(use matchable) +(define (tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (status-compare3 status1 status2) + (let* + ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((not mem2) 1) + ((= (length mem1) (length mem2)) 0) + ((> (length mem1) (length mem2)) 1) + (else -1)))) + + +(define (xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) + (let* ((src-hash (tests-mindat->hash src-tests-mindat)) + (dest-hash (tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (let ((res + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key (list #f #f #f))) ;; (list test-id state status) + (dest-test-id (list-ref dest-value 0)) + (dest-state (list-ref dest-value 1)) + (dest-status (list-ref dest-value 2)) + + (src-value (hash-table-ref/default src-hash key (list #f #f #f))) ;; (list test-id state status) + (src-test-id (list-ref src-value 0)) + (src-state (list-ref src-value 1)) + (src-status (list-ref src-value 2)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value) + ((not dest-complete) + (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE") src-value dest-value) + ((not src-complete) + (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE") src-value dest-value) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value)) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status) src-value dest-value)) + (else + (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status) src-value dest-value))))) + (list test-name item-path xor-new-item))) + all-keys))) + + (if hide-clean + (filter + (lambda (item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) + +(define (run-name->run-id runname) + (if (number? runname) + runname + (let* ((qry-res (rmt:get-runs runname 1 0 '()))) + (if (eq? 2 (vector-length qry-res)) + (vector-ref (car (vector-ref qry-res 1)) 1) + #f)))) + +(define (run-name->tests-mindat runname) + (let* ((run-id (run-name->run-id runname)) + (testpatt "%/%") +;; (states '("COMPLETED" "INCOMPLETE")) + ;; (statuses '("PASS" "FAIL" "ABORT" "SKIP")) + (states '()) + (statuses '()) + (offset #f) + (limit #f) + (not-in #t) + (sort-by #f) + (sort-order #f) + (qryvals "id,testname,item_path,state,status") + (qryvals "id,testname,item_path,state,status") + (last-update 0) + (mode #f) + ) + (map + ;; (lambda (row) + ;; (match row + ;; ((#(id test-name item-path state status) + ;; (list test-name item-path (list id state status)))) + ;; (else #f))) + (lambda (row) + (let* ((id (vector-ref row 0)) + (test-name (vector-ref row 1)) + (item-path (vector-ref row 2)) + (state (vector-ref row 3)) + (status (vector-ref row 4))) + (list test-name item-path (list id state status)))) + + (rmt:get-tests-for-run run-id + testpatt states statuses + offset limit + not-in sort-by sort-order + qryvals + last-update + mode)))) + + +(define (diff-runs run1 run2) + (let* ((src-tests-mindat (run-name->tests-mindat run1)) + (dest-tests-mindat (run-name->tests-mindat run2))) + (xor-tests-mindat src-tests-mindat dest-tests-mindat)));; #!key (hide-c + + +(define (rundiff-find-by-state run-diff state) + (filter + (lambda (x) + (equal? (list-ref (caddr x) 1) state)) + run-diff)) + + +(define (summarize-run-diff run-diff) + (let* ((diff-states (list "CLEAN" "DIRTY-BETTER" "DIRTY-WORSE" "BOTH-BAD" "DIFF-MISSING" "DIFF-NEW" ))) + (map + (lambda (state) + (list state + (length (rundiff-find-by-state run-diff state)))) + diff-states))) + +(define (stml->string in-stml) + (with-output-to-string + (lambda () + (s:output-new + (current-output-port) + in-stml)))) + +(define (test-state-status->diff-report-cell state status) + (s:td status)) + +(define (diff-state-status->diff-report-cell state status) + (s:td state 'bgcolor "#33ff33")) + +(define (run-diff->diff-report src-runname dest-runname run-diff) + (let* ((test-count (length run-diff)) + (summary-table + (apply s:table 'cellspacing "0" 'border "1" + (s:tr + (s:th "Diff type") + (s:th "% share") + (s:th "Count")) + + (map + (lambda (state-count) + (s:tr + (s:td (car state-count)) + (s:td (* 100 (/ (cadr state-count) test-count))) + (s:td (cadr state-count)))) + (summarize-run-diff run-diff)))) + (main-table + (apply s:table 'cellspacing "0" 'border "1" + (s:tr + (s:th "Test name") + (s:th "Item Path") + (s:th (conc "Source=" src-runname)) + (s:th (conc "Dest=" dest-runname)) + (s:th "Diff")) + (map + (lambda (run-diff-item) + (match run-diff-item + ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) + (s:tr + (s:td test-name) + (s:td item-path) + (test-state-status->diff-report-cell src-state src-status) + (test-state-status->diff-report-cell dest-state dest-status) + (diff-state-status->diff-report-cell diff-state diff-status))) + (else ""))) + (filter (lambda (run-diff-item) + (match run-diff-item + ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) + (not (equal? diff-state "CLEAN"))) + (else #f))) + run-diff))))) + (stml->string (s:body + summary-table + main-table)))) + + + + + + +(let* ((src-runname "all57") + (dest-runname "all60") + (to "bjbarcla") + (subj (conc "[MEGATEST DIFF] "src-runname" vs. "dest-runname)) + (run-diff (diff-runs src-runname dest-runname)) + (diff-summary (summarize-run-diff run-diff)) + (html-report (run-diff->diff-report src-runname dest-runname run-diff))) + ;;(pretty-print run-diff) + ;;(pretty-print diff-summary) + + (sendmail to subj html-report use_html: #t) + ;;(print html-report) + ) + + +;; (match de +;; ((test-name test-path ( test-id "BOTH-BAD" test-status)) test-path) +;; (else #f)) Index: docs/inprogress/megatest-architecture-proposed-2.fig ================================================================== --- docs/inprogress/megatest-architecture-proposed-2.fig +++ docs/inprogress/megatest-architecture-proposed-2.fig @@ -13,35 +13,140 @@ 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 675 1575 675 2175 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 1575 1500 1575 2175 -6 -6 1875 825 2850 1875 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 1950 1050 1950 1650 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 2850 975 2850 1650 --6 -6 3225 450 4200 1500 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 3300 675 3300 1275 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4200 600 4200 1275 --6 -6 3075 2925 4050 3975 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 3150 3150 3150 3750 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4050 3075 4050 3750 --6 -6 7275 4050 12825 9675 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +6 6150 2700 7500 3225 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700 +4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001 +-6 +6 2025 675 3000 1725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2550 825 450 150 2550 825 3000 975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2549 1502 450 150 2549 1502 2999 1652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2100 900 2100 1500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3000 825 3000 1500 +-6 +6 675 7275 1650 8325 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1200 7425 450 150 1200 7425 1650 7575 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1199 8102 450 150 1199 8102 1649 8252 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 750 7500 750 8100 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1650 7425 1650 8100 +-6 +6 3675 6675 4650 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4200 6825 450 150 4200 6825 4650 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4199 7502 450 150 4199 7502 4649 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3750 6900 3750 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4650 6825 4650 7500 +-6 +6 900 3825 2175 4425 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2175 4425 2175 3825 900 3825 900 4425 2175 4425 +4 0 0 50 -1 0 12 0.0000 4 150 720 1050 4125 server-1\001 +-6 +6 150 5475 1500 6000 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 150 5475 1500 5475 1500 6000 150 6000 150 5475 +4 0 0 50 -1 0 12 0.0000 4 180 870 300 5700 run1/test1\001 +-6 +6 1725 5400 3075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1725 5400 3075 5400 3075 5925 1725 5925 1725 5400 +4 0 0 50 -1 0 12 0.0000 4 180 870 1800 5625 run1/test2\001 +-6 +6 5400 5100 6375 6975 +6 5400 5100 6375 6150 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5925 5250 450 150 5925 5250 6375 5400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5924 5927 450 150 5924 5927 6374 6077 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5475 5325 5475 5925 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6375 5250 6375 5925 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 885 5475 6375 postgresql\001 +4 0 0 50 -1 0 12 0.0000 4 195 555 5475 6630 sqlite3\001 +4 0 0 50 -1 0 12 0.0000 4 195 510 5475 6885 mysql\001 +-6 +6 4050 675 6000 2175 +6 4125 900 5100 1950 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4650 1050 450 150 4650 1050 5100 1200 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4649 1727 450 150 4649 1727 5099 1877 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 1125 4200 1725 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5100 1050 5100 1725 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 1905 4050 2100 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 4200 825 monitor.db\001 +-6 6 8175 4125 8400 8625 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 @@ -248,165 +353,14 @@ 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 -6 -# Dimension line: 1-1/16 in -6 7875 9375 9150 9675 -# main dimension line -2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 7875 9525 9150 9525 -# text box -2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 - 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375 -# tick -2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 - 7875 9375 7875 9675 -# tick -2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 - 9150 9375 9150 9675 -4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001 --6 -# Dimension line: 1-11/16 in -6 7425 4125 7725 6150 -# main dimension line -2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 7575 4125 7575 6150 -# text box -2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 - 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617 -# tick -2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 - 7425 6150 7725 6150 -# tick -2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 - 7425 4125 7725 4125 -4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001 --6 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 -2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 -4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001 -4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001 --6 -6 14100 150 19950 6075 -6 14850 1350 15825 2400 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 14925 1575 14925 2175 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 15825 1500 15825 2175 --6 -2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 - 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 -2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 16050 3375 15525 2400 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 -2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 16350 4050 16350 5325 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 -2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 16725 4050 17850 4800 -2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 17025 3750 18375 4125 -2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 18975 3900 18075 2625 15900 1875 -2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 - 14100 150 19950 150 19950 6075 14100 6075 14100 150 -4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 -4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 -4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 -4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 -4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 --6 -6 14850 7425 15825 8475 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 14925 7650 14925 8250 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 15825 7575 15825 8250 --6 -6 17775 6675 18750 7725 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 17850 6900 17850 7500 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 18750 6825 18750 7500 --6 -6 4875 6075 5850 7125 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5400 6225 450 150 5400 6225 5850 6375 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5399 6902 450 150 5399 6902 5849 7052 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4950 6300 4950 6900 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 5850 6225 5850 6900 --6 -6 5400 7425 7350 8925 -6 5475 7650 6450 8700 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 7800 450 150 6000 7800 6450 7950 -1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5999 8477 450 150 5999 8477 6449 8627 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 5550 7875 5550 8475 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 6450 7800 6450 8475 --6 -4 0 0 50 -1 0 12 0.0000 4 195 1905 5400 8850 pointers to the servers\001 -4 0 0 50 -1 0 12 0.0000 4 150 930 5550 7575 monitor.db\001 --6 -6 6150 2700 7500 3225 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700 -4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001 --6 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 1725 5025 1275 2475 -2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 - 5550 4500 5550 225 225 225 225 4500 5550 4500 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 1875 7725 1875 5775 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725 -2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 - 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725 -2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 3675 7725 2175 5775 -2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 - 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700 -2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 - 0 0 1.00 60.00 120.00 - 0 0 1.00 60.00 120.00 - 6600 3300 2925 5025 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1500 3825 1200 2550 2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 0 0 1.00 60.00 120.00 0 0 1.00 60.00 120.00 @@ -448,32 +402,55 @@ 2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 3975 11250 4575 12075 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 3300 3000 3300 225 225 225 225 3000 3300 3000 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3675 7275 1800 7875 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2475 8775 2475 6675 225 6675 225 8775 2475 8775 +2 4 0 1 5 7 50 -1 -1 0.000 0 0 7 0 0 5 + 75 6525 75 9000 4950 9000 4950 6525 75 6525 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 2400 4200 5400 5400 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1135 5476 1285 4426 2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 0 0 1.00 60.00 120.00 0 0 1.00 60.00 120.00 - 2175 5025 3075 3750 + 2321 5402 1796 4427 2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 0 0 1.00 60.00 120.00 0 0 1.00 60.00 120.00 - 4800 6375 2850 5550 + 6000 3075 1725 2100 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 0 0 1.00 60.00 120.00 0 0 1.00 60.00 120.00 - 3600 2475 7425 6525 -4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001 -4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001 -4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001 -4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001 -4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001 -4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001 -4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001 -4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001 -4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001 -4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001 + 1725 2250 7275 4425 +2 4 0 1 5 7 50 -1 -1 0.000 0 0 7 0 0 5 + 6300 525 6300 2175 3825 2175 3825 525 6300 525 +2 1 0 1 5 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3675 225 6000 2400 +2 1 0 1 5 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3825 2475 5775 300 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +3 2 0 1 0 7 50 -1 -1 3.000 0 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4125 6675 3675 5250 2325 4425 + 0.000 -1.000 0.000 4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 @@ -481,10 +458,17 @@ 4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 4 0 0 50 -1 0 12 0.0000 4 195 2205 450 525 /tmp//??? /.db/*.db\001 -4 0 0 50 -1 0 12 0.0000 4 195 1065 4800 7350 megatest.db\001 -4 0 0 50 -1 0 12 0.0000 4 150 1785 600 8775 Possible Future state\001 4 0 0 50 -1 0 12 0.0000 4 150 1110 8025 450 CHANGES:\001 4 0 0 50 -1 0 12 0.0000 4 195 2145 8025 705 1. http -> rcp or nanomsg\001 4 0 0 50 -1 0 12 0.0000 4 195 3330 8025 960 2. cache db moves from inmem to /tmp\001 +4 0 0 50 -1 0 12 0.0000 4 195 1410 2025 1875 megatest_ref.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1785 3675 375 Possible Future state\001 +4 0 0 50 -1 0 12 0.0000 4 195 1290 450 6900 Read-only user\001 +4 0 0 50 -1 0 12 0.0000 4 195 1755 675 8475 /tmp/.../megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 3750 8025 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 1650 2925 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1350 5100 http\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 750 2475 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 945 9675 3750 Dashboard\001 ADDED ducttape/MANIFEST Index: ducttape/MANIFEST ================================================================== --- /dev/null +++ ducttape/MANIFEST @@ -0,0 +1,10 @@ +MANIFEST +Makefile +ducttape-lib.scm +ducttape-lib.setup +mimetypes.scm +sample_ducttape.scm +test_ducttape.scm +test_example.scm +useargs-example.scm +workweekdate.scm ADDED ducttape/Makefile Index: ducttape/Makefile ================================================================== --- /dev/null +++ ducttape/Makefile @@ -0,0 +1,35 @@ +SHELL=/bin/tcsh -f + +help: + @echo "" + @echo "make targets:" + @echo "=============" + @echo "install - build and install general_lib egg as icfadm" + @echo "test - run unit tests on ducttape-lib.scm (tests code, not egg)" + @echo "eggs-info - show chicken-install commands to get eggs upon which ducttape-lib depends" + @echo "test_example - compile an example scm against installed general_lib egg" + @echo "clean - remove binaries and other build artifacts" + @echo "" + +clean: + rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o + +install: + chicken-install + +test: + chicken-install -no-install + csc test_ducttape.scm + + ./test_ducttape + if (-e foo) rm -f foo + +test_example: + @csc test_example.scm + @./test_example + @rm test_example + +eggs-info: + @echo chicken-install ansi-escape-sequences + @echo chicken-install slice + @echo chicken-install rfc3339 ADDED ducttape/ducttape-lib.meta Index: ducttape/ducttape-lib.meta ================================================================== --- /dev/null +++ ducttape/ducttape-lib.meta @@ -0,0 +1,13 @@ +;;; ducttape-lib.meta -*- Hen -*- + +((egg "ducttape-lib.egg") + (synopsis "Miscellaneous tool and standard print routines.") + (category env) + (author "Brandon Barclay") + (doc-from-wiki) + (license "GPL-2") + ;; srfi-69, posix, srfi-18 + (depends regex) + (test-depends test) + ; suspicious - (files "ducttape-lib") + ) ADDED ducttape/ducttape-lib.scm Index: ducttape/ducttape-lib.scm ================================================================== --- /dev/null +++ ducttape/ducttape-lib.scm @@ -0,0 +1,801 @@ +(module ducttape-lib + ( + runs-ok + ducttape-debug-level + ducttape-debug-regex-filter + ducttape-silent-mode + ducttape-quiet-mode + ducttape-log-file + ducttape-color-mode + iputs-preamble + script-name + idbg + ierr + iwarn + inote + iputs + re-match? + ; launch-repl + keyword-skim + skim-cmdline-opts-noarg-by-regex + skim-cmdline-opts-withargs-by-regex + concat-lists + process-command-line + ducttape-append-logfile + ducttape-activate-logfile + isys + do-or-die + counter-maker + dir-is-writable? + mktemp + get-tmpdir + sendmail + find-exe + + zeropad + string-leftpad + string-rightpad + seconds->isodate + seconds->wwdate + seconds->wwdate-values + isodate->seconds + isodate->wwdate + wwdate->seconds + wwdate->isodate + current-wwdate + current-isodate + + ) + + (import scheme chicken extras ports data-structures ) + (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339 scsh-process directory-utils uuid-lib filepath srfi-19 ) ; linenoise + (include "mimetypes.scm") ; provides ext->mimetype + (include "workweekdate.scm") + (define ducttape-lib-version 1.00) + (define (toplevel-command sym proc) (lambda () #f)) +;;;; utility procedures + + ;; begin credit: megatest's process.scm + (define (port->list fh ) + (if (eof-object? fh) #f + (let loop ((curr (read-line fh)) + (result '())) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + result)))) + + (define (conservative-read port) + (let loop ((res "")) + (if (not (eof-object? (peek-char port))) + (loop (conc res (read-char port))) + res))) + ;; end credit: megatest's process.scm + + (define (counter-maker) + (let ((acc 0)) + (lambda ( #!optional (increment 1) ) + (set! acc (+ increment acc)) + acc))) + + (define (port->string port #!optional ) ; todo - add newline + (let ((linelist (port->list port))) + (if linelist + (string-join linelist "\n") + ""))) + + + (define (outport->foreach outport foreach-thunk) + (let loop ((line (foreach-thunk))) + (if line + (begin + (write-line line outport) + (loop (foreach-thunk)) + ) + (begin + ;;http://bugs.call-cc.org/ticket/766 + ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like + ;;Error: (process-wait) waiting for child process failed - No child processes: 10872 + (close-output-port outport) + #f)))) + + ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining. + (define (my-alist-ref key alist) + (let ((res (assoc key alist))) + (if res (cdr res) #f))) + + (define (keyword-skim-alist args alist) + (let loop ((result-alist '()) (result-args args) (rest-alist alist)) + (cond + ((null? rest-alist) (values result-alist result-args)) + (else + (let ((keyword (caar rest-alist)) + (defval (cdar rest-alist))) + (let-values (((kwval result-args2) + (keyword-skim + keyword + defval + result-args))) + (loop + (cons (cons keyword kwval) result-alist) + result-args2 + (cdr rest-alist)))))))) + + (define (isys command . rest-args) + (let-values + (((opt-alist args) + (keyword-skim-alist + rest-args + '( ( foreach-stdout-thunk: . #f ) + ( foreach-stdin-thunk: . #f ) + ( stdin-proc: . #f ) ) ))) + (let* ((foreach-stdout-thunk + (my-alist-ref foreach-stdout-thunk: opt-alist)) + (foreach-stdin-thunk + (my-alist-ref foreach-stdin-thunk: opt-alist)) + (stdin-proc + (if foreach-stdin-thunk + (lambda (port) + (outport->foreach port foreach-stdin-thunk)) + (my-alist-ref stdin-proc: opt-alist)))) + + ;; TODO: support command is list. + + (let-values (((stdout stdin pid stderr) + (if (null? args) + (process* command) + (process* command args)))) + + ;(if foreach-stdin-thunk + ; (set! stdin-proc + ; (lambda (port) + ; (outport->foreach port foreach-stdin-thunk)))) + + (if stdin-proc + (stdin-proc stdin)) + + (let ((stdout-res + (if foreach-stdout-thunk ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory + (begin + (port-for-each foreach-stdout-thunk (lambda () (read-line stdout))) + "foreach-stdout-thunk ate stdout" + ) + (if stdin-proc + "foreach-stdin-thunk/stdin-proc blocks stdout" + (port->string stdout)))) + (stderr-res + (if stdin-proc + "foreach-stdin-thunk/stdin-proc blocks stdout" + (port->string stderr)))) + + ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close. don't close them again. (so sad - we lost stdout and stderr contents when we write to stdin) + ;; see - http://bugs.call-cc.org/ticket/766 + (if (not stdin-proc) + (close-input-port stdout) + (close-input-port stderr)) + + (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) + (values exitstatus stdout-res stderr-res))))))) + + (define (do-or-die command #!key nodie (foreach-stdout #f) (stdin-proc #f)) + (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc ))) + (if (equal? 0 exit-code) + stdout-str + (begin + (ierr (conc "Command > " command " " "< failed with " exit-code " because: \n" stderr-str) ) + (if nodie #f (exit exit-code)))))) + + + + + ;; this is broken. one day i will fix it and thus understand run/collecting... don't use isys-broken. + (define (isys-broken command-list) + + (let-values ( ( (rv outport errport) (run/collecting (1 2) ("ls" "-l") ) ) ) + (print "rv is " rv) + (print "op is " outport) + (print "ep is " errport) + (values rv (port->string outport) (port->string errport)))) + + + + ;; runs-ok: evaluate expression while suppressing exceptions. + ; on caught exception, returns #f + ; otherwise, returns expression value + (define (runs-ok thunk) + (handle-exceptions exn #f (begin (thunk) #t))) + + ;; concat-lists: result list = lista + listb + (define (concat-lists lista listb) ;; ok, I just reimplemented append... + (foldr cons listb lista)) + + +;;; setup general_lib env var parameters + + ;; show warning/note/error/debug prefixes using ansi colors + (define ducttape-color-mode + (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE"))) + + ;; if defined, has number value. if number value > 0, show debug messages + ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack + (define ducttape-debug-level + (make-parameter + (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) ) + (if raw-debug-level + (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) + (if (integer? num-debug-level) + (begin + (let ((new-num-debug-level (- num-debug-level 1))) + (if (> new-num-debug-level 0) ;; decrement + (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level)) + (unsetenv "DUCTTAPE_DEBUG_LEVEL"))) + num-debug-level) ; it was set and > 0, mode is value + (begin + (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it + #f))) ; value was invalid, mode is f + #f)))) ; var not set, mode is f + + + (define ducttape-debug-mode (if (ducttape-debug-level) #t #f)) + + ;; ducttape-debug-regex-filter suppresses non-matching debug messages + (define ducttape-debug-regex-filter + (make-parameter + (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN"))) + (if raw-debug-pattern + raw-debug-pattern + ".")))) + + ;; silent mode suppresses Note and Warning type messages + (define ducttape-silent-mode + (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE"))) + + ;; quiet mode suppresses Note type messages + (define ducttape-quiet-mode + (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE"))) + + ;; if log file is defined, warning/note/error/debug messages are appended + ;; to named logfile. + (define ducttape-log-file + (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE"))) + + + + + + +;;; standard messages printing implementation + + ; get the name of the current script/binary being run + (define (script-name) + (car (reverse (string-split (car (argv)) "/")))) + + (define (ducttape-timestamp) + (rfc3339->string (time->rfc3339 (seconds->local-time)))) + + + (define (iputs-preamble msg-type #!optional (suppress-color #f)) + (let ((do-color (and + (not suppress-color) + (ducttape-color-mode) + (terminal-port? (current-error-port))))) + (case msg-type + ((note) + (if do-color + (set-text (list 'fg-green 'bg-black 'bold) "Note:") + "Note:" + )) + ((warn) + (if do-color + (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:") + "Warning:" + )) + ((err) + (if do-color + (set-text (list 'fg-red 'bg-black 'bold) "Error:") + "Error:" + )) + ((dbg) + (if do-color + (set-text (list 'fg-blue 'bg-magenta) "Debug:") + "Debug:" + ))))) + + (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f)) + (let + ((txt + (string-join + (list + (ducttape-timestamp) + (script-name) + (if suppress-preamble + message + (string-join (list (iputs-preamble msg-type #t) message) " "))) + " | "))) + + (if (ducttape-log-file) + (runs-ok + (call-with-output-file (ducttape-log-file) + (lambda (output-port) + (format output-port "~A ~%" txt) + ) + #:append)) + #t))) + + (define (ducttape-activate-logfile #!optional (logfile #f)) + ;; from python ducttape-lib.py + ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') ) + (let ((pid (number->string (current-process-id))) + (ppid (number->string (parent-process-id))) + (argv + (string-join + (map + (lambda (x) + (string-join (list "\"" x "\"") "" )) + (argv)) + " ")) + (pwd (or (get-environment-variable "PWD") "nopwd")) + (user (or (get-environment-variable "USER") "nouser")) + (host (or (get-environment-variable "HOST") "nohost"))) + (if logfile + (begin + (ducttape-log-file logfile) + (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) + (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t))) + + ;; immediately activate logfile (will be noop if logfile disabled) + (ducttape-activate-logfile) + + ;; log exit code + (define (set-exit-handler) + (let ((orig-exit-handler (exit-handler))) + (exit-handler + (lambda (exitcode) + (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t) + (orig-exit-handler exitcode))))) + (set-exit-handler) + + ;; TODO: hook exception handler so we can log exception before we sign off. + + (define (idbg first-message . rest-args) + (let* ((debug-level-threshold + (if (> (length rest-args) 0) (car rest-args) 1)) + (message-list + (if (> (length rest-args) 1) + (cons first-message (cdr rest-args)) + (list first-message)) ) + (message (apply conc + (map ->string message-list)))) + + (ducttape-append-logfile 'dbg message) + (if (ducttape-debug-level) + (if (<= debug-level-threshold (ducttape-debug-level)) + (if (string-search (ducttape-debug-regex-filter) message) + (begin + (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name)))))))) + + (define (ierr message-first . message-rest) + (let* ((message + (apply conc + (map ->string (cons message-first message-rest))))) + (ducttape-append-logfile 'err message) + (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name)))) + + (define (iwarn message-first . message-rest) + (let* ((message + (apply conc + (map ->string (cons message-first message-rest))))) + (ducttape-append-logfile 'warn message) + (if (not (ducttape-silent-mode)) + (begin + (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name)))))) + + (define (inote message-first . message-rest) + (let* ((message + (apply conc + (map ->string (cons message-first message-rest))))) + (ducttape-append-logfile 'note message) + (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode))) + (begin + (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name)))))) + + + (define (iputs kind message #!optional (debug-level-threshold 1)) + (cond + ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message)) + ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message)) + ((member kind + (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/")) + (iwarn message)) + ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/")) + (idbg message debug-level-threshold)))) + + (define (mkdir-recursive path-so-far hier-list-to-create) + (if (null? hier-list-to-create) + path-so-far + (let* ((next-hier-item (car hier-list-to-create)) + (rest-hier-items (cdr hier-list-to-create)) + (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item)))) + (if (runs-ok (lambda () (create-directory path-to-mkdir))) + (mkdir-recursive path-to-mkdir rest-hier-items) + #f)))) + + ; ::mkdir-if-not-exists:: + ; make a dir recursively if it does not + ; already exist. + ; on success - returns path + ; on fail - returns #f + (define (mkdirp-if-not-exists the-dir) + (let ( (path-list (string-split the-dir "/"))) + (mkdir-recursive "/" path-list))) + + ; ::mkdir-if-not-exists:: + ; make a dir recursively if it does not + ; already exist. + ; on success - returns path + ; on fail - returns #f + + + (define (mkdirp-if-not-exists the-dir) + (let ( (path-list (string-split the-dir "/"))) + (mkdir-recursive "/" path-list))) + + (define (dir-is-writable? the-dir) + (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile")))) + (and + (file-exists? the-dir) + (cond + ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo"))))) + (begin + (runs-ok (lambda () (delete-file dummy-file) )) + the-dir)) + (else #f))))) + + + (define (get-tmpdir ) + (let* ((tmproot + (dir-is-writable? + (or + (get-environment-variable "TMPDIR") + "/tmp"))) + + (user + (or + (get-environment-variable "USER") + "USER_Envvar_not_set")) + (tmppath + (string-concatenate + (list tmproot "/env21-general-" user )))) + + (dir-is-writable? + (mkdirp-if-not-exists + tmppath)))) + + (define (mktemp + #!optional + (prefix "general_lib_tmpfile") + (dir #f)) + (let-values + (((fd path) + (file-mkstemp + (conc + (if dir dir (get-tmpdir)) + "/" prefix ".XXXXXX")))) + (close-output-port (open-output-file* fd)) + path)) + + + + ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment + ;; write send-email using: + ;; - isys-foreach-stdin-line + ;; - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment + (define (sendmail to_addr subject body + #!key + (from_addr "admin") + cc_addr + bcc_addr + more-headers + use_html + (attach-files-list '())) + + (define (sendmail-proc sendmail-port) + (define (wl line-str) + (write-line line-str sendmail-port)) + + (define (get-uuid) + (string-upcase (uuid->string (uuid-generate)))) + + (let ((mailpart-uuid (get-uuid)) + (mailpart-body-uuid (get-uuid))) + + (define (boundary) + (wl (conc "--" mailpart-uuid))) + + (define (body-boundary) + (wl (conc "--" mailpart-body-uuid))) + + + (define (email-mime-header) + (wl (conc "From: " from_addr)) + (wl (conc "To: " to_addr)) + (if cc_addr + (wl (conc "Cc: " cc_addr))) + (if bcc_addr + (wl (conc "Bcc: " bcc_addr))) + (if more-headers + (wl more-headers)) + (wl (conc "Subject: " subject)) + (wl "MIME-Version: 1.0") + (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\"")) + (wl "") + (boundary) + (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\"")) + (wl "") + ) + + (define (email-text-body) + (body-boundary) + (wl "Content-Type: text/plain; charset=ISO-8859-1") + (wl "Content-Disposition: inline") + (wl "") + (wl body) + (body-boundary)) + + (define (email-html-body) + (body-boundary) + (wl "Content-Type: text/plain; charset=ISO-8859-1") + (wl "") + (wl "You need to enable HTML option for email") + (body-boundary) + (wl "Content-Type: text/html; charset=ISO-8859-1") + (wl "Content-Disposition: inline") + (wl "") + (wl body) + (body-boundary)) + + (define (attach-file file) + (let* ((filename + (filepath:take-file-name file)) + (ext-with-dot + (filepath:take-extension file)) + (ext (string-take-right + ext-with-dot + (- (string-length ext-with-dot) 1))) + (mimetype (ext->mimetype ext)) + (uuencode-command (conc "uuencode " file " " filename))) + (boundary) + (wl (conc "Content-Type: " mimetype "; name=\"" filename "\"")) + (wl "Content-Transfer-Encoding: uuencode") + (wl (conc "Content-Disposition: attachment; filename=\"" filename "\"")) + (wl "") + (do-or-die + uuencode-command + foreach-stdout: + (lambda (line) + (wl line))))) + + ;; send the email + (email-mime-header) + (if use_html + (email-html-body) + (email-text-body)) + (for-each attach-file attach-files-list) + (boundary) + (close-output-port sendmail-port))) + + (do-or-die "/usr/sbin/sendmail -t" + stdin-proc: sendmail-proc)) + + ;; like shell "which" command + (define (find-exe exe) + (let* ((path-items + (string-split + (or + (get-environment-variable "PATH") "") + ":"))) + + (let loop ((rest-path-items path-items)) + (if (null? rest-path-items) + #f + (let* ((this-dir (car rest-path-items)) + (next-rest (cdr rest-path-items)) + (candidate (conc this-dir "/" exe))) + (if (file-execute-access? candidate) + candidate + (loop next-rest))))))) + + + + + ;; (define (launch-repl ) + ;; (use linenoise) + ;; (current-input-port (make-linenoise-port)) + + ;; (let ((histfile (conc (or (get-environment-variable "HOME") ".") "/." (script-name) "-hist"))) + + ;; (set-history-length! 30000) + + ;; (load-history-from-file histfile) + + ;; (let loop ((l (linenoise "> "))) + ;; (cond ((equal? l "bye") + ;; (save-history-to-file histfile) + ;; "Bye!") + ;; ((eof-object? l) + ;; (save-history-to-file histfile) + ;; (exit)) + ;; (else + ;; (display l) + ;; (handle-exceptions exn + ;; ;;(print-call-chain (current-error-port)) + ;; (let ((message ((condition-property-accessor 'exn 'message) exn))) + ;; (print "exn> " message ) + ;; ;;(pp (condition->list exn)) + ;; ;;(exit) + ;; ;;(display "Went wrong") + ;; (newline)) + ;; (print (eval l))))) + ;; (newline) + ;; (history-add l) + ;; (loop (linenoise "> "))))) + + ;; (define (launch-repl2 ) + ;; (use readline) + ;; (use apropos) + ;; (use trace) + ;; ;(import csi) + ;; (current-input-port (make-readline-port (conc (script-name) "> ") "... ")) + ;; ; (install-history-file #f (conc (or (get-environment-variable "HOME") ".") "/." (script-name) "_history")) + ;; (parse-and-bind "set editing-mode emacs") + ;; (install-history-file) + ;; (let loop ((foo #f)) + + ;; (let ((expr (read))) + ;; (cond + ;; ((eof-object? expr) (exit)) + ;; (else + ;; (handle-exceptions exn + ;; ;;(print-call-chain (current-error-port)) + ;; (let ((message ((condition-property-accessor 'exn 'message) exn))) + ;; (print "exn> " message ) + ;; ;;(pp (condition->list exn)) + ;; ;;(exit) + ;; ;;(display "Went wrong") + ;; (newline)) + ;; (print (eval expr)))))) + ;; (loop #f)) + ;; ) + +;;;; process command line options + + ;; get command line switches (have no subsequent arg; eg. [-foo]) + ;; assumes these are switches without arguments + ;; will return list of matches + ;; removes matches from command-line-arguments parameter + (define (skim-cmdline-opts-noarg-by-regex switch-pattern) + (let* ( + (irr (irregex switch-pattern)) + (matches (filter + (lambda (x) + (irregex-match irr x)) + (command-line-arguments))) + (non-matches (filter + (lambda (x) + (not (member x matches))) + (command-line-arguments)))) + + (command-line-arguments non-matches) + matches)) + + (define (keyword-skim keyword default args #!optional (eqpred equal?)) + (let loop ( (kwval default) (args-remaining args) (args-to-return '()) ) + (cond + ((null? args-remaining) + (values + (if (list? kwval) (reverse kwval) kwval) + (reverse args-to-return))) + ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining))) + (if (list? default) + (if (equal? default kwval) + (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return) + (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return)) + (loop (cadr args-remaining) (cddr args-remaining) args-to-return))) + (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return)))))) + + + + ;; get command line switches (have a subsequent arg; eg. [-foo bar]) + ;; assumes these are switches without arguments + ;; will return list of arguments to matches + ;; removes matches from command-line-arguments parameter + + (define (re-match? re str) + (irregex-match re str)) + + (define (skim-cmdline-opts-withargs-by-regex switch-pattern) + (let-values + (((result new-cmdline-args) + (keyword-skim switch-pattern + '() + (command-line-arguments) + re-match? + ))) + (command-line-arguments new-cmdline-args) + result)) + + + + ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile) + ;; - reset parameters; reset DUCTTAPE_* env vars to match user specified intent + ;; - mutate (command-line-arguments) parameter to subtract these recognized and handled switches + ;; * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas. Use (command-line-arguments) + (define (process-command-line) + + ;; --quiet + (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) + (if (not (null? quiet-opts)) + (begin + (setenv "DUCTTAPE_QUIET_MODE" "1") + (ducttape-quiet-mode "1")))) + + ;; --silent + (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent"))) + (if (not (null? silent-opts)) + (begin + (setenv "DUCTTAPE_SILENT_MODE" "1") + (ducttape-silent-mode "1")))) + + ;; -color + (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?"))) + (if (not (null? color-opts)) + (begin + (setenv "DUCTTAPE_COLORIZE" "1") + (ducttape-color-mode "1")))) + + ;; -nocolor + (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?"))) + (if (not (null? nocolor-opts)) + (begin + (unsetenv "DUCTTAPE_COLORIZE" ) + (ducttape-color-mode #f)))) + + ;; -logfile + (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?"))) + (if (not (null? logfile-opts)) + (begin + (ducttape-log-file (car (reverse logfile-opts))) + (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))) + + ;; -d -dd -d# + (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)")) + (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) )) + (if (not (null? debug-opts)) + (begin + (ducttape-debug-level + (let loop ((opts debug-opts) (debuglevel initial-debuglevel)) + (if (null? opts) + debuglevel + (let* + ( (curopt (car opts)) + (restopts (cdr opts)) + (ds (string-match "-(d+)" curopt)) + (dnum (string-match "-d(\\d+)" curopt))) + (cond + (ds (loop restopts (+ debuglevel (string-length (cadr ds))))) + (dnum (loop restopts (string->number (cadr dnum))))))))) + (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level)))))) + + + ;; -dp / --debug-pattern + (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)"))) + (if (not (null? debugpat-opts)) + (begin + (ducttape-debug-regex-filter (string-join debugpat-opts "|")) + (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) + + ;; handle command line immediately; + (process-command-line) + + + ) ; end module ADDED ducttape/ducttape-lib.setup Index: ducttape/ducttape-lib.setup ================================================================== --- /dev/null +++ ducttape/ducttape-lib.setup @@ -0,0 +1,1 @@ +(standard-extension 'ducttape-lib '1.0.0) ADDED ducttape/mimetypes.scm Index: ducttape/mimetypes.scm ================================================================== --- /dev/null +++ ducttape/mimetypes.scm @@ -0,0 +1,782 @@ +;; gathered from macosx: +;; cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm +;; + manual manipulation + +(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset") +("aw" . "application/applixware") +("atom" . "application/atom+xml") +("atomcat" . "application/atomcat+xml") +("atomsvc" . "application/atomsvc+xml") +("ccxml" . "application/ccxml+xml") +("cdmia" . "application/cdmi-capability") +("cdmic" . "application/cdmi-container") +("cdmid" . "application/cdmi-domain") +("cdmio" . "application/cdmi-object") +("cdmiq" . "application/cdmi-queue") +("cu" . "application/cu-seeme") +("davmount" . "application/davmount+xml") +("dbk" . "application/docbook+xml") +("dssc" . "application/dssc+der") +("xdssc" . "application/dssc+xml") +("ecma" . "application/ecmascript") +("emma" . "application/emma+xml") +("epub" . "application/epub+zip") +("exi" . "application/exi") +("pfr" . "application/font-tdpfr") +("gml" . "application/gml+xml") +("gpx" . "application/gpx+xml") +("gxf" . "application/gxf") +("stk" . "application/hyperstudio") +("ink" . "application/inkml+xml") +("ipfix" . "application/ipfix") +("jar" . "application/java-archive") +("ser" . "application/java-serialized-object") +("class" . "application/java-vm") +("js" . "application/javascript") +("json" . "application/json") +("jsonml" . "application/jsonml+json") +("lostxml" . "application/lost+xml") +("hqx" . "application/mac-binhex40") +("cpt" . "application/mac-compactpro") +("mads" . "application/mads+xml") +("mrc" . "application/marc") +("mrcx" . "application/marcxml+xml") +("ma" . "application/mathematica") +("mathml" . "application/mathml+xml") +("mbox" . "application/mbox") +("mscml" . "application/mediaservercontrol+xml") +("metalink" . "application/metalink+xml") +("meta4" . "application/metalink4+xml") +("mets" . "application/mets+xml") +("mods" . "application/mods+xml") +("m21" . "application/mp21") +("mp4s" . "application/mp4") +("doc" . "application/msword") +("mxf" . "application/mxf") +("bin" . "application/octet-stream") +("oda" . "application/oda") +("opf" . "application/oebps-package+xml") +("ogx" . "application/ogg") +("omdoc" . "application/omdoc+xml") +("onetoc" . "application/onenote") +("oxps" . "application/oxps") +("xer" . "application/patch-ops-error+xml") +("pdf" . "application/pdf") +("pgp" . "application/pgp-encrypted") +("asc" . "application/pgp-signature") +("prf" . "application/pics-rules") +("p10" . "application/pkcs10") +("p7m" . "application/pkcs7-mime") +("p7s" . "application/pkcs7-signature") +("p8" . "application/pkcs8") +("ac" . "application/pkix-attr-cert") +("cer" . "application/pkix-cert") +("crl" . "application/pkix-crl") +("pkipath" . "application/pkix-pkipath") +("pki" . "application/pkixcmp") +("pls" . "application/pls+xml") +("ai" . "application/postscript") +("cww" . "application/prs.cww") +("pskcxml" . "application/pskc+xml") +("rdf" . "application/rdf+xml") +("rif" . "application/reginfo+xml") +("rnc" . "application/relax-ng-compact-syntax") +("rl" . "application/resource-lists+xml") +("rld" . "application/resource-lists-diff+xml") +("rs" . "application/rls-services+xml") +("gbr" . "application/rpki-ghostbusters") +("mft" . "application/rpki-manifest") +("roa" . "application/rpki-roa") +("rsd" . "application/rsd+xml") +("rss" . "application/rss+xml") +("rtf" . "application/rtf") +("sbml" . "application/sbml+xml") +("scq" . "application/scvp-cv-request") +("scs" . "application/scvp-cv-response") +("spq" . "application/scvp-vp-request") +("spp" . "application/scvp-vp-response") +("sdp" . "application/sdp") +("setpay" . "application/set-payment-initiation") +("setreg" . "application/set-registration-initiation") +("shf" . "application/shf+xml") +("smi" . "application/smil+xml") +("rq" . "application/sparql-query") +("srx" . "application/sparql-results+xml") +("gram" . "application/srgs") +("grxml" . "application/srgs+xml") +("sru" . "application/sru+xml") +("ssdl" . "application/ssdl+xml") +("ssml" . "application/ssml+xml") +("tei" . "application/tei+xml") +("tfi" . "application/thraud+xml") +("tsd" . "application/timestamped-data") +("plb" . "application/vnd.3gpp.pic-bw-large") +("psb" . "application/vnd.3gpp.pic-bw-small") +("pvb" . "application/vnd.3gpp.pic-bw-var") +("tcap" . "application/vnd.3gpp2.tcap") +("pwn" . "application/vnd.3m.post-it-notes") +("aso" . "application/vnd.accpac.simply.aso") +("imp" . "application/vnd.accpac.simply.imp") +("acu" . "application/vnd.acucobol") +("atc" . "application/vnd.acucorp") +("air" . "application/vnd.adobe.air-application-installer-package+zip") +("fcdt" . "application/vnd.adobe.formscentral.fcdt") +("fxp" . "application/vnd.adobe.fxp") +("xdp" . "application/vnd.adobe.xdp+xml") +("xfdf" . "application/vnd.adobe.xfdf") +("ahead" . "application/vnd.ahead.space") +("azf" . "application/vnd.airzip.filesecure.azf") +("azs" . "application/vnd.airzip.filesecure.azs") +("azw" . "application/vnd.amazon.ebook") +("acc" . "application/vnd.americandynamics.acc") +("ami" . "application/vnd.amiga.ami") +("apk" . "application/vnd.android.package-archive") +("cii" . "application/vnd.anser-web-certificate-issue-initiation") +("fti" . "application/vnd.anser-web-funds-transfer-initiation") +("atx" . "application/vnd.antix.game-component") +("mpkg" . "application/vnd.apple.installer+xml") +("m3u8" . "application/vnd.apple.mpegurl") +("swi" . "application/vnd.aristanetworks.swi") +("iota" . "application/vnd.astraea-software.iota") +("aep" . "application/vnd.audiograph") +("mpm" . "application/vnd.blueice.multipass") +("bmi" . "application/vnd.bmi") +("rep" . "application/vnd.businessobjects") +("cdxml" . "application/vnd.chemdraw+xml") +("mmd" . "application/vnd.chipnuts.karaoke-mmd") +("cdy" . "application/vnd.cinderella") +("cla" . "application/vnd.claymore") +("rp9" . "application/vnd.cloanto.rp9") +("c4g" . "application/vnd.clonk.c4group") +("c11amc" . "application/vnd.cluetrust.cartomobile-config") +("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg") +("csp" . "application/vnd.commonspace") +("cdbcmsg" . "application/vnd.contact.cmsg") +("cmc" . "application/vnd.cosmocaller") +("clkx" . "application/vnd.crick.clicker") +("clkk" . "application/vnd.crick.clicker.keyboard") +("clkp" . "application/vnd.crick.clicker.palette") +("clkt" . "application/vnd.crick.clicker.template") +("clkw" . "application/vnd.crick.clicker.wordbank") +("wbs" . "application/vnd.criticaltools.wbs+xml") +("pml" . "application/vnd.ctc-posml") +("ppd" . "application/vnd.cups-ppd") +("car" . "application/vnd.curl.car") +("pcurl" . "application/vnd.curl.pcurl") +("dart" . "application/vnd.dart") +("rdz" . "application/vnd.data-vision.rdz") +("uvf" . "application/vnd.dece.data") +("uvt" . "application/vnd.dece.ttml+xml") +("uvx" . "application/vnd.dece.unspecified") +("uvz" . "application/vnd.dece.zip") +("fe_launch" . "application/vnd.denovo.fcselayout-link") +("dna" . "application/vnd.dna") +("mlp" . "application/vnd.dolby.mlp") +("dpg" . "application/vnd.dpgraph") +("dfac" . "application/vnd.dreamfactory") +("kpxx" . "application/vnd.ds-keypoint") +("ait" . "application/vnd.dvb.ait") +("svc" . "application/vnd.dvb.service") +("geo" . "application/vnd.dynageo") +("mag" . "application/vnd.ecowin.chart") +("nml" . "application/vnd.enliven") +("esf" . "application/vnd.epson.esf") +("msf" . "application/vnd.epson.msf") +("qam" . "application/vnd.epson.quickanime") +("slt" . "application/vnd.epson.salt") +("ssf" . "application/vnd.epson.ssf") +("es3" . "application/vnd.eszigno3+xml") +("ez2" . "application/vnd.ezpix-album") +("ez3" . "application/vnd.ezpix-package") +("fdf" . "application/vnd.fdf") +("mseed" . "application/vnd.fdsn.mseed") +("seed" . "application/vnd.fdsn.seed") +("gph" . "application/vnd.flographit") +("ftc" . "application/vnd.fluxtime.clip") +("fm" . "application/vnd.framemaker") +("fnc" . "application/vnd.frogans.fnc") +("ltf" . "application/vnd.frogans.ltf") +("fsc" . "application/vnd.fsc.weblaunch") +("oas" . "application/vnd.fujitsu.oasys") +("oa2" . "application/vnd.fujitsu.oasys2") +("oa3" . "application/vnd.fujitsu.oasys3") +("fg5" . "application/vnd.fujitsu.oasysgp") +("bh2" . "application/vnd.fujitsu.oasysprs") +("ddd" . "application/vnd.fujixerox.ddd") +("xdw" . "application/vnd.fujixerox.docuworks") +("xbd" . "application/vnd.fujixerox.docuworks.binder") +("fzs" . "application/vnd.fuzzysheet") +("txd" . "application/vnd.genomatix.tuxedo") +("ggb" . "application/vnd.geogebra.file") +("ggt" . "application/vnd.geogebra.tool") +("gex" . "application/vnd.geometry-explorer") +("gxt" . "application/vnd.geonext") +("g2w" . "application/vnd.geoplan") +("g3w" . "application/vnd.geospace") +("gmx" . "application/vnd.gmx") +("kml" . "application/vnd.google-earth.kml+xml") +("kmz" . "application/vnd.google-earth.kmz") +("gqf" . "application/vnd.grafeq") +("gac" . "application/vnd.groove-account") +("ghf" . "application/vnd.groove-help") +("gim" . "application/vnd.groove-identity-message") +("grv" . "application/vnd.groove-injector") +("gtm" . "application/vnd.groove-tool-message") +("tpl" . "application/vnd.groove-tool-template") +("vcg" . "application/vnd.groove-vcard") +("hal" . "application/vnd.hal+xml") +("zmm" . "application/vnd.handheld-entertainment+xml") +("hbci" . "application/vnd.hbci") +("les" . "application/vnd.hhe.lesson-player") +("hpgl" . "application/vnd.hp-hpgl") +("hpid" . "application/vnd.hp-hpid") +("hps" . "application/vnd.hp-hps") +("jlt" . "application/vnd.hp-jlyt") +("pcl" . "application/vnd.hp-pcl") +("pclxl" . "application/vnd.hp-pclxl") +("sfd-hdstx" . "application/vnd.hydrostatix.sof-data") +("mpy" . "application/vnd.ibm.minipay") +("afp" . "application/vnd.ibm.modcap") +("irm" . "application/vnd.ibm.rights-management") +("sc" . "application/vnd.ibm.secure-container") +("icc" . "application/vnd.iccprofile") +("igl" . "application/vnd.igloader") +("ivp" . "application/vnd.immervision-ivp") +("ivu" . "application/vnd.immervision-ivu") +("igm" . "application/vnd.insors.igm") +("xpw" . "application/vnd.intercon.formnet") +("i2g" . "application/vnd.intergeo") +("qbo" . "application/vnd.intu.qbo") +("qfx" . "application/vnd.intu.qfx") +("rcprofile" . "application/vnd.ipunplugged.rcprofile") +("irp" . "application/vnd.irepository.package+xml") +("xpr" . "application/vnd.is-xpr") +("fcs" . "application/vnd.isac.fcs") +("jam" . "application/vnd.jam") +("rms" . "application/vnd.jcp.javame.midlet-rms") +("jisp" . "application/vnd.jisp") +("joda" . "application/vnd.joost.joda-archive") +("ktz" . "application/vnd.kahootz") +("karbon" . "application/vnd.kde.karbon") +("chrt" . "application/vnd.kde.kchart") +("kfo" . "application/vnd.kde.kformula") +("flw" . "application/vnd.kde.kivio") +("kon" . "application/vnd.kde.kontour") +("kpr" . "application/vnd.kde.kpresenter") +("ksp" . "application/vnd.kde.kspread") +("kwd" . "application/vnd.kde.kword") +("htke" . "application/vnd.kenameaapp") +("kia" . "application/vnd.kidspiration") +("kne" . "application/vnd.kinar") +("skp" . "application/vnd.koan") +("sse" . "application/vnd.kodak-descriptor") +("lasxml" . "application/vnd.las.las+xml") +("lbd" . "application/vnd.llamagraphics.life-balance.desktop") +("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml") +("123" . "application/vnd.lotus-1-2-3") +("apr" . "application/vnd.lotus-approach") +("pre" . "application/vnd.lotus-freelance") +("nsf" . "application/vnd.lotus-notes") +("org" . "application/vnd.lotus-organizer") +("scm" . "application/vnd.lotus-screencam") +("lwp" . "application/vnd.lotus-wordpro") +("portpkg" . "application/vnd.macports.portpkg") +("mcd" . "application/vnd.mcd") +("mc1" . "application/vnd.medcalcdata") +("cdkey" . "application/vnd.mediastation.cdkey") +("mwf" . "application/vnd.mfer") +("mfm" . "application/vnd.mfmp") +("flo" . "application/vnd.micrografx.flo") +("igx" . "application/vnd.micrografx.igx") +("mif" . "application/vnd.mif") +("daf" . "application/vnd.mobius.daf") +("dis" . "application/vnd.mobius.dis") +("mbk" . "application/vnd.mobius.mbk") +("mqy" . "application/vnd.mobius.mqy") +("msl" . "application/vnd.mobius.msl") +("plc" . "application/vnd.mobius.plc") +("txf" . "application/vnd.mobius.txf") +("mpn" . "application/vnd.mophun.application") +("mpc" . "application/vnd.mophun.certificate") +("xul" . "application/vnd.mozilla.xul+xml") +("cil" . "application/vnd.ms-artgalry") +("cab" . "application/vnd.ms-cab-compressed") +("xls" . "application/vnd.ms-excel") +("xlam" . "application/vnd.ms-excel.addin.macroenabled.12") +("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12") +("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12") +("xltm" . "application/vnd.ms-excel.template.macroenabled.12") +("eot" . "application/vnd.ms-fontobject") +("chm" . "application/vnd.ms-htmlhelp") +("ims" . "application/vnd.ms-ims") +("lrm" . "application/vnd.ms-lrm") +("thmx" . "application/vnd.ms-officetheme") +("cat" . "application/vnd.ms-pki.seccat") +("stl" . "application/vnd.ms-pki.stl") +("ppt" . "application/vnd.ms-powerpoint") +("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12") +("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12") +("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12") +("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12") +("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12") +("mpp" . "application/vnd.ms-project") +("docm" . "application/vnd.ms-word.document.macroenabled.12") +("dotm" . "application/vnd.ms-word.template.macroenabled.12") +("wps" . "application/vnd.ms-works") +("wpl" . "application/vnd.ms-wpl") +("xps" . "application/vnd.ms-xpsdocument") +("mseq" . "application/vnd.mseq") +("mus" . "application/vnd.musician") +("msty" . "application/vnd.muvee.style") +("taglet" . "application/vnd.mynfc") +("nlu" . "application/vnd.neurolanguage.nlu") +("ntf" . "application/vnd.nitf") +("nnd" . "application/vnd.noblenet-directory") +("nns" . "application/vnd.noblenet-sealer") +("nnw" . "application/vnd.noblenet-web") +("ngdat" . "application/vnd.nokia.n-gage.data") +("n-gage" . "application/vnd.nokia.n-gage.symbian.install") +("rpst" . "application/vnd.nokia.radio-preset") +("rpss" . "application/vnd.nokia.radio-presets") +("edm" . "application/vnd.novadigm.edm") +("edx" . "application/vnd.novadigm.edx") +("ext" . "application/vnd.novadigm.ext") +("odc" . "application/vnd.oasis.opendocument.chart") +("otc" . "application/vnd.oasis.opendocument.chart-template") +("odb" . "application/vnd.oasis.opendocument.database") +("odf" . "application/vnd.oasis.opendocument.formula") +("odft" . "application/vnd.oasis.opendocument.formula-template") +("odg" . "application/vnd.oasis.opendocument.graphics") +("otg" . "application/vnd.oasis.opendocument.graphics-template") +("odi" . "application/vnd.oasis.opendocument.image") +("oti" . "application/vnd.oasis.opendocument.image-template") +("odp" . "application/vnd.oasis.opendocument.presentation") +("otp" . "application/vnd.oasis.opendocument.presentation-template") +("ods" . "application/vnd.oasis.opendocument.spreadsheet") +("ots" . "application/vnd.oasis.opendocument.spreadsheet-template") +("odt" . "application/vnd.oasis.opendocument.text") +("odm" . "application/vnd.oasis.opendocument.text-master") +("ott" . "application/vnd.oasis.opendocument.text-template") +("oth" . "application/vnd.oasis.opendocument.text-web") +("xo" . "application/vnd.olpc-sugar") +("dd2" . "application/vnd.oma.dd2+xml") +("oxt" . "application/vnd.openofficeorg.extension") +("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation") +("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide") +("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow") +("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template") +("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") +("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template") +("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document") +("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template") +("mgp" . "application/vnd.osgeo.mapguide.package") +("dp" . "application/vnd.osgi.dp") +("esa" . "application/vnd.osgi.subsystem") +("pdb" . "application/vnd.palm") +("paw" . "application/vnd.pawaafile") +("str" . "application/vnd.pg.format") +("ei6" . "application/vnd.pg.osasli") +("efif" . "application/vnd.picsel") +("wg" . "application/vnd.pmi.widget") +("plf" . "application/vnd.pocketlearn") +("pbd" . "application/vnd.powerbuilder6") +("box" . "application/vnd.previewsystems.box") +("mgz" . "application/vnd.proteus.magazine") +("qps" . "application/vnd.publishare-delta-tree") +("ptid" . "application/vnd.pvi.ptid1") +("qxd" . "application/vnd.quark.quarkxpress") +("bed" . "application/vnd.realvnc.bed") +("mxl" . "application/vnd.recordare.musicxml") +("musicxml" . "application/vnd.recordare.musicxml+xml") +("cryptonote" . "application/vnd.rig.cryptonote") +("cod" . "application/vnd.rim.cod") +("rm" . "application/vnd.rn-realmedia") +("rmvb" . "application/vnd.rn-realmedia-vbr") +("link66" . "application/vnd.route66.link66+xml") +("st" . "application/vnd.sailingtracker.track") +("see" . "application/vnd.seemail") +("sema" . "application/vnd.sema") +("semd" . "application/vnd.semd") +("semf" . "application/vnd.semf") +("ifm" . "application/vnd.shana.informed.formdata") +("itp" . "application/vnd.shana.informed.formtemplate") +("iif" . "application/vnd.shana.informed.interchange") +("ipk" . "application/vnd.shana.informed.package") +("twd" . "application/vnd.simtech-mindmapper") +("mmf" . "application/vnd.smaf") +("teacher" . "application/vnd.smart.teacher") +("sdkm" . "application/vnd.solent.sdkm+xml") +("dxp" . "application/vnd.spotfire.dxp") +("sfs" . "application/vnd.spotfire.sfs") +("sdc" . "application/vnd.stardivision.calc") +("sda" . "application/vnd.stardivision.draw") +("sdd" . "application/vnd.stardivision.impress") +("smf" . "application/vnd.stardivision.math") +("sdw" . "application/vnd.stardivision.writer") +("sgl" . "application/vnd.stardivision.writer-global") +("smzip" . "application/vnd.stepmania.package") +("sm" . "application/vnd.stepmania.stepchart") +("sxc" . "application/vnd.sun.xml.calc") +("stc" . "application/vnd.sun.xml.calc.template") +("sxd" . "application/vnd.sun.xml.draw") +("std" . "application/vnd.sun.xml.draw.template") +("sxi" . "application/vnd.sun.xml.impress") +("sti" . "application/vnd.sun.xml.impress.template") +("sxm" . "application/vnd.sun.xml.math") +("sxw" . "application/vnd.sun.xml.writer") +("sxg" . "application/vnd.sun.xml.writer.global") +("stw" . "application/vnd.sun.xml.writer.template") +("sus" . "application/vnd.sus-calendar") +("svd" . "application/vnd.svd") +("sis" . "application/vnd.symbian.install") +("xsm" . "application/vnd.syncml+xml") +("bdm" . "application/vnd.syncml.dm+wbxml") +("xdm" . "application/vnd.syncml.dm+xml") +("tao" . "application/vnd.tao.intent-module-archive") +("pcap" . "application/vnd.tcpdump.pcap") +("tmo" . "application/vnd.tmobile-livetv") +("tpt" . "application/vnd.trid.tpt") +("mxs" . "application/vnd.triscape.mxs") +("tra" . "application/vnd.trueapp") +("ufd" . "application/vnd.ufdl") +("utz" . "application/vnd.uiq.theme") +("umj" . "application/vnd.umajin") +("unityweb" . "application/vnd.unity") +("uoml" . "application/vnd.uoml+xml") +("vcx" . "application/vnd.vcx") +("vsd" . "application/vnd.visio") +("vis" . "application/vnd.visionary") +("vsf" . "application/vnd.vsf") +("wbxml" . "application/vnd.wap.wbxml") +("wmlc" . "application/vnd.wap.wmlc") +("wmlsc" . "application/vnd.wap.wmlscriptc") +("wtb" . "application/vnd.webturbo") +("nbp" . "application/vnd.wolfram.player") +("wpd" . "application/vnd.wordperfect") +("wqd" . "application/vnd.wqd") +("stf" . "application/vnd.wt.stf") +("xar" . "application/vnd.xara") +("xfdl" . "application/vnd.xfdl") +("hvd" . "application/vnd.yamaha.hv-dic") +("hvs" . "application/vnd.yamaha.hv-script") +("hvp" . "application/vnd.yamaha.hv-voice") +("osf" . "application/vnd.yamaha.openscoreformat") +("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml") +("saf" . "application/vnd.yamaha.smaf-audio") +("spf" . "application/vnd.yamaha.smaf-phrase") +("cmp" . "application/vnd.yellowriver-custom-menu") +("zir" . "application/vnd.zul") +("zaz" . "application/vnd.zzazz.deck+xml") +("vxml" . "application/voicexml+xml") +("wgt" . "application/widget") +("hlp" . "application/winhlp") +("wsdl" . "application/wsdl+xml") +("wspolicy" . "application/wspolicy+xml") +("7z" . "application/x-7z-compressed") +("abw" . "application/x-abiword") +("ace" . "application/x-ace-compressed") +("dmg" . "application/x-apple-diskimage") +("aab" . "application/x-authorware-bin") +("aam" . "application/x-authorware-map") +("aas" . "application/x-authorware-seg") +("bcpio" . "application/x-bcpio") +("torrent" . "application/x-bittorrent") +("blb" . "application/x-blorb") +("bz" . "application/x-bzip") +("bz2" . "application/x-bzip2") +("cbr" . "application/x-cbr") +("vcd" . "application/x-cdlink") +("cfs" . "application/x-cfs-compressed") +("chat" . "application/x-chat") +("pgn" . "application/x-chess-pgn") +("nsc" . "application/x-conference") +("cpio" . "application/x-cpio") +("csh" . "application/x-csh") +("deb" . "application/x-debian-package") +("dgc" . "application/x-dgc-compressed") +("dir" . "application/x-director") +("wad" . "application/x-doom") +("ncx" . "application/x-dtbncx+xml") +("dtb" . "application/x-dtbook+xml") +("res" . "application/x-dtbresource+xml") +("dvi" . "application/x-dvi") +("evy" . "application/x-envoy") +("eva" . "application/x-eva") +("bdf" . "application/x-font-bdf") +("gsf" . "application/x-font-ghostscript") +("psf" . "application/x-font-linux-psf") +("otf" . "application/x-font-otf") +("pcf" . "application/x-font-pcf") +("snf" . "application/x-font-snf") +("ttf" . "application/x-font-ttf") +("pfa" . "application/x-font-type1") +("woff" . "application/x-font-woff") +("arc" . "application/x-freearc") +("spl" . "application/x-futuresplash") +("gca" . "application/x-gca-compressed") +("ulx" . "application/x-glulx") +("gnumeric" . "application/x-gnumeric") +("gramps" . "application/x-gramps-xml") +("gtar" . "application/x-gtar") +("hdf" . "application/x-hdf") +("install" . "application/x-install-instructions") +("iso" . "application/x-iso9660-image") +("jnlp" . "application/x-java-jnlp-file") +("latex" . "application/x-latex") +("lzh" . "application/x-lzh-compressed") +("mie" . "application/x-mie") +("prc" . "application/x-mobipocket-ebook") +("m3u8" . "application/x-mpegurl") +("application" . "application/x-ms-application") +("lnk" . "application/x-ms-shortcut") +("wmd" . "application/x-ms-wmd") +("wmz" . "application/x-ms-wmz") +("xbap" . "application/x-ms-xbap") +("mdb" . "application/x-msaccess") +("obd" . "application/x-msbinder") +("crd" . "application/x-mscardfile") +("clp" . "application/x-msclip") +("exe" . "application/x-msdownload") +("mvb" . "application/x-msmediaview") +("wmf" . "application/x-msmetafile") +("mny" . "application/x-msmoney") +("pub" . "application/x-mspublisher") +("scd" . "application/x-msschedule") +("trm" . "application/x-msterminal") +("wri" . "application/x-mswrite") +("nc" . "application/x-netcdf") +("nzb" . "application/x-nzb") +("p12" . "application/x-pkcs12") +("p7b" . "application/x-pkcs7-certificates") +("p7r" . "application/x-pkcs7-certreqresp") +("rar" . "application/x-rar-compressed") +("ris" . "application/x-research-info-systems") +("sh" . "application/x-sh") +("shar" . "application/x-shar") +("swf" . "application/x-shockwave-flash") +("xap" . "application/x-silverlight-app") +("sql" . "application/x-sql") +("sit" . "application/x-stuffit") +("sitx" . "application/x-stuffitx") +("srt" . "application/x-subrip") +("sv4cpio" . "application/x-sv4cpio") +("sv4crc" . "application/x-sv4crc") +("t3" . "application/x-t3vm-image") +("gam" . "application/x-tads") +("tar" . "application/x-tar") +("tcl" . "application/x-tcl") +("tex" . "application/x-tex") +("tfm" . "application/x-tex-tfm") +("texinfo" . "application/x-texinfo") +("obj" . "application/x-tgif") +("ustar" . "application/x-ustar") +("src" . "application/x-wais-source") +("der" . "application/x-x509-ca-cert") +("fig" . "application/x-xfig") +("xlf" . "application/x-xliff+xml") +("xpi" . "application/x-xpinstall") +("xz" . "application/x-xz") +("z1" . "application/x-zmachine") +("xaml" . "application/xaml+xml") +("xdf" . "application/xcap-diff+xml") +("xenc" . "application/xenc+xml") +("xhtml" . "application/xhtml+xml") +("xml" . "application/xml") +("dtd" . "application/xml-dtd") +("xop" . "application/xop+xml") +("xpl" . "application/xproc+xml") +("xslt" . "application/xslt+xml") +("xspf" . "application/xspf+xml") +("mxml" . "application/xv+xml") +("yang" . "application/yang") +("yin" . "application/yin+xml") +("zip" . "application/zip") +("adp" . "audio/adpcm") +("au" . "audio/basic") +("mid" . "audio/midi") +("mp4a" . "audio/mp4") +("m4a" . "audio/mp4a-latm") +("mpga" . "audio/mpeg") +("oga" . "audio/ogg") +("s3m" . "audio/s3m") +("sil" . "audio/silk") +("uva" . "audio/vnd.dece.audio") +("eol" . "audio/vnd.digital-winds") +("dra" . "audio/vnd.dra") +("dts" . "audio/vnd.dts") +("dtshd" . "audio/vnd.dts.hd") +("lvp" . "audio/vnd.lucent.voice") +("pya" . "audio/vnd.ms-playready.media.pya") +("ecelp4800" . "audio/vnd.nuera.ecelp4800") +("ecelp7470" . "audio/vnd.nuera.ecelp7470") +("ecelp9600" . "audio/vnd.nuera.ecelp9600") +("rip" . "audio/vnd.rip") +("weba" . "audio/webm") +("aac" . "audio/x-aac") +("aif" . "audio/x-aiff") +("caf" . "audio/x-caf") +("flac" . "audio/x-flac") +("mka" . "audio/x-matroska") +("m3u" . "audio/x-mpegurl") +("wax" . "audio/x-ms-wax") +("wma" . "audio/x-ms-wma") +("ram" . "audio/x-pn-realaudio") +("rmp" . "audio/x-pn-realaudio-plugin") +("wav" . "audio/x-wav") +("xm" . "audio/xm") +("cdx" . "chemical/x-cdx") +("cif" . "chemical/x-cif") +("cmdf" . "chemical/x-cmdf") +("cml" . "chemical/x-cml") +("csml" . "chemical/x-csml") +("xyz" . "chemical/x-xyz") +("bmp" . "image/bmp") +("cgm" . "image/cgm") +("g3" . "image/g3fax") +("gif" . "image/gif") +("ief" . "image/ief") +("jp2" . "image/jp2") +("jpeg" . "image/jpeg") +("ktx" . "image/ktx") +("pict" . "image/pict") +("png" . "image/png") +("btif" . "image/prs.btif") +("sgi" . "image/sgi") +("svg" . "image/svg+xml") +("tiff" . "image/tiff") +("psd" . "image/vnd.adobe.photoshop") +("uvi" . "image/vnd.dece.graphic") +("sub" . "image/vnd.dvb.subtitle") +("djvu" . "image/vnd.djvu") +("dwg" . "image/vnd.dwg") +("dxf" . "image/vnd.dxf") +("fbs" . "image/vnd.fastbidsheet") +("fpx" . "image/vnd.fpx") +("fst" . "image/vnd.fst") +("mmr" . "image/vnd.fujixerox.edmics-mmr") +("rlc" . "image/vnd.fujixerox.edmics-rlc") +("mdi" . "image/vnd.ms-modi") +("wdp" . "image/vnd.ms-photo") +("npx" . "image/vnd.net-fpx") +("wbmp" . "image/vnd.wap.wbmp") +("xif" . "image/vnd.xiff") +("webp" . "image/webp") +("3ds" . "image/x-3ds") +("ras" . "image/x-cmu-raster") +("cmx" . "image/x-cmx") +("fh" . "image/x-freehand") +("ico" . "image/x-icon") +("pntg" . "image/x-macpaint") +("sid" . "image/x-mrsid-image") +("pcx" . "image/x-pcx") +("pic" . "image/x-pict") +("pnm" . "image/x-portable-anymap") +("pbm" . "image/x-portable-bitmap") +("pgm" . "image/x-portable-graymap") +("ppm" . "image/x-portable-pixmap") +("qtif" . "image/x-quicktime") +("rgb" . "image/x-rgb") +("tga" . "image/x-tga") +("xbm" . "image/x-xbitmap") +("xpm" . "image/x-xpixmap") +("xwd" . "image/x-xwindowdump") +("eml" . "message/rfc822") +("igs" . "model/iges") +("msh" . "model/mesh") +("dae" . "model/vnd.collada+xml") +("dwf" . "model/vnd.dwf") +("gdl" . "model/vnd.gdl") +("gtw" . "model/vnd.gtw") +("mts" . "model/vnd.mts") +("vtu" . "model/vnd.vtu") +("wrl" . "model/vrml") +("x3db" . "model/x3d+binary") +("x3dv" . "model/x3d+vrml") +("x3d" . "model/x3d+xml") +("manifest" . "text/cache-manifest") +("appcache" . "text/cache-manifest") +("ics" . "text/calendar") +("css" . "text/css") +("csv" . "text/csv") +("html" . "text/html") +("n3" . "text/n3") +("txt" . "text/plain") +("dsc" . "text/prs.lines.tag") +("rtx" . "text/richtext") +("sgml" . "text/sgml") +("tsv" . "text/tab-separated-values") +("t" . "text/troff") +("ttl" . "text/turtle") +("uri" . "text/uri-list") +("vcard" . "text/vcard") +("curl" . "text/vnd.curl") +("dcurl" . "text/vnd.curl.dcurl") +("scurl" . "text/vnd.curl.scurl") +("mcurl" . "text/vnd.curl.mcurl") +("sub" . "text/vnd.dvb.subtitle") +("fly" . "text/vnd.fly") +("flx" . "text/vnd.fmi.flexstor") +("gv" . "text/vnd.graphviz") +("3dml" . "text/vnd.in3d.3dml") +("spot" . "text/vnd.in3d.spot") +("jad" . "text/vnd.sun.j2me.app-descriptor") +("wml" . "text/vnd.wap.wml") +("wmls" . "text/vnd.wap.wmlscript") +("s" . "text/x-asm") +("c" . "text/x-c") +("f" . "text/x-fortran") +("java" . "text/x-java-source") +("opml" . "text/x-opml") +("p" . "text/x-pascal") +("nfo" . "text/x-nfo") +("etx" . "text/x-setext") +("sfv" . "text/x-sfv") +("uu" . "text/x-uuencode") +("vcs" . "text/x-vcalendar") +("vcf" . "text/x-vcard") +("3gp" . "video/3gpp") +("3g2" . "video/3gpp2") +("h261" . "video/h261") +("h263" . "video/h263") +("h264" . "video/h264") +("jpgv" . "video/jpeg") +("jpm" . "video/jpm") +("mj2" . "video/mj2") +("ts" . "video/mp2t") +("mp4" . "video/mp4") +("mpeg" . "video/mpeg") +("ogv" . "video/ogg") +("qt" . "video/quicktime") +("uvh" . "video/vnd.dece.hd") +("uvm" . "video/vnd.dece.mobile") +("uvp" . "video/vnd.dece.pd") +("uvs" . "video/vnd.dece.sd") +("uvv" . "video/vnd.dece.video") +("dvb" . "video/vnd.dvb.file") +("fvt" . "video/vnd.fvt") +("mxu" . "video/vnd.mpegurl") +("pyv" . "video/vnd.ms-playready.media.pyv") +("uvu" . "video/vnd.uvvu.mp4") +("viv" . "video/vnd.vivo") +("dv" . "video/x-dv") +("webm" . "video/webm") +("f4v" . "video/x-f4v") +("fli" . "video/x-fli") +("flv" . "video/x-flv") +("m4v" . "video/x-m4v") +("mkv" . "video/x-matroska") +("mng" . "video/x-mng") +("asf" . "video/x-ms-asf") +("vob" . "video/x-ms-vob") +("wm" . "video/x-ms-wm") +("wmv" . "video/x-ms-wmv") +("wmx" . "video/x-ms-wmx") +("wvx" . "video/x-ms-wvx") +("avi" . "video/x-msvideo") +("movie" . "video/x-sgi-movie") +("smv" . "video/x-smv") +("ice" . "x-conference/x-cooltalk"))) + +(define (ext->mimetype ext) + (let ((x (assoc ext ducttape_ext2mimetype))) + (if x (cdr x) "text/plain"))) ADDED ducttape/sample_ducttape.scm Index: ducttape/sample_ducttape.scm ================================================================== --- /dev/null +++ ducttape/sample_ducttape.scm @@ -0,0 +1,4 @@ +(include "ducttape-lib.scm") +(import ducttape-lib) +(inote "hello world") +(exit 0) ADDED ducttape/test_ducttape.scm Index: ducttape/test_ducttape.scm ================================================================== --- /dev/null +++ ducttape/test_ducttape.scm @@ -0,0 +1,345 @@ +#!/usr/bin/env csi -script +(use test) +(include "ducttape-lib.scm") +(import ducttape-lib) +(import ansi-escape-sequences) +(use trace) +(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname"))) +;(trace skim-cmdline-opts-withargs-by-regex) +;(trace keyword-skim) +;(trace re-match?) +(define (reset-ducttape) + (unsetenv "ducttape_DEBUG_LEVEL") + (ducttape-debug-level #f) + + (unsetenv "ducttape_DEBUG_PATTERN") + (ducttape-debug-regex-filter ".") + + (unsetenv "ducttape_LOG_FILE") + (ducttape-log-file #f) + + (unsetenv "ducttape_SILENT_MODE") + (ducttape-silent-mode #f) + + (unsetenv "ducttape_QUIET_MODE") + (ducttape-quiet-mode #f) + + (unsetenv "ducttape_COLOR_MODE") + (ducttape-color-mode #f) +) + +(define (reset-ducttape-with-cmdline-list cmdline-list) + (reset-ducttape) + + (command-line-arguments cmdline-list) + (process-command-line) +) + + +(define (direct-iputs-test) + (ducttape-color-mode #f) + (ierr "I'm an error") + (iwarn "I'm a warning") + (inote "I'm a note") + + (ducttape-debug-level 1) + (idbg "I'm a debug statement") + (ducttape-debug-level #f) + (idbg "I'm a hidden debug statement") + + (ducttape-silent-mode #t) + (iwarn "I shouldn't show up") + (inote "I shouldn't show up either") + (ierr "I should show up 1") + (ducttape-silent-mode #f) + + (ducttape-quiet-mode #t) + (iwarn "I should show up 2") + (inote "I shouldn't show up though") + (ierr "I should show up 3") + (ducttape-quiet-mode #f) + + (ducttape-debug-level 1) + (idbg "foo") + (iputs "dbg" "debug message") + (iputs "e" "error message") + (iputs "w" "warning message") + (iputs "n" "note message") + + (ducttape-color-mode #t) + (ierr "I'm an error COLOR") + (iwarn "I'm a warning COLOR") + (inote "I'm a note COLOR") + (idbg "I'm a debug COLOR") + + + ) + +(define (test-argprocessor-funcs) + + (test-group + "Command line processor utility functions" + + (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo")) + (command-line-arguments testargs1) + (set! expected_result '("-d" "-d" "-d3" "-ddd")) + (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo")) + + (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?")) + (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments)) + + + + (command-line-arguments testargs1) + (set! expected_result '("fooarg" "fooarg2" )) + (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo")) + (test + "skim-cmdline-opts-withargs-by-regex result" + expected_result + (skim-cmdline-opts-withargs-by-regex "--?foo")) + + (test + "skim-cmdline-opts-withargs-by-regex sideeffect" + expected_sideeffect + (command-line-arguments)) + + )) + +(define (test-misc) + (test-group + "misc" + (let ((tmpfile (mktemp))) + (test-assert "mktemp: temp file created" (file-exists? tmpfile)) + (if (file-exists? tmpfile) + (delete-file tmpfile)) + + ))) + +(define (test-systemstuff) + (test-group + "system commands" + + (let-values (((ec o e) (isys (find-exe "true")))) + (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0))) + (let-values (((ec o e) (isys (find-exe "false")))) + (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1))) + + (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz"))) + (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0)) + (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz"))) + + (let-values (((ec o e) (isys "/bin/ls /zzzzz"))) + (let ((expected-code + (if (equal? systype "Darwin") 1 2)) + (expected-err + (if (equal? systype "Darwin") + "ls: /zzzzz: No such file or directory" + "/bin/ls: cannot access /zzzzz: No such file or directory")) + + ) + (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec) + (test "isys: /bin/ls /zzzzz should have empty stdout" "" o) + (test + "isys: /bin/ls /zzzzz should have stderr" + expected-err + e)) + ) + + (let-values (((ec o e) (isys "/bin/ls /etc/passwd"))) + (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec) + (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o) + (test + "isys: /bin/ls /etc/passwd should have empty stderr" + "" + e)) + + (let ((res (do-or-die "/bin/ls /etc/passwd"))) + (test + "do-or-die: ls /etc/passwd should work" + "/etc/passwd" res )) + + (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t))) + (test + "do-or-die: ls /zzzzz should die" + #f res )) + + ; test reading from process stdout line at a time + (let* ( + (lineno (counter-maker)) + + ; print each line with an index + (eachline-fn (lambda (line) + (print "GOTLINE " (lineno) "> " line))) + + (res + (do-or-die "/bin/ls -l /etc | head; true" + foreach-stdout: eachline-fn ))) + + (test-assert "ls -l /etc should not be empty" + (not (equal? res "")))) + ;; test writing to process stdout line at a time + + (let* ((tmpfile (mktemp)) + (cmd (conc "cat > " tmpfile))) + (let-values (((c o e) + (isys cmd stdin-proc: + (lambda (myport) + (write-line "hello" myport) + (write-line "hello2" myport) + (close-output-port myport))))) + (test "isys-sp: cat should exit 0" 0 c) + (let ((mycmd (conc "cat " tmpfile))) + (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd))) + + (delete-file tmpfile) + )) + + (let* ((tmpfile (mktemp)) + (cmd (conc "cat > " tmpfile))) + (do-or-die cmd stdin-proc: + (lambda (myport) + (write-line "hello" myport) + (write-line "hello2" myport) + (close-output-port myport)) + cmd) + (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile))) + (delete-file tmpfile)) + + + + + + (let* + ((thefile (conc "/tmp/" (get-environment-variable "USER") "9-lines")) + (counter (counter-maker)) + (stdin-writer + (lambda () + (if (< (counter) 10) + (number->string (counter 0)) + #f))) + (cmd (conc "cat > " thefile))) + (let-values + (((c o e) + (isys cmd foreach-stdin-thunk: stdin-writer))) + + (test-assert "isys-fsl: cat should return 0" (equal? c 0)) + + (test-assert + "isys-fsl: cat should have written a file" + (file-exists? thefile)) + + (if + (file-exists? thefile) + (begin + (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile))) + (delete-file thefile))))) + + ) ; end test-group + ) ; end define + + +(define (test-argprocessor ) + (test-group + "Command line processor parameter settings" + + (reset-ducttape-with-cmdline-list '()) + (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level))) + (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter))) + (test-assert "(nil): colors should be off" (not (ducttape-color-mode))) + (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode))) + (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode))) + (test-assert "(nil): logfile should be off" (not (ducttape-log-file))) + + (reset-ducttape-with-cmdline-list '("-d")) + (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level))) + + (reset-ducttape-with-cmdline-list '("-dd")) + (test "-dd: debug level should be 2" 2 (ducttape-debug-level)) + + (reset-ducttape-with-cmdline-list '("-ddd")) + (test "-ddd: debug level should be 3" 3 (ducttape-debug-level)) + + (reset-ducttape-with-cmdline-list '("-d2")) + (test "-d2: debug level should be 2" 2 (ducttape-debug-level)) + + (reset-ducttape-with-cmdline-list '("-d3")) + (test "-d3: debug level should be 3" 3 (ducttape-debug-level)) + + (reset-ducttape-with-cmdline-list '("-dp" "foo")) + (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter)) + + (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo")) + (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter)) + + (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar")) + (test "-dp foo -dp bar: debug pattern should be 'foo|bar'" "foo|bar" (ducttape-debug-regex-filter)) + + (reset-ducttape-with-cmdline-list '("--quiet")) + (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode)) + + (reset-ducttape-with-cmdline-list '("--silent")) + (test-assert "-silent: silent mode should be active" (ducttape-silent-mode)) + + (reset-ducttape-with-cmdline-list '("--color")) + (test-assert "-color: color mode should be active" (ducttape-color-mode)) + + (reset-ducttape-with-cmdline-list '("--log" "foo")) + (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file)) + +)) + +(define (test-wwdate) + (test-group + "wwdate conversion tests" + (let ((test-table + '(("16ww01.5" . "2016-01-01") + ("16ww18.5" . "2016-04-29") + ("1999ww33.5" . "1999-08-13") + ("16ww18.4" . "2016-04-28") + ("16ww18.3" . "2016-04-27") + ("13ww01.0" . "2012-12-30") + ("13ww52.6" . "2013-12-28") + ("16ww53.3" . "2016-12-28")))) + (for-each + (lambda (test-pair) + (let ((wwdate (car test-pair)) + (isodate (cdr test-pair))) + (test + (conc "(isodate->wwdate "isodate ") => "wwdate) + wwdate + (isodate->wwdate isodate)) + + (test + (conc "(wwdate->isodate "wwdate ") => "isodate) + isodate + (wwdate->isodate wwdate)))) + test-table)))) + +(define (main) + ;; (test ) + +; (test-group "silly settext group" +; (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo")) +; (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo")) +; ) + + ; visually inspect this + (direct-iputs-test) + + ; following use unit test test-egg + (reset-ducttape) + (test-argprocessor-funcs) + (reset-ducttape) + (test-argprocessor) + (test-systemstuff) + (test-misc) + (test-wwdate) + ) ; end main() + +(main) +(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body") +;(sendmail "bjbarcla" "2hello subject html" "test body

hello

italics" use_html: #t) +;(sendmail "bb" "4hello attach subject html" "

hmm

" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) ) + +;(launch-repl) +(test-exit) ADDED ducttape/test_example.scm Index: ducttape/test_example.scm ================================================================== --- /dev/null +++ ducttape/test_example.scm @@ -0,0 +1,3 @@ +(use ducttape-lib) + +(inote "Hello world") ADDED ducttape/useargs-example.scm Index: ducttape/useargs-example.scm ================================================================== --- /dev/null +++ ducttape/useargs-example.scm @@ -0,0 +1,19 @@ +(use ducttape-lib) + +(let ( + (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?")) + (magicmode (skim-cmdline-opts-noarg-by-regex "--magic")) + ) + (print "your customers are " customers) + (if (null? magicmode) + (print "no unicorns for you") + (print "magic!") + ) + ) + +(idbg "hello") +(idbg "hello2" 2) +(idbg "hello2" 3) +(inote "note") +(iwarn "warn") +(ierr "err") ADDED ducttape/workweekdate.scm Index: ducttape/workweekdate.scm ================================================================== --- /dev/null +++ ducttape/workweekdate.scm @@ -0,0 +1,193 @@ +(use srfi-19) +(use test) +;;(use format) +(use regex) +;(declare (unit wwdate)) +;; utility procedures to convert among +;; different ways to express date (wwdate, seconds since epoch, isodate) +;; +;; samples: +;; isodate -> "2016-01-01" +;; wwdate -> "16ww01.5" +;; seconds -> 1451631600 + +;; procedures provided: +;; ==================== +;; seconds->isodate +;; seconds->wwdate +;; +;; isodate->seconds +;; isodate->wwdate +;; +;; wwdate->seconds +;; wwdate->isodate + +;; srfi-19 used extensively; this doc is better tha the eggref: +;; http://srfi.schemers.org/srfi-19/srfi-19.html + +;; Author: brandon.j.barclay@intel.com 16ww18.6 + +(define (date->seconds date) + (inexact->exact + (string->number + (date->string date "~s")))) + +(define (seconds->isodate seconds) + (let* ((date (seconds->date seconds)) + (result (date->string date "~Y-~m-~d"))) + result)) + +(define (isodate->seconds isodate) + "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K" + (let* ((numlist (map string->number (string-split isodate "-"))) + (raw-year (car numlist)) + (year (if (< raw-year 100) (+ raw-year 2000) raw-year)) + (month (list-ref numlist 1)) + (day (list-ref numlist 2)) + (date (make-date 0 0 0 0 day month year)) + (seconds (date->seconds date))) + + seconds)) + +;; adapted from perl Intel::WorkWeek perl module +;; workweek year consists of numbered weeks starting from week 1 +;; days of week are numbered starting from 0 on sunday +;; weeks begin on sunday- day number 0 and end saturday- day 6 +;; week 1 is defined as the week containing jan 1 of the year +;; workweek year does not match calendar year in workweek 1 +;; since workweek 1 contains jan1 and workweek begins sunday, +;; days prior to jan1 in workweek 1 belong to the next workweek year +(define (seconds->wwdate-values seconds) + (define (date-difference->seconds d1 d2) + (- (date->seconds d1) (date->seconds d2))) + + (let* ((thisdate (seconds->date seconds)) + (thisdow (string->number (date->string thisdate "~w"))) + + (year (date-year thisdate)) + ;; intel workweek 1 begins on sunday of week containing jan1 + (jan1 (make-date 0 0 0 0 1 1 year)) + (jan1dow (date-week-day jan1)) + (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow)))) + + (ww01_delta_seconds (date-difference->seconds thisdate ww01)) + (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) )))) + + ;; we could be in ww1 of next year + (this-saturday (seconds->date + (+ seconds + (* 60 60 24 (- 6 thisdow))))) + (this-week-ends-next-year? + (> (date-year this-saturday) year)) + (intelyear + (if this-week-ends-next-year? + (add1 year) + year)) + (intelweek + (if this-week-ends-next-year? + 1 + wwnum_initial))) + (values intelyear intelweek thisdow))) + +(define (string-leftpad in width pad-char) + (let* ((unpadded-str (->string in)) + (padlen_temp (- width (string-length unpadded-str))) + (padlen (if (< padlen_temp 0) 0 padlen_temp)) + (padding (make-string padlen pad-char))) + (conc padding unpadded-str))) + +(define (string-rightpad in width pad-char) + (let* ((unpadded-str (->string in)) + (padlen_temp (- width (string-length unpadded-str))) + (padlen (if (< padlen_temp 0) 0 padlen_temp)) + (padding (make-string padlen pad-char))) + (conc unpadded-str padding))) + +(define (zeropad num width) + (string-leftpad num width #\0)) + +(define (seconds->wwdate seconds) + + (let-values (((intelyear intelweek day-of-week-num) + (seconds->wwdate-values seconds))) + (let ((intelyear-str + (zeropad + (->string + (if (> intelyear 1999) + (- intelyear 2000) intelyear)) + 2)) + (intelweek-str + (zeropad (->string intelweek) 2)) + (dow-str (->string day-of-week-num))) + (conc intelyear-str "ww" intelweek-str "." dow-str)))) + +(define (isodate->wwdate isodate) + (seconds->wwdate + (isodate->seconds isodate))) + +(define (wwdate->seconds wwdate) + (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate))) + (if + (not match) + #f + (let* ( + (intelyear-raw (string->number (list-ref match 1))) + (intelyear (if (< intelyear-raw 100) + (+ intelyear-raw 2000) + intelyear-raw)) + (intelww (string->number (list-ref match 2))) + (dayofweek (string->number (list-ref match 3))) + + (day-of-seconds (* 60 60 24 )) + (week-of-seconds (* day-of-seconds 7)) + + + ;; get seconds at ww1.0 + (new-years-date (make-date 0 0 0 0 1 1 intelyear)) + (new-years-seconds + (date->seconds new-years-date)) + (new-years-dayofweek (date-week-day new-years-date)) + (ww1.0_seconds (- new-years-seconds + (* day-of-seconds + new-years-dayofweek))) + (workweek-adjustment (* week-of-seconds (sub1 intelww))) + (weekday-adjustment (* dayofweek day-of-seconds)) + + (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment))) + result)))) + +(define (wwdate->isodate wwdate) + (seconds->isodate (wwdate->seconds wwdate))) + +(define (current-wwdate) + (seconds->wwdate (current-seconds))) + +(define (current-isodate) + (seconds->isodate (current-seconds))) + +(define (wwdate-tests) + (test-group + "date conversion tests" + (let ((test-table + '(("16ww01.5" . "2016-01-01") + ("16ww18.5" . "2016-04-29") + ("1999ww33.5" . "1999-08-13") + ("16ww18.4" . "2016-04-28") + ("16ww18.3" . "2016-04-27") + ("13ww01.0" . "2012-12-30") + ("13ww52.6" . "2013-12-28") + ("16ww53.3" . "2016-12-28")))) + (for-each + (lambda (test-pair) + (let ((wwdate (car test-pair)) + (isodate (cdr test-pair))) + (test + (conc "(isodate->wwdate "isodate ") => "wwdate) + wwdate + (isodate->wwdate isodate)) + + (test + (conc "(wwdate->isodate "wwdate ") => "isodate) + isodate + (wwdate->isodate wwdate)))) + test-table)))) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -164,11 +164,11 @@ new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))) + (cdb:set-state-status-and-roll-up-items *runremote* run-id test-name item-path new-status)))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no ))) (pop-directory) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -217,11 +217,11 @@ (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) - (res #f) + (res (vector #f "uninitialized")) (success #t) (sparams (db:obj->string params transport: 'http))) (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) @@ -383,30 +383,34 @@ (server-going #f)) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) - + ;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-db* ;; Removed code is pasted below (keeping it around until we are clear it is not needed). ;; no *dbstruct-db* yet, set running after our first pass through and start the db (if (eq? server-state 'available) (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers (if (equal? new-server-id server-id) (begin (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") + ;;(BB> "http-transport: ->dbprep") (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access (set! *dbstruct-db* (db:setup)) ;; run-id)) (set! server-going #t) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") - (server:write-dotserver *toppath* (conc iface ":" port)) - (delete-file* (conc *toppath* "/.starting-server"))) + ;;(BB> "http-transport: ->running") + (server:write-dotserver *toppath* iface port (current-process-id) 'http) + (thread-start! *watchdog*) + (server:complete-attempt *toppath*)) (begin ;; gotta exit nicely + ;;(BB> "http-transport: ->collision") (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision") (http-transport:server-shutdown server-id port)))))) - + ;; 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. (let* ((sync-time (- (current-milliseconds) start-time)) (rem-time (quotient (- 4000 sync-time) 1000))) (if (and (<= rem-time 4) @@ -424,11 +428,12 @@ (if (or (not (equal? sdat (list iface port))) (not server-id)) (begin (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info") (set! iface (car sdat)) - (set! port (cadr sdat)))) + (set! port (cadr sdat)) + (server:write-dotserver *toppath* iface port (current-process-id) 'http))) ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *db-last-access*) (mutex-unlock! *heartbeat-mutex*) @@ -443,25 +448,30 @@ (adjusted-timeout (if (> hrs-since-start 1) (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour server-timeout))) (if (common:low-noise-print 120 "server timeout") (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout)) - (if (and *server-run* + (cond + ((not (server:confirm-dotserver *toppath* iface port (current-process-id) 'http)) + (debug:print-info 0 *default-log-port* "Server .server file does not exist or contents do not match. Initiate server shutdown.") + (http-transport:server-shutdown server-id port)) + ((and *server-run* (> (+ last-access server-timeout) (current-seconds))) - (begin - (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))) - ;; - ;; Consider implementing some smarts here to re-insert the record or kill self is - ;; the db indicates so - ;; - ;; (if (tasks:server-am-i-the-server? tdb run-id) - ;; (tasks:server-set-state! tdb server-id "running")) - ;; - (loop 0 server-state bad-sync-count (current-milliseconds))) - (http-transport:server-shutdown server-id port)))))) + (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))) + ;; + ;; Consider implementing some smarts here to re-insert the record or kill self is + ;; the db indicates so + ;; + ;; (if (tasks:server-am-i-the-server? tdb run-id) + ;; (tasks:server-set-state! tdb server-id "running")) + ;; + (loop 0 server-state bad-sync-count (current-milliseconds))) + (else + (debug:print-info 0 *default-log-port* "Server timeed out. seconds since last db access: " (- (current-seconds) last-access)) + (http-transport:server-shutdown server-id port))))))) ;; code cut out from above ;; ;; (condition-case ;; ;; (if (and (member (mutex-state *db-sync-mutex*) '(abandoned not-abandoned)) @@ -486,48 +496,50 @@ ;; (thread-sleep! rem-time) ;; (thread-sleep! 4))) ;; fallback for if the math is changed ... (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) - (debug:print-info 0 *default-log-port* "Starting to shutdown the server.") + ;;(BB> "http-transport:server-shutdown called") + (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up (portlogger:open-run-close portlogger:set-port port "released") (thread-sleep! 5) - (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") +;; (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") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") ;; if the .server file contained :myport then we can remove it (server:remove-dotserver-file *toppath* port) + ;;(BB> "http-transport:server-shutdown -> exit") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) - (with-output-to-file - (conc *toppath* "/.starting-server") - (lambda () - (print (current-process-id) " on " (get-host-name)))) + (server:attempting-start *toppath*) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) @@ -539,11 +551,11 @@ (server:check-if-running run-id)) (begin (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0)) (begin ;; ok, no server detected, clean out any lingering records - (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding"))) + (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding"))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) (begin @@ -552,11 +564,11 @@ (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") - (delete-file* (conc *toppath* "/.starting-server")) + (server:complete-attempt *toppath*) )) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") DELETED inteldate.scm Index: inteldate.scm ================================================================== --- inteldate.scm +++ /dev/null @@ -1,180 +0,0 @@ -(use srfi-19) -(use test) -(use format) -(use regex) -(declare (unit inteldate)) -;; utility procedures to convert among -;; different ways to express date (inteldate, seconds since epoch, isodate) -;; -;; samples: -;; isodate -> "2016-01-01" -;; inteldate -> "16ww01.5" -;; seconds -> 1451631600 - -;; procedures provided: -;; ==================== -;; seconds->isodate -;; seconds->inteldate -;; -;; isodate->seconds -;; isodate->inteldate -;; -;; inteldate->seconds -;; inteldate->isodate - -;; srfi-19 used extensively; this doc is better tha the eggref: -;; http://srfi.schemers.org/srfi-19/srfi-19.html - -;; Author: brandon.j.barclay@intel.com 16ww18.6 - -(define (date->seconds date) - (inexact->exact - (string->number - (date->string date "~s")))) - -(define (seconds->isodate seconds) - (let* ((date (seconds->date seconds)) - (result (date->string date "~Y-~m-~d"))) - result)) - -(define (isodate->seconds isodate) - "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K" - (let* ((numlist (map string->number (string-split isodate "-"))) - (raw-year (car numlist)) - (year (if (< raw-year 100) (+ raw-year 2000) raw-year)) - (month (list-ref numlist 1)) - (day (list-ref numlist 2)) - (date (make-date 0 0 0 0 day month year)) - (seconds (date->seconds date))) - - seconds)) - -;; adapted from perl Intel::WorkWeek perl module -;; intel year consists of numbered weeks starting from week 1 -;; week 1 is the week containing jan 1 of the year -;; days of week are numbered starting from 0 on sunday -;; intel year does not match calendar year in workweek 1 -;; before jan1. -(define (seconds->inteldate-values seconds) - (define (date-difference->seconds d1 d2) - (- (date->seconds d1) (date->seconds d2))) - - (let* ((thisdate (seconds->date seconds)) - (thisdow (string->number (date->string thisdate "~w"))) - - (year (date-year thisdate)) - ;; intel workweek 1 begins on sunday of week containing jan1 - (jan1 (make-date 0 0 0 0 1 1 year)) - (jan1dow (date-week-day jan1)) - (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow)))) - - (ww01_delta_seconds (date-difference->seconds thisdate ww01)) - (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) )))) - - ;; we could be in ww1 of next year - (this-saturday (seconds->date - (+ seconds - (* 60 60 24 (- 6 thisdow))))) - (this-week-ends-next-year? - (> (date-year this-saturday) year)) - (intelyear - (if this-week-ends-next-year? - (add1 year) - year)) - (intelweek - (if this-week-ends-next-year? - 1 - wwnum_initial))) - (values intelyear intelweek thisdow))) - -(define (seconds->inteldate seconds) - (define (string-leftpad in width pad-char) - (let* ((unpadded-str (->string in)) - (padlen_temp (- width (string-length unpadded-str))) - (padlen (if (< padlen_temp 0) 0 padlen_temp)) - (padding - (fold conc "" - (map (lambda (x) (->string pad-char)) (iota padlen))))) - (conc padding unpadded-str))) - (define (zeropad num width) - (string-leftpad num width #:0)) - - (let-values (((intelyear intelweek day-of-week-num) - (seconds->inteldate-values seconds))) - (let ((intelyear-str - (zeropad - (->string - (if (> intelyear 1999) - (- intelyear 2000) intelyear)) - 2)) - (intelweek-str - (zeropad (->string intelweek) 2)) - (dow-str (->string day-of-week-num))) - (conc intelyear-str "ww" intelweek-str "." dow-str)))) - -(define (isodate->inteldate isodate) - (seconds->inteldate - (isodate->seconds isodate))) - -(define (inteldate->seconds inteldate) - (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate))) - (if - (not match) - #f - (let* ( - (intelyear-raw (string->number (list-ref match 1))) - (intelyear (if (< intelyear-raw 100) - (+ intelyear-raw 2000) - intelyear-raw)) - (intelww (string->number (list-ref match 2))) - (dayofweek (string->number (list-ref match 3))) - - (day-of-seconds (* 60 60 24 )) - (week-of-seconds (* day-of-seconds 7)) - - - ;; get seconds at ww1.0 - (new-years-date (make-date 0 0 0 0 1 1 intelyear)) - (new-years-seconds - (date->seconds new-years-date)) - (new-years-dayofweek (date-week-day new-years-date)) - (ww1.0_seconds (- new-years-seconds - (* day-of-seconds - new-years-dayofweek))) - (workweek-adjustment (* week-of-seconds (sub1 intelww))) - (weekday-adjustment (* dayofweek day-of-seconds)) - - (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment))) - result)))) - -(define (inteldate->isodate inteldate) - (seconds->isodate (inteldate->seconds inteldate))) - -(define (inteldate-tests) - (test-group - "date conversion tests" - (let ((test-table - '(("16ww01.5" . "2016-01-01") - ("16ww18.5" . "2016-04-29") - ("1999ww33.5" . "1999-08-13") - ("16ww18.4" . "2016-04-28") - ("16ww18.3" . "2016-04-27") - ("13ww01.0" . "2012-12-30") - ("13ww52.6" . "2013-12-28") - ("16ww53.3" . "2016-12-28")))) - (for-each - (lambda (test-pair) - (let ((inteldate (car test-pair)) - (isodate (cdr test-pair))) - (test - (conc "(isodate->inteldate "isodate ") => "inteldate) - inteldate - (isodate->inteldate isodate)) - - (test - (conc "(inteldate->isodate "inteldate ") => "isodate) - isodate - (inteldate->isodate inteldate)))) - test-table)))) - -;(inteldate-tests) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -64,18 +64,19 @@ (define (launch:load-logpro-dat run-id test-id stepname) (let ((cname (conc stepname ".dat"))) (if (file-exists? cname) (let* ((dat (read-config cname #f #f)) (csvr (db:logpro-dat->csv dat stepname)) - (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ","))) - (fmt-csv (map list->csv-record csvr)))) + (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ","))) + (fmt-csv (map list->csv-record csvr)))) (status (configf:lookup dat "final" "exit-status")) (msg (configf:lookup dat "final" "message"))) - ;;(if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro + (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro (rmt:csv->test-data run-id test-id csvt) - ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) - ;; ) + (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) + ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) + ;; ) (cond ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) #f))) @@ -122,10 +123,22 @@ (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 (pid (process-run "/bin/bash" (list "-c" cmd)))) + + (with-output-to-file "Makefile.ezsteps" + (lambda () + (print stepname ".log :") + (print "\t" cmd) + (if (file-exists? (conc stepname ".logpro")) + (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log")) + (print) + (print stepname " : " stepname ".log") + (print)) + #:append) + (rmt:test-set-top-process-pid run-id test-id pid) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) @@ -241,11 +254,11 @@ ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a ;; (thread-sleep! 0.3) ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING" #f) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) @@ -268,11 +281,11 @@ ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. - (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) + (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) (hash-table-ref/default testconfig "ezsteps" '()) #f))) (if testconfig (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... @@ -316,15 +329,15 @@ (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes)) - (cpu-load (get-cpu-load)) + (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (disk-free (get-df (current-directory)))) - (let ((new-cpu-load (let* ((load (get-cpu-load)) + (let ((new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (delta (abs (- load cpu-load)))) - (if (> delta 0.6) ;; don't bother updating with small changes + (if (> delta 0.1) ;; don't bother updating with small changes load #f))) (new-disk-free (let* ((df (get-df (current-directory))) (delta (abs (- df disk-free)))) (if (> delta 200) ;; ignore changes under 200 Meg @@ -445,11 +458,11 @@ (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () - (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED") + (rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f) (print "Killed by signal " signum ". Exiting") (thread-sleep! 1) (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 2) @@ -469,17 +482,23 @@ (test-host (db:test-get-host test-info)) (test-pid (db:test-get-process_id test-info))) (cond ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") - (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running + ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") - (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))) + ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + )) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) - (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) + ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + ) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) @@ -639,11 +658,11 @@ test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest - ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! + ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status! )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f)) (tests:summarize-test run-id test-id) ;; don't force - just update if no @@ -846,11 +865,14 @@ (directory-exists? *toppath*)) (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) (begin - (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area."))) + (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") + ;;(exit 1) + #f + )) *toppath*)) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) @@ -861,11 +883,11 @@ (if res (cdr res) (begin (if (common:low-noise-print 20 "No valid disks or no disk with enough space") (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) - (exit 1))))))) + (exit 1))))))) ;; TODO - move the exit to the calling location and return #f ;; Desired directory structure: ;; ;; - - -. ;; | @@ -1053,30 +1075,35 @@ ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* ((item-path (item-list->path itemdat))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5")))) (if (> launch-delay delta) (begin (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds") (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) - (set! *last-launch* (current-seconds)) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) - (list - (list "MT_RUN_AREA_HOME" *toppath*) - (list "MT_TEST_NAME" test-name) - (list "MT_RUNNAME" runname) - (list "MT_ITEMPATH" item-path) - )) - (let* ((tregistry (tests:get-all)) - (tconfig (or (tests:get-testconfig test-name tregistry #t force-create: #t) - test-conf)) ;; force re-read now that all vars are set + (append + (list + (list "MT_RUN_AREA_HOME" *toppath*) + (list "MT_TEST_NAME" test-name) + (list "MT_RUNNAME" runname) + (list "MT_ITEMPATH" item-path) + ) + itemdat)) + (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed + ;; for tconfig, why do we allow fallback to test-conf? + (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) + (begin + (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.") + test-conf))) ;; force re-read now that all vars are set (useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) (if ush (if (equal? ush "no") ;; must use "no" to NOT use shell #f ush) @@ -1101,22 +1128,21 @@ ((dboard) "../megatest") ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher")) - (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path - (work-area #f) + (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path + (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) - ;; (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) @@ -1129,11 +1155,12 @@ ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED" #f) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) + ;; (pp (hash-table->alist tconfig)) (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) @@ -1184,10 +1211,11 @@ ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 *default-log-port* "Launching " work-area) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 *default-log-port* "fullcmd: " fullcmd) + (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible. (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) @@ -1206,15 +1234,16 @@ process-run) (if useshell (let ((cmdstr (string-intersperse fullcmd " "))) (if launchwait cmdstr - (conc cmdstr " >> mt_launch.log 2>&1"))) + (conc cmdstr " >> mt_launch.log 2>&1 &"))) (car fullcmd)) (if useshell '() (cdr fullcmd))))) + (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) (with-output-to-file "mt_launch.log" (lambda () (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6302) +(define megatest-version 1.6305) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -67,10 +67,11 @@ version " megatest-version " license GPL, Copyright Matt Welland 2006-2015 Usage: megatest [options] -h : this help + -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") Launching and managing runs -runall : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt @@ -93,10 +94,12 @@ -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context -status : Applies to runs, tests or steps depending on context + --modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified + -tagexpr tag1,tag2%,.. : select tests with tags matching expression Test helpers (for use inside tests) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test @@ -209,11 +212,13 @@ ":state" "-state" ":status" "-status" "-list-runs" - "-testpatt" + "-testpatt" + "--modepatt" + "-tagexpr" "-itempatt" "-setlog" "-set-toplog" "-runstep" "-logpro" @@ -345,11 +350,13 @@ ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread common:watchdog "Watchdog thread")) -(thread-start! *watchdog*) +(if (not (args:get-arg "-server")) + (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog +;;(BB> "thread-start! watchdog") (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log")) (set! *default-log-port* oup))) @@ -1851,13 +1858,11 @@ (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - ;; now can find our db - ;; keep this one local - (open-run-close runs:update-all-test_meta #f) + (runs:update-all-test_meta #f) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== @@ -1986,17 +1991,22 @@ ;;====================================================================== ;; Exit and clean up ;;====================================================================== -(if *runremote* (close-all-connections!)) ;; for http-client - (if (not *didsomething*) (debug:print 0 *default-log-port* help)) +;;(BB> "thread-join! watchdog") + +;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) +;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) +(if (thread? *watchdog*) + (case (thread-state *watchdog*) + ((ready running blocked sleeping terminated dead) + (thread-join! *watchdog*)))) (set! *time-to-exit* #t) -(thread-join! *watchdog*) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) ADDED minimal/manyservers.sh Index: minimal/manyservers.sh ================================================================== --- /dev/null +++ minimal/manyservers.sh @@ -0,0 +1,119 @@ +#!/bin/bash + +echo manyservers.sh pid $$ + +logdir=$PWD/log-manysrv + + +function reset { + rm -f .homehost .server .server.lock links/.db/monitor.db .starting-server + } + +function launch_many_servers { + # count = $1 + # logdir = $2 + # prefx = $3 + perl -e 'foreach my $i (1 ... '$1'){print "'$2'/'$3'-srv-$i.log\n"}' | \ + xargs -P $1 -n 1 megatest -server - -run-id 0 -daemonize -log +} + + +function get_srv_pids { + ps auwx | grep "mtest -server" | grep $logdir | grep -v grep | awk '{print $2}' +} + + +if [[ -e $logdir ]]; then rm -rf $logdir; fi +if [[ ! -e $logdir ]]; then mkdir $logdir; fi + +reset + +simultaneous_servers=20 +server_collision_resolution_delay=15 +server_timeout_delay=65 + +echo "Launching $simultaneous_servers simultaneous servers" +launch_many_servers $simultaneous_servers $logdir "first" +echo "Sleeping $server_collision_resolution_delay seconds to allow new servers to die because one is already running." +sleep $server_collision_resolution_delay + +pids=`get_srv_pids` +pids_left=`echo $pids | wc -w` +echo "pids_left=$pids_left" +echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1" +if [[ $pids_left == 1 ]]; then + echo "All servers but 1 terminated. Still good." +else + if [[ $pids_left == 0 ]]; then + echo "All servers died too soon. Not good. Aborting." + echo "TEST FAIL" + exit 1 + else + echo "Too many servers left. Not good. Aborting." + echo "TEST FAIL" + echo $pids | xargs kill + sleep 5 + pids=`get_srv_pids` + pids_left=`echo $pids | wc -w` + if [[ ! ( $pids_left == 0 ) ]]; then + echo $pids | xargs kill -9 + fi + exit 1 + fi +fi + + + +echo "launching another volley of $simultaneous_servers. THey should all perish. right away, leaving the one server running." +launch_many_servers $simultaneous_servers $logdir "second" +sleep $server_collision_resolution_delay + +pids=`get_srv_pids` +pids_left=`echo $pids | wc -w` +echo "pids_left=$pids_left" +echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1" +if [[ $pids_left == 1 ]]; then + echo "All servers but 1 terminated. So far so good." +else + if [[ $pids_left == 0 ]]; then + echo "All servers died too soon. Not good. Aborting." + echo "TEST FAIL" + exit 1 + else + echo "Too many servers left. Not good. Aborting." + echo "TEST FAIL" + echo $pids | xargs kill + sleep 5 + pids=`get_srv_pids` + pids_left=`echo $pids | wc -w` + if [[ ! ( $pids_left == 0 ) ]]; then + echo $pids | xargs kill -9 + fi + exit 1 + fi +fi + + + +echo "sleeping for awhile ($server_timeout_delay seconds) to let server exit on its own for no-request timeout" +sleep $server_timeout_delay +pids=`get_srv_pids` +pids_left=`echo $pids | wc -w` +echo "after $server_timeout_delay seconds: servers remaining=$pids_left; expecting 0" + +if [[ $pids_left == 0 ]]; then + echo "No servers remain. This is good." + echo "TEST PASS" + exit 0 +else + echo "Too many servers left. Not good. Aborting." + echo "TEST FAIL" + echo $pids | xargs kill + sleep 5 + pids=`get_srv_pids` + pids_left=`echo $pids | wc -w` + if [[ ! ( $pids_left == 0 ) ]]; then + echo $pids | xargs kill -9 + fi + exit 1 +fi Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -128,12 +128,12 @@ ;;====================================================================== ;; T R I G G E R S ;;====================================================================== -(define (mt:process-triggers run-id test-id newstate newstatus) - (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))) +(define (mt:process-triggers dbstruct run-id test-id newstate newstatus) + (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat (let* ((test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) @@ -186,18 +186,18 @@ ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) ;; (else ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) - (rmt:roll-up-pass-fail-counts run-id test-id #f newstate newstatus newcomment) - (mt:process-triggers run-id test-id newstate newstatus) + (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment) + ;; (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) - (rmt:roll-up-pass-fail-counts run-id test-name item-path new-state new-status new-comment) - (mt:process-triggers run-id test-id new-state new-status) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) + ;; (mt:process-triggers run-id test-id new-state new-status) #t)) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -24,27 +24,20 @@ ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u -(defstruct remote - (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) - (server-url (if *toppath* (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*) #f)) - (last-server-check 0) ;; last time we checked to see if the server was alive - (conndat #f) - (transport *transport-type*) - (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds - ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; -(define (rmt:get-connection-info run-id) - (let ((cinfo (remote-conndat *runremote*))) +(define (rmt:get-connection-info areapath) ;; TODO: push areapath down. + (let ((cinfo (remote-conndat *runremote*)) + (run-id 0)) (if cinfo cinfo (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) @@ -82,11 +75,11 @@ (set! *runremote* (make-remote)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 1") (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; ensure we have a homehost record - ((not (pair? (remote-hh-dat *runremote*))) ;; have a homehost record? + ((not (pair? (remote-hh-dat *runremote*))) ;; not on homehost (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little (remote-hh-dat-set! *runremote* (common:get-homehost)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2") (rmt:send-receive cmd rid params attemptnum: attemptnum)) @@ -94,60 +87,92 @@ ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3") (rmt:open-qry-close-locally cmd 0 params)) + + ;; on homehost and this is a write, we already have a server, but server has died + ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + (not (member cmd api:read-only-queries)) ;; this is a write + (remote-server-url *runremote*) ;; have a server + (not (server:read-dotserver *toppath*))) ;; server has died. + (set! *runremote* #f) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") + (rmt:send-receive cmd rid params attemptnum: attemptnum)) + ;; on homehost and this is a write, we already have a server ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write (remote-server-url *runremote*)) ;; have a server (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4") (rmt:open-qry-close-locally cmd 0 params)) - ;; on homehost and this is a write, we have a server (we know because case 4 checked) - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost - (not (member cmd api:read-only-queries))) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") - (rmt:open-qry-close-locally cmd 0 params)) - ;; no server contact made and this is a write, passively start a server - ((and (not (remote-server-url *runremote*)) + + ;; commented by bb; this was blocking server passive start on write on homehost (case 5) + ;; ;; on homehost and this is a write, we have a server (we know because case 4 checked) + ;; ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ;; (not (member cmd api:read-only-queries))) + ;; (mutex-unlock! *rmt-mutex*) + ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") + ;; (rmt:open-qry-close-locally cmd 0 params)) + + + ;; on homehost, no server contact made and this is a write, passively start a server + ((and (cdr (remote-hh-dat *runremote*)) ; new + (not (remote-server-url *runremote*)) (not (member cmd api:read-only-queries))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") - (let ((serverconn (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call - (if serverconn - (remote-server-url-set! *runremote* serverconn) ;; the string can be consumed by the client setup if needed + (let ((server-url (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call + (if server-url + (remote-server-url-set! *runremote* server-url) ;; the string can be consumed by the client setup if needed (if (not (server:start-attempted? *toppath*)) (server:kind-run *toppath*)))) - (if (cdr (remote-hh-dat *runremote*)) ;; we are on the homehost, just do the call - (begin - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1") - (rmt:open-qry-close-locally cmd 0 params)) - (begin ;; not on homehost, start server and wait - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.2") - (tasks:start-and-wait-for-server (tasks:open-db) 0 15) - (rmt:send-receive cmd rid params attemptnum: attemptnum)))) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1") + (rmt:open-qry-close-locally cmd 0 params)) + + + + ;;; + ;; (begin ;; not on homehost, start server and wait + ;; (mutex-unlock! *rmt-mutex*) + ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.2") + ;; (tasks:start-and-wait-for-server (tasks:open-db) 0 15) + ;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;) ;) +;;;; + ;; if not on homehost ensure we have a connection to a live server ;; NOTE: we *have* a homehost record by now - ((and (not (cdr (remote-hh-dat *runremote*))) ;; are we on a homehost? + + ;; ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost + ;; (not (remote-conndat *runremote*)) ;; and no connection + ;; (server:read-dotserver *toppath*)) ;; .server file exists + ;; ;; something caused the server entry in tdb to disappear, but the server is still running + ;; (server:remove-dotserver-file *toppath* ".*") + ;; (mutex-unlock! *rmt-mutex*) + ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20") + ;; (rmt:send-receive cmd rid params attemptnum: (add1 attemptnum))) + + ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost (not (remote-conndat *runremote*))) ;; and no connection (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*)) (mutex-unlock! *rmt-mutex*) (tasks:start-and-wait-for-server (tasks:open-db) 0 15) - (remote-conndat-set! *runremote* (rmt:get-connection-info 0)) ;; calls client:setup which calls client:setup-http - (rmt:send-receive cmd rid params attemptnum: attemptnum)) + (remote-conndat-set! *runremote* (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http + (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as ;; all set up if get this far, dispatch the query ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 7") (rmt:open-qry-close-locally cmd (if rid rid 0) params)) + ;; not on homehost, do server query (else (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") + (mutex-lock! *rmt-mutex*) (let* ((conninfo (remote-conndat *runremote*)) (dat (case (remote-transport *runremote*) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away (http-transport:client-api-send-receive 0 conninfo cmd params) ((commfail)(vector #f "communications fail")) @@ -156,44 +181,48 @@ (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported") (exit)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat) + ;; (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " *runremote* = "*runremote*) (if success (case (remote-transport *runremote*) - ((http) res) + ((http) + (mutex-unlock! *rmt-mutex*) + res) (else (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown") + (mutex-unlock! *rmt-mutex*) (exit 1))) (begin (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) (remote-conndat-set! *runremote* #f) (remote-server-url-set! *runremote* #f) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") + (mutex-unlock! *rmt-mutex*) (tasks:start-and-wait-for-server (tasks:open-db) 0 15) (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) -(define (rmt:update-db-stats run-id rawcmd params duration) - (mutex-lock! *db-stats-mutex*) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) - #f) ;; if this fails we don't care, it is just stats - (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) - (stat-vec (hash-table-ref/default *db-stats* cmd #f))) - (if (not (vector? stat-vec)) - (let ((newvec (vector 0 0))) - (hash-table-set! *db-stats* cmd newvec) - (set! stat-vec newvec))) - (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) - (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) - (mutex-unlock! *db-stats-mutex*)) - +;; (define (rmt:update-db-stats run-id rawcmd params duration) +;; (mutex-lock! *db-stats-mutex*) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") +;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) +;; (print "exn=" (condition->list exn)) +;; #f) ;; if this fails we don't care, it is just stats +;; (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) +;; (stat-vec (hash-table-ref/default *db-stats* cmd #f))) +;; (if (not (vector? stat-vec)) +;; (let ((newvec (vector 0 0))) +;; (hash-table-set! *db-stats* cmd newvec) +;; (set! stat-vec newvec))) +;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) +;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) +;; (mutex-unlock! *db-stats-mutex*)) (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* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) @@ -257,11 +286,11 @@ ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) - (set! *db-last-write* start-time) ;; the oldest "write" + (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) @@ -320,10 +349,15 @@ ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) + +;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host +(define (rmt:get-latest-host-load hostname) + (rmt:send-receive 'get-latest-host-load 0 (list hostname))) + ;; (define (rmt:sync-inmem->db run-id) ;; (rmt:send-receive 'sync-inmem->db run-id '())) (define (rmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr @@ -330,10 +364,17 @@ (rmt:send-receive 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) + +;;====================================================================== +;; T E S T M E T A +;;====================================================================== + +(define (rmt:get-tests-tags) + (rmt:send-receive 'get-tests-tags #f '())) ;;====================================================================== ;; K E Y S ;;====================================================================== @@ -345,10 +386,15 @@ (define (rmt:get-keys) (if *db-keys* *db-keys* (let ((res (rmt:send-receive 'get-keys #f '()))) (set! *db-keys* res) res))) + +(define (rmt:get-keys-write) ;; dummy query to force server start + (let ((res (rmt:send-receive 'get-keys-write #f '()))) + (set! *db-keys* res) + res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; (define (rmt:get-key-vals run-id) @@ -460,12 +506,12 @@ ;; This is not needed as test steps are deleted on test delete call ;; ;; (define (rmt:delete-test-step-records run-id test-id) ;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) -(define (rmt:test-set-status-state run-id test-id status state msg) - (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg))) +(define (rmt:test-set-state-status run-id test-id state status msg) + (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (rmt:test-toplevel-num-items run-id test-name) (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) @@ -524,12 +570,12 @@ (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; -(define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status comment) - (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status comment))) +(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) + (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) (define (rmt:update-pass-fail-counts run-id test-name) (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -176,11 +176,11 @@ (if ping-res (let ((server-dat (list iface port #f #f #f))) (hash-table-set! *runremote* run-id server-dat) server-dat) (begin - (server:try-running run-id) + (server:try-running *toppath*) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))) (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-db-info @@ -191,15 +191,15 @@ (if start-res (begin (hash-table-set! *runremote* run-id server-dat) server-dat) (begin - (server:try-running run-id) + (server:try-running *toppath*) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))) (begin - (server:try-running run-id) + (server:try-running *toppath*) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))))))) ;; ;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) ;; (if (and port Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -928,11 +928,11 @@ (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL + (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying @@ -1673,10 +1673,11 @@ ((remove-runs) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) + ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) @@ -1958,10 +1959,23 @@ (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) + +;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." +;; +(define (runs:get-tests-matching-tags tagpatt) + (let* ((tagdata (rmt:get-tests-tags)) + (res '())) ;; list of tests that match one or more tags + (for-each + (lambda (tag) + (if (patt-list-match tag tagpatt) + (set! res (append (hash-table-ref tagdata tag))))) + (hash-table-keys tagdata)) + res)) + ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each ADDED sample-sauth-paths.scm Index: sample-sauth-paths.scm ================================================================== --- /dev/null +++ sample-sauth-paths.scm @@ -0,0 +1,4 @@ +(define *db-path* "/path/to/db") +(define *exe-path* "/path/to/store/suids") +(define *exe-src* "/path/to/spublish/and/sretrieve/executables") +(define *sauth-path* "/path/to/production/sauthorize/exe") ADDED sauth-common.scm Index: sauth-common.scm ================================================================== --- /dev/null +++ sauth-common.scm @@ -0,0 +1,263 @@ + +;; Create the sqlite db +(define (sauthorize:db-do proc) + (if (or (not *db-path*) + (not (file-exists? *db-path*))) + (begin + (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!") + (exit 1))) + (if (and *db-path* + (directory? *db-path*) + (file-read-access? *db-path*)) + (let* ((dbpath (conc *db-path* "/sauthorize.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit 1)) + ; (print "calling proc " proc "db path " dbpath ) + (call-with-database + dbpath + (lambda (db) + ;(print 0 "calling proc " proc " on db " db) + (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout + (if (not dbexists)(sauthorize:initialize-db db)) + (proc db))))) + (print 0 "ERROR: invalid path for storing database: " *db-path*))) + +;;execute a query +(define (sauthorize:db-qry db qry) + (exec (sql db qry))) + + +(define (sauthorize:do-as-calling-user proc) + (let ((eid (current-effective-user-id)) + (cid (current-user-id))) + (if (not (eq? eid cid)) ;; running suid + (set! (current-effective-user-id) cid)) + ;(print 0 "cid " cid " eid:" eid) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + + +(define (run-cmd cmd arg-list) + ; (print (current-effective-user-id)) + ;(handle-exceptions +; exn +; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert)) + (let ((pid (process-run cmd arg-list))) + (process-wait pid)) +) +;) + + +(define (regster-log inl usr-id area-id cmd) + (sauth-common:shell-do-as-adm + (lambda () + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )"))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Check user types +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;check if a user is an admin +(define (is-admin username) + (let* ((admin #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) + (if (not (null? data-row)) + (let ((col (car data-row))) + (if (equal? col "yes") + (set! admin #t))))))) +admin)) + + +;;check if a user is an read-admin +(define (is-read-admin username) + (let* ((admin #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) + (if (not (null? data-row)) + (let ((col (car data-row))) + (if (equal? col "read-admin") + (set! admin #t))))))) +admin)) + + +;;check if user has specifc role for a area +(define (is-user role username area) + (let* ((has-access #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'"))))) + (if (not (null? data-row)) + (begin + (let* ((access-type (car data-row)) + (exdate (cadr data-row))) + (if (not (null? exdate)) + (begin + (let ((valid (is-access-valid exdate))) + ;(print valid) + (if (and (equal? access-type role) + (equal? valid #t)) + (set! has-access #t)))) + (print "Access expired")))))))) + ;(print has-access) +has-access)) + +(define (is-access-valid exp-str) + (let* ((ret-val #f ) + (date-parts (string-split exp-str "/")) + (yr (string->number (car date-parts))) + (month (string->number(car (cdr date-parts)))) + (day (string->number(caddr date-parts))) + (exp-date (make-date 0 0 0 0 day month yr ))) + ;(print exp-date) + ;(print (current-date)) + (if (> (date-compare exp-date (current-date)) 0) + (set! ret-val #t)) + ;(print ret-val) + ret-val)) + + +;check if area exists +(define (area-exists area) + (let* ((area-defined #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) + (if (not (null? data-row)) + (set! area-defined #t))))) +area-defined)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Get Record from database +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;gets area id by code +(define (get-area area) + (let* ((area-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) + (set! area-defined data-row)))) +area-defined)) + +;get id of users table by user name +(define (get-user user) + (let* ((user-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'"))))) + (set! user-defined data-row)))) +user-defined)) + +;get permissions id by userid and area id +(define (get-perm userid areaid) + (let* ((user-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid))))) + (set! user-defined data-row)))) + +user-defined)) + +(define (get-restrictions base-path usr) +(let* ((user-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'"))))) + ;(print data-row) + (set! user-defined data-row)))) + ; (print user-defined) + (if (null? user-defined) + "" + (car user-defined)))) + + +(define (get-obj-by-path path) + (let* ((obj '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'"))))) + (set! obj data-row)))) +obj)) + +(define (get-obj-by-code code ) + (let* ((obj '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'"))))) + (set! obj data-row)))) +;(print obj) +obj)) + + + +;; function to validate the users input for target path and resolve the path +;; TODO: Check for restriction in subpath +(define (sauth-common:resolve-path new current allowed-sheets) + (let* ((target-path (append current (string-split new "/"))) + (target-path-string (string-join target-path "/")) + (normal-path (normalize-pathname target-path-string)) + (normal-list (string-split normal-path "/")) + (ret '())) + (if (string-contains normal-path "..") + (begin + (print "ERROR: Path " new " resolved outside target area ") + #f) + (if(equal? normal-path ".") + ret + (if (not (member (car normal-list) allowed-sheets)) + (begin + (print "ERROR: Permision denied to " new ) + #f) + normal-list))))) + +(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )) + (usr (current-user-name) ) ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + #f + (let* ((sheet (car resolved-path)) + (restricted-areas (get-restrictions base-path usr)) + (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*")) + (target-path (if (null? (cdr resolved-path)) + base-path + (conc base-path "/" (string-join (cdr resolved-path) "/"))))) + ; (print restricted-areas) + (if (and (not (equal? restricted-areas "" )) + (string-match (regexp restrictions) target-path)) + (begin + (print "Access denied to " (string-join resolved-path "/")) + ;(exit 1) + #f) + target-path))) + #f))) + +(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) + (if (and (null? base-path-list) (equal? ext-path "") ) + (print (string-intersperse top-areas " ")) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))) + ;(print resolved-path) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print (string-intersperse top-areas " ")) + (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path))) + (print target-path) + (if (not (equal? target-path #f)) + (begin + (cond + ((null? tail-cmd-list) + (run (pipe + (ls "-lrt" ,target-path)))) + ((not (equal? (car tail-cmd-list) "|")) + (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!")) + (else + (run (pipe + (ls "-lrt" ,target-path) + (begin (system (string-join (cdr tail-cmd-list)))))) + ) +))) +)))))) + ADDED sauthorize.scm Index: sauthorize.scm ================================================================== --- /dev/null +++ sauthorize.scm @@ -0,0 +1,566 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use defstruct) +(use scsh-process) + +(use srfi-18) +(use srfi-19) +(use refdb) + +(use sql-de-lite srfi-1 posix regex regex-case srfi-69) +(declare (uses common)) + +(declare (uses configf)) +(declare (uses margs)) +(declare (uses megatest-version)) + +(include "megatest-fossil-hash.scm") +;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. +(include "sauth-paths.scm") +(include "sauth-common.scm") + +;; +;; GLOBALS +;; +(define *verbosity* 1) +(define *logging* #f) +(define *exe-name* (pathname-file (car (argv)))) +(define *sretrieve:current-tab-number* 0) +(define *args-hash* (make-hash-table)) +(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]] + + list : list areas $USER's can access + log : get listing of recent activity. + sauth list-area-user : list the users that can access the area. + sauth open --group : Open up an area. User needs to be the owner of the area to open it. + --code + --retrieve|--publish + sauth grant --area : Grant permission to read or write to a area that is alrady opend up. + --expiration yyyy/mm/dd --retrieve|--publish + [--restrict ] + sauth read-shell : Open sretrieve shell for reading. + sauth write-shell : Open spublish shell for writing. + +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) ;; " + +;;====================================================================== +;; RECORDS +;;====================================================================== + +;;====================================================================== +;; DB +;;====================================================================== + +;; replace (strftime('%s','now')), with datetime('now')) +(define (sauthorize:initialize-db db) + (for-each + (lambda (qry) + (exec (sql db qry))) + (list + "CREATE TABLE IF NOT EXISTS actions + (id INTEGER PRIMARY KEY, + cmd TEXT NOT NULL, + user_id INTEGER NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')), + area_id INTEGER NOT NULL, + comment TEXT DEFAULT '' NOT NULL, + action_type TEXT NOT NULL);" + "CREATE TABLE IF NOT EXISTS users + (id INTEGER PRIMARY KEY, + username TEXT NOT NULL, + is_admin TEXT NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')) + );" + "CREATE TABLE IF NOT EXISTS areas + (id INTEGER PRIMARY KEY, + basepath TEXT NOT NULL, + code TEXT NOT NULL, + exe_name TEXT NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')) + );" + "CREATE TABLE IF NOT EXISTS permissions + (id INTEGER PRIMARY KEY, + access_type TEXT NOT NULL, + user_id INTEGER NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')), + area_id INTEGER NOT NULL, + restriction TEXT DEFAULT '' NOT NULL, + expiration TIMESTAMP DEFAULT NULL);" + ))) + + + + +(define (get-access-type args) + (let loop ((hed (car args)) + (tal (cdr args))) + (cond + ((equal? hed "--retrieve") + "retrieve") + ((equal? hed "--publish") + "publish") + ((equal? hed "--area-admin") + "area-admin") + ((equal? hed "--writer-admin") + "writer-admin") + ((equal? hed "--read-admin") + "read-admin") + + ((null? tal) + #f) + (else + (loop (car tal)(cdr tal)))))) + + + +;; check if user can gran access to an area +(define (can-grant-perm username access-type area) + (let* ((isadmin (is-admin username)) + (is-area-admin (is-user "area-admin" username area )) + (is-read-admin (is-user "read-admin" username area) ) + (is-writer-admin (is-user "writer-admin" username area) ) ) + (cond + ((equal? isadmin #t) + #t) + ((equal? is-area-admin #t ) + #t) + ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve")) + #t) + ((and (equal? is-read-admin #t ) (equal? access-type "retrieve")) + #t) + + (else + #f)))) + +(define (sauthorize:list-areausers area ) + (sauthorize:db-do (lambda (db) + (print "Users having access to " area ":") + (query (for-each-row + (lambda (row) + (let* ((exp-date (cadr row))) + (if (is-access-valid exp-date) + (apply print (intersperse row " | ")))))) + (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'")))))) + + + + +; check if executable exists +(define (exe-exist exe access-type) + (let* ((filepath (conc *exe-path* "/" access-type "/" exe))) + ; (print filepath) + (if (file-exists? filepath) + #t + #f))) + +(define (copy-exe access-type exe-name group) + (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type))) + (let* ((spath (conc *exe-src* "/s" access-type)) + (dpath (conc *exe-path* "/" access-type "/" exe-name))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd "/bin/cp" (list spath dpath )) + (if (equal? access-type "publish") + (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) + (begin + (if (equal? group "none") + (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) + (begin + (run-cmd "/bin/chgrp" (list group dpath)) + (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath)))))))) + (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type))))) + +(define (get-exe-name path group) + (let ((name "")) + (sauthorize:do-as-calling-user + (lambda () + (if (equal? (current-effective-user-id) (file-owner path)) + (set! name (conc (current-user-name) "_" group)) + (begin + (print "You cannot open areas that you dont own!!") + (exit 1))))) +name)) + +(define (sauthorize:valid-unix-user username) + (let* ((ret-val #f)) + (let-values (((inp oup pid) + (process "/usr/bin/id" (list username)))) + (let loop ((inl (read-line inp))) + (if (string? inl) + (if (string-contains inl "No such user") + (set! ret-val #f) + (set! ret-val #t))) + (if (eof-object? inl) + (begin + (close-input-port inp) + (close-output-port oup)) + (loop (read-line inp))))) + ret-val)) + + +;check if a paths/codes are vaid and if area is alrady open +(define (open-area group path code access-type) + (let* ((exe-name (get-exe-name path group)) + (path-obj (get-obj-by-path path)) + (code-obj (get-obj-by-code code))) + ;(print path-obj) + (cond + ((not (null? path-obj)) + (if (equal? code (car path-obj)) + (begin + (if (equal? exe-name (cadr path-obj)) + (begin + (if (not (exe-exist exe-name access-type)) + (copy-exe access-type exe-name group) + (begin + (print "Area already open!!") + (exit 1)))) + (begin + (if (not (exe-exist exe-name access-type)) + (copy-exe access-type exe-name group)) + ;; update exe-name in db + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj))))) + ))) + (begin + (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type ) + (exit 1)))) + + ((not (null? code-obj)) + (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) + (exit 1)) + (else + ; (print (exe-exist exe-name access-type)) + (if (not (exe-exist exe-name access-type)) + (copy-exe access-type exe-name group)) + (sauthorize:db-do (lambda (db) + ;(print (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")) + (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")))))))) + +(define (user-has-open-perm user path access) + (let* ((has-access #f) + (eid (current-user-id))) + (cond + ((is-admin user) + (set! has-access #t )) + ((and (is-read-admin user) (equal? access "retrieve")) + (set! has-access #t )) + (else + (print "User " user " does not have permission to open areas"))) + has-access)) + + +;;check if user has group access +(define (is-group-washed req_grpid current-grp-list) + (let loop ((hed (car current-grp-list)) + (tal (cdr current-grp-list))) + (cond + ((equal? hed req_grpid) + #t) + ((null? tal) + #f) + (else + (loop (car tal)(cdr tal)))))) + +;create executables with appropriate suids +(define (sauthorize:open user path group code access-type) + (let* ((gpid (group-information group)) + (req_grpid (if (equal? group "none") + group + (if (equal? gpid #f) + #f + (caddr gpid)))) + (current-grp-list (get-groups)) + (valid-grp (if (equal? group "none") + group + (is-group-washed req_grpid current-grp-list)))) + (if (and (not (equal? group "none")) (equal? valid-grp #f )) + (begin + (print "Group " group " is not washed in the current xterm!!") + (exit 1)))) + (if (not (file-write-access? path)) + (begin + (print "You can open areas owned by yourself. You do not have permissions to open path." path) + (exit 1))) + (if (user-has-open-perm user path access-type) + (begin + ;(print "here") + (open-area group path code access-type) + (sauthorize:grant user user code "2017/12/25" "read-admin" "") + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )")))) + (print "Area has " path " been opened for " access-type )))) + +(define (sauthorize:grant auser guser area exp-date access-type restrict) + ; check if user exist in db + (let* ((area-obj (get-area area)) + (auser-obj (get-user auser)) + (user-obj (get-user guser))) + + (if (null? user-obj) + (begin + ;; is guser a valid unix user + (if (not (sauthorize:valid-unix-user guser)) + (begin + (print "User " guser " is Invalid unix user!!") + (exit 1))) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') ")))) + (set! user-obj (get-user guser)))) + (let* ((perm-obj (get-perm (car user-obj) (car area-obj)))) + (if(null? perm-obj) + (begin + ;; insert permissions + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')"))))) + (begin + ;update permissions + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj))))))) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )")))) + (print "Permission has been sucessfully granted to user " guser)))) + +(define (sauthorize:process-action username action . args) + (case (string->symbol action) + ((grant) + (if (< (length args) 6) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0)) + (guser (car args)) + (restrict (or (args:get-arg "--restrict") "")) + (area (or (args:get-arg "--area") "")) + (exp-date (or (args:get-arg "--expiration") "")) + (access-type (get-access-type remargs))) + ; (print "version " guser " restrict " restrict ) + ; (print "area " area " exp-date " exp-date " access-type " access-type) + (cond + ((equal? guser "") + (print "Username not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? area "") + (print "Area not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? access-type #f) + (print "Access type not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? exp-date "") + (print "Date of expiration not found!! Try \"sauthorize help\" for useage ") + (exit 1))) + (if (not (area-exists area)) + (begin + (print "Area does not exisit!!") + (exit 1))) + (if (can-grant-perm username access-type area) + (begin + (print "calling sauthorize:grant ") + (sauthorize:grant username guser area exp-date access-type restrict)) + (begin + (print "User " username " does not have permission to grant permissions to area " area "!!") + (exit 1))))) + ((list-area-user) + (if (not (equal? (length args) 1)) + (begin + (print "Missing argument area code to list-area-user ") + (exit 1))) + (let* ((area (car args))) + (if (not (area-exists area)) + (begin + (print "Area does not exisit!!") + (exit 1))) + + (sauthorize:list-areausers area ) + )) + ((read-shell) + (if (not (equal? (length args) 1)) + (begin + (print "Missing argument area code to read-shell ") + (exit 1))) + (let* ((area (car args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "retrieve"))) + (begin + (print "Area " area " is not open for reading!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area )))))) + ((write-shell) + (if (not (equal? (length args) 1)) + (begin + (print "Missing argument area code to read-shell ") + (exit 1))) + (let* ((area (car args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "publish"))) + (begin + (print "Area " area " is not open for Writing!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area)))))) + ((publish) + (if (< (length args) 2) + (begin + (print "Missing argument to publish. \n publish [opts] ") + (exit 1))) + (let* ((action (car args)) + (area (cadr args)) + (cmd-args (cddr args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "publish"))) + (begin + (print "Area " area " is not open for writing!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) + + ((retrieve) + (if (< (length args) 2) + (begin + (print "Missing argument to publish. \n publish [opts] ") + (exit 1))) + (let* ((action (car args)) + (area (cadr args)) + (cmd-args (cddr args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "retrieve"))) + (begin + (print "Area " area " is not open for reading!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) + + + + ((open) + (if (< (length args) 6) + (begin + (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open --group --code --retrieve|--publish") + (exit 1))) + (let* ((remargs (args:get-args args '("--group" "--code") '() args:arg-hash 0)) + (path (car args)) + (group (or (args:get-arg "--group") "")) + (area (or (args:get-arg "--code") "")) + (access-type (get-access-type remargs))) + (cond + ((equal? path "") + (print "path not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? area "") + (print "--code not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? access-type #f) + (print "Access type not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((and (not (equal? access-type "publish")) + (not (equal? access-type "retrieve"))) + (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ") + (exit 1))) + + (sauthorize:open username path group area access-type))) + ((area-admin) + (let* ((usr (car args)) + (usr-obj (get-user usr)) + (user-id (car (get-user username)))) + + (if (is-admin username) + (begin + ; (print usr-obj) + (if (null? usr-obj) + (begin + (sauthorize:db-do (lambda (db) + ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")) + (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))))) + (begin + ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) )) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj))))))) + (print "User " usr " is updated with area-admin access!")) + (print "Admin only function")) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) + + ((register-log) + (if (< (length args) 4) + (print "Invalid arguments")) + ;(print args) + (let* ((cmd-line (car args)) + (user-id (cadr args)) + (area-id (caddr args)) + (user-obj (get-user username)) + (cmd (cadddr args))) + + (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj)))) + (begin + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" ))))) + (print "You ar not authorised to run this cmd") + +))) + + + (else (print 0 "Unrecognised command " action)))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (username (current-user-name))) + ;; preserve the exe data in the config file + (cond + ;; one-word commands + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((help -h -help --h --help) + (print sauthorize:help)) + ((list) + + (sauthorize:db-do (lambda (db) + (print "My Area accesses: ") + (query (for-each-row + (lambda (row) + (let* ((exp-date (car row))) + (if (is-access-valid exp-date) + (apply print (intersperse (cdr row) " | ")))))) + (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'")))))) + + ((log) + (sauthorize:db-do (lambda (db) + (print "Logs : ") + (query (for-each-row + (lambda (row) + + (apply print (intersperse row " | ")))) + (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id "))))) + (else + (print "ERROR: Unrecognised command. Try \"sauthorize help\"")))) + ;; multi-word commands + ((null? rema)(print sauthorize:help)) + ((>= (length rema) 2) + (apply sauthorize:process-action username (car rema)(cdr rema))) + (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\""))))) + +(main) + + + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras) ;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -47,16 +47,33 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch run-id transport-type) - (BB> "server:launch fired for run-id="run-id" transport-type="transport-type) + ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type) + + (let ((attempt-in-progress (server:start-attempted? *toppath*))) ; check for .server-starting + (when attempt-in-progress + (debug:print-info 0 *default-log-port* "Server start attempt in progress in other process (=> "attempt-in-progress"<=). Aborting server launch attempt in this process ("(current-process-id)")") + (exit))) + + (let ((dotserver-url (server:check-if-running *toppath*))) ;; check for .server + (when dotserver-url + (debug:print-info 0 *default-log-port* "Server already running (=> "dotserver-url"<=). Aborting server launch attempt in this process ("(current-process-id)")") + (exit) + )) + (case transport-type ((http)(http-transport:launch run-id)) ;;((nmsg)(nmsg-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id)) - (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))) + (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))) + + ;; is this a good place to print server exit stats? + (debug:print 0 "SERVER: max parallel api requests: " *max-api-process-requests*) + + ) ;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S @@ -103,52 +120,60 @@ ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; -(define (server:run areapath) ;; areapath is ignored for now. +(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area (let* ((curr-host (get-host-name)) + (attempt-in-progress (server:start-attempted? areapath)) + (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) - (logfile (conc *toppath* "/logs/server.log")) + (logfile (conc areapath "/logs/server.log")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))) ;; we want the remote server to start in *toppath* so push there - (push-directory *toppath*) - (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") - (thread-start! log-rotate) - - ;; host.domain.tld match host? - (if (and target-host - ;; look at target host, is it host.domain.tld or ip address and does it - ;; match current ip or hostname - (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) - (not (equal? curr-ip target-host))) - (begin - (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) - (setenv "TARGETHOST" target-host))) - - (setenv "TARGETHOST_LOGF" logfile) - (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever - (system (conc "nbfake " cmdln)) - (unsetenv "TARGETHOST_LOGF") - (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) - (thread-join! log-rotate) - (pop-directory))) - + (push-directory areapath) + (cond + (attempt-in-progress + (debug:print 0 *default-log-port* "INFO: Not trying to start server because attempt is in progress: "attempt-in-progress)) + (dot-server-url + (debug:print 0 *default-log-port* "INFO: Not trying to start server because one is already running : "dot-server-url)) + (else + (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") + (thread-start! log-rotate) + + ;; host.domain.tld match host? + (if (and target-host + ;; look at target host, is it host.domain.tld or ip address and does it + ;; match current ip or hostname + (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) + (not (equal? curr-ip target-host))) + (begin + (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) + (setenv "TARGETHOST" target-host))) + + (setenv "TARGETHOST_LOGF" logfile) + (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever + (system (conc "nbfake " cmdln)) + (unsetenv "TARGETHOST_LOGF") + (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) + (thread-join! log-rotate) + (pop-directory))))) + (define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) - (set! *my-client-signature* sig) - *my-client-signature*))) + (set! *my-client-signature* sig) + *my-client-signature*))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run areapath) (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f))) @@ -156,96 +181,168 @@ (> (- (current-seconds) last-run-time) 30)) (begin (server:run areapath) (hash-table-set! *server-kind-run* areapath (current-seconds)))))) -;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 -;; -;; (define (server:try-running run-id) -;; (if (eq? run-id 0) -;; (server:run run-id) -;; (rmt:start-server run-id))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. +(define (server:attempting-start areapath) + (with-output-to-file + (conc areapath "/.starting-server") + (lambda () + (print (current-process-id) " on " (get-host-name))))) + +(define (server:complete-attempt areapath) + (delete-file* (conc areapath "/.starting-server"))) + (define (server:start-attempted? areapath) (let ((flagfile (conc areapath "/.starting-server"))) (handle-exceptions exn #f ;; if things go wrong pretend we can't see the file - (and (file-exists? flagfile) - (< (- (current-seconds) - (file-modification-time flagfile)) - 15))))) ;; exists and less than 15 seconds old - + (cond + ((and (file-exists? flagfile) + (< (- (current-seconds) + (file-modification-time flagfile)) + 15)) ;; exists and less than 15 seconds old + (with-input-from-file flagfile (lambda () (read-line)))) + ((file-exists? flagfile) ;; it is stale. + (server:complete-attempt areapath) + #f) + (else #f))))) + (define (server:read-dotserver areapath) (let ((dotfile (conc areapath "/.server"))) (handle-exceptions exn #f ;; if things go wrong pretend we can't see the file - (if (and (file-exists? dotfile) - (file-read-access? dotfile)) - (with-input-from-file - dotfile - (lambda () - (read-line))) - #f)))) + (cond + ((not (file-exists? dotfile)) + #f) + ((not (file-read-access? dotfile)) + #f) + ((> (server:dotserver-age-seconds areapath) (+ 5 (server:get-timeout))) + (server:remove-dotserver-file areapath ".*") + #f) + (else + (let* ((line + (with-input-from-file + dotfile + (lambda () + (read-line)))) + (tokens (if (string? line) (string-split line ":") #f))) + (cond + ((eq? 4 (length tokens)) + tokens) + (else #f)))))))) + +(define (server:read-dotserver->url areapath) + (let ((dotserver-tokens (server:read-dotserver areapath))) + (if dotserver-tokens + (conc (list-ref dotserver-tokens 0) ":" (list-ref dotserver-tokens 1)) + #f))) ;; write a .server file in *toppath* with hostport ;; return #t on success, #f otherwise ;; -(define (server:write-dotserver areapath hostport) +(define (server:write-dotserver areapath host port pid transport) (let ((lock-file (conc areapath "/.server.lock")) (server-file (conc areapath "/.server"))) (if (common:simple-file-lock lock-file) (let ((res (handle-exceptions exn #f ;; failed for some reason, for the moment simply return #f (with-output-to-file server-file (lambda () - (print hostport))) + (print (conc host ":" port ":" pid ":" transport)))) #t))) - (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " created") + (debug:print-info 0 *default-log-port* "server file " server-file " for " host ":" port " created pid="pid) (common:simple-file-release-lock lock-file) res) #f))) + +;; this will check that the .server file present matches the server calling this procedure. +;; if parameters match (this-pid and transport) the file will be touched and #t returned +;; otherwise #f will be returned. +(define (server:confirm-dotserver areapath this-iface this-port this-pid this-transport) + (let* ((tokens (server:read-dotserver areapath))) + (cond + ((not tokens) + (debug:print-info 0 *default-log-port* "INFO: .server file does not exist.") + #f) + ((not (eq? 4 (length tokens))) + (debug:print-info 0 *default-log-port* "INFO: .server file is corrupt. There are not 4 tokens as expeted; there are "(length tokens)".") + #f) + ((not (equal? this-iface (list-ref tokens 0))) + (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for iface, server has value >"(list-ref tokens 0)"< but this server's value is >"this-iface"<") + #f) + ((not (equal? (->string this-port) (list-ref tokens 1))) + (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for port, .server has value >"(list-ref tokens 1)"< but this server's value is >"(->string this-port)"<") + #f) + ((not (equal? (->string this-pid) (list-ref tokens 2))) + (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for pid, .server has value >"(list-ref tokens 2)"< but this server's value is >"(->string this-pid)"<") + #f) + ((not (equal? (->string this-transport) (->string (list-ref tokens 3)))) + (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for transport, .server has value >"(list-ref tokens 3)"< but this server's value is >"this-transport"<") + #f) + (else (server:touch-dotserver areapath) + #t)))) + +(define (server:touch-dotserver areapath) + (let ((server-file (conc areapath "/.server"))) + (change-file-times server-file (current-seconds) (current-seconds)))) + +(define (server:dotserver-age-seconds areapath) + (let ((server-file (conc areapath "/.server"))) + (begin + (handle-exceptions + exn + #f + (- (current-seconds) + (file-modification-time server-file)))))) + (define (server:remove-dotserver-file areapath hostport) - (let ((dotserver (server:read-dotserver areapath)) + (let ((dotserver-url (server:read-dotserver->url areapath)) (server-file (conc areapath "/.server")) (lock-file (conc areapath "/.server.lock"))) - (if (and dotserver (string-match (conc ".*:" hostport "$") dotserver)) ;; port matches, good enough info to decide to remove the file + (if (and dotserver-url (string-match (conc ".*:" hostport "$") dotserver-url)) ;; port matches, good enough info to decide to remove the file (if (common:simple-file-lock lock-file) (begin (handle-exceptions exn #f (delete-file* server-file)) (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed") - (common:simple-file-release-lock lock-file)))))) + (common:simple-file-release-lock lock-file)) + (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - could not get lock.")) + (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - dotserver-url("dotserver-url") did not match hostport pattern ("hostport")")))) ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; (define (server:check-if-running areapath) - (let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db))) - (if dotserver + (let* ((dotserver-url (server:read-dotserver->url areapath))) ;; tdbdat (tasks:open-db))) + (if dotserver-url (let* ((res (case *transport-type* - ((http)(server:ping-server dotserver)) + ((http)(server:ping-server dotserver-url)) ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) ))) (if res - dotserver - #f)) + dotserver-url + (begin + (server:remove-dotserver-file areapath ".*") ;; remove stale dotserver + #f))) #f))) ;; called in megatest.scm, host-port is string hostname:port ;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running ;; in the same process as the server. ;; (define (server:ping host-port-in #!key (do-exit #f)) (let ((host:port (if (not host-port-in) ;; use read-dotserver to find - (server:read-dotserver *toppath*) + (server:read-dotserver->url *toppath*) (if (number? host-port-in) ;; we were handed a server-id (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in))) ;; (print "srec: " srec " host-port-in: " host-port-in) (if srec (conc (vector-ref srec 3) ":" (vector-ref srec 4)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -323,12 +323,12 @@ (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) mdb - (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") - run-id) + (conc "SELECT " selstr " FROM servers WHERE state in ('available','running','dbprep') ORDER BY start_time DESC;") + ) (vector header res))) (define (tasks:get-server mdb run-id #!key (retries 10)) (let ((res #f) (best #f)) @@ -402,11 +402,11 @@ (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) (debug:print 0 *default-log-port* "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) - (server:kind-run run-id) + (server:kind-run *toppath*) (thread-sleep! (min delay-time 1)) (if (not (or (server:start-attempted? *toppath*) (server:read-dotserver *toppath*))) ;; no point in trying (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)) #f)) @@ -448,14 +448,16 @@ (reverse res))) ;; no elegance here ... ;; (define (tasks:kill-server hostname pid #!key (kill-switch "")) + (server:remove-dotserver-file *toppath* ".*") (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill "kill-switch" "pid)) + (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) ;; look up a server by run-id and send it a kill, also delete the record for that server ;; @@ -466,10 +468,11 @@ (let ((hostname (vector-ref sdat 6)) (pid (vector-ref sdat 5)) (server-id (vector-ref sdat 0))) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") (debug:print-info 0 *default-log-port* "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) + (server:remove-dotserver-file *toppath* ".*") (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) (debug:print-info 0 *default-log-port* "No server found for run-id " run-id ", nothing to kill")) ;; (sqlite3:finalize! tdb) )) @@ -780,11 +783,11 @@ (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) ;; (handle-exceptions ;; exn ;; '() ;; (sqlite3:first-row - (let ((db (db:delay-if-busy (db:get-db dbstruct #f))) + (let ((db (db:delay-if-busy (db:get-db dbstruct))) (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (cons a b) res))) db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -141,11 +141,11 @@ ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry) - (let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs))) + (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) @@ -291,11 +291,11 @@ ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) - (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) + (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr (db:test-get-rundir testdat)) ;; ) (prev-rundir ;; (sdb:qry 'passstr (db:test-get-rundir prev-testdat)) ;; ) (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) @@ -351,15 +351,10 @@ (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) -(define (tests:test-force-state-status! run-id test-id state status) - (rmt:test-set-status-state run-id test-id status state #f) - ;; (rmt:roll-up-pass-fail-counts run-id test-name item - (mt:process-triggers run-id test-id state status)) - ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (rmt:get-test-info-by-id run-id test-id)) @@ -396,12 +391,12 @@ (debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin - (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) - ;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-status-state + (rmt:set-state-status-and-roll-up-items run-id test-id item-path state real-status (if waived waived comment)) + ;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-state-status )) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. ;; (if (and test-id state status (equal? status "AUTO")) @@ -442,12 +437,12 @@ ;; 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)))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (if (not (equal? item-path "")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path state status #f)) + ;;;;;; (if (not (equal? item-path "")) + ;;;;;; (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) @@ -481,12 +476,11 @@ (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) (print "Obtained lock for " outputfilename) - (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f #f) - ;; (rmt:test-set-status-state run-id test-name #f #f #f) ;; (rmt:top-test-set-per-pf-counts run-id test-name) + (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) (if script (system (conc script " > " outputfilename " & ")) (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf) (change-directory orig-dir) @@ -979,11 +973,11 @@ ;; 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" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; -(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)) (let* ((cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read (file-exists? cache-file))) @@ -991,14 +985,17 @@ cache-exists) (handle-exceptions exn #f ;; any issues, just give up with the cached version and re-read (configf:read-alist cache-file)) - #f))) + #f)) + (test-full-name (if (and item-path (not (string-null? item-path))) + (conc test-name "/" item-path) + test-name))) (if cached-dat cached-dat - (let ((dat (hash-table-ref/default *testconfigs* test-name #f))) + (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f))) (if (and dat ;; have a locally cached version (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? dat ;; no cached data available (let* ((treg (or test-registry @@ -1012,11 +1009,11 @@ environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data - (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) + (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) @@ -1240,11 +1237,12 @@ (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car 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* "hed=" hed " at top of loop") - (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) + ;; don't know item-path at this time, let the testconfig get the top level testconfig + (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -5,16 +5,16 @@ NEWDASHBOARD = $(BINDIR)/newdashboard RUNNAME = a NUMTESTS = 20 all : - $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% - $(MEGATEST) -runtests % -target a/b :runname c + $(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/% + $(MEGATEST) -run -testpatt % -target a/b -runname c bigbig : for tn in a b c d;do \ - ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ + ($(MEGATEST) -run -testpatt % -target a/b -runname $tn & ) ; \ done waitonpatt : megatest -remove-runs -runname waitonpatt -target a/b -testpatt % NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8 @@ -22,17 +22,17 @@ waitonall : megatest -remove-runs -runname waitonall -target a/b -testpatt % NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop bigrun : - NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun -target a/bigrun -runname a$(shell date +%V) bigrun2 : - NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun2 -target a/bigrun2 -runname a$(shell date +%V) bigrun3 : - NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun3 -target a/bigrun3 -runname $(RUNNAME) dashboard : mkdir -p ../simpleruns $(DASHBOARD) -rows 20 & @@ -41,6 +41,6 @@ compile : (cd ../../..;make -j && make install) clean : - rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db + rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db /tmp/$(USER)/megatest_localdb/testqa .server ADDED tests/fdktestqa/testqa/local.config.example Index: tests/fdktestqa/testqa/local.config.example ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/local.config.example @@ -0,0 +1,15 @@ +[host-types] +general #MTLOWESTLOAD xena zeus + +[jobtools] +launcher nbfake +maxload 1.5 +flexi-launcher yes +# useshell no + +[setup] +launch-delay 1 +launchwait no + +[launchers] +% general Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,11 +1,13 @@ [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # launchwait no +launch-delay 0 # All these are overridden in ../fdk.config # [jobtools] # launcher nbfake # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log [include ../fdk.config] +[include local.config] Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,8 +1,8 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET -check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat +check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUNNAME.dat [logpro] check_triggers ;; (expect:error in "LogFileBody" = 0 "No errors" #/error/i) ADDED thunk-utils.scm Index: thunk-utils.scm ================================================================== --- /dev/null +++ thunk-utils.scm @@ -0,0 +1,121 @@ +(use srfi-18) + + +;; wrap a proc with a mutex so that two threads may not call proc simultaneously. +;; will catch exceptions to ensure mutex is unlocked even if exception is thrown. +;; will generate a unique mutex for proc unless one is specified with canned-mutex: option +;; +;; example 1: (define thread-safe-+ (make-synchronized-proc +)) +;; example 2: (define thread-safe-plus +;; (make-synchronized-proc +;; (lambda (x y) +;; (+ x y)))) + +(define (make-synchronized-proc proc + #!key (canned-mutex #f)) + (let* ((guard-mutex (if canned-mutex canned-mutex (make-mutex))) + (guarded-proc ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. + (lambda args + (mutex-lock! guard-mutex) + (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision with a proc that returns a pair having the first element be our flag. gensym guarantees the symbol is unique. + (res + (condition-case + (apply proc args) ;; this is what we are guarding the execution of + [x () (cons EXCEPTION x)] + ))) + (mutex-unlock! guard-mutex) + (cond + ((and (pair? res) (eq? (car res) EXCEPTION)) + (raise (cdr res))) + (else + res)))))) + guarded-proc)) + + +;; retry an operation (depends on srfi-18) +;; ================== +;; idea here is to avoid spending time on coding retrying something. Trying to be generic here. +;; +;; Exception handling: +;; ------------------- +;; if evaluating the thunk results in exception, it will be retried. +;; on last try, if final-failure-returns-actual is true, the exception will be re-thrown to caller. +;; +;; look at options below #!key to see how to configure behavior +;; +;; + +(define (retry-thunk + the-thunk + #!key ;;;; options below + (accept-result? (lambda (x) x)) ;; retry if predicate applied to thunk's result is false + (retries 4) ;; how many tries + (failure-value #f) ;; return this on final failure, unless following option is enabled: + (final-failure-returns-actual #f) ;; on failure, on the last try, just return the result, not failure-value + + (retry-delay 0.1) ;; delay between tries + (back-off-factor 1) ;; multiply retry-delay by this factor on retry + (random-delay 0.1) ;; add a random portion of this value to wait + + (chatty #f) ;; print status as we go, for debugging. + ) + + (when chatty (print) (print "Entered retry-thunk") (print "-=-=-=-=-=-")) + (let* ((guarded-thunk ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. + (lambda () + (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision + (res + (condition-case + (the-thunk) ;; this is what we are guarding the execution of + [x () (cons EXCEPTION x)] + ))) + (cond + ((and (pair? res) (eq? (car res) EXCEPTION)) + (if chatty + (print " - the-thunk threw exception >"(cdr res)"<")) + (cons 'exception (cdr res))) + (else + (if chatty + (print " - the-thunk returned result >"res"<")) + (cons 'regular-result res))))))) + + (let loop ((guarded-res (guarded-thunk)) + (retries-left retries) + (fail-wait retry-delay)) + (if chatty (print " ==========")) + (let* ((wait-time (+ fail-wait (+ (* fail-wait back-off-factor) + (* random-delay + (/ (random 1024) 1024) )))) + (res-type (car guarded-res)) + (res-value (cdr guarded-res))) + (cond + ((and (eq? res-type 'regular-result) (accept-result? res-value)) + (if chatty (print " + return result that satisfied accept-result? >"res-value"<")) + res-value) + + ((> retries-left 0) + (if chatty (print " - sleep "wait-time)) + (thread-sleep! wait-time) + (if chatty (print " + retry ["retries-left" tries left]")) + (loop (guarded-thunk) + (sub1 retries-left) + wait-time)) + + ((eq? res-type 'regular-result) + (if final-failure-returns-actual + (begin + (if chatty (print " + last try failed- return the result >"res-value"<")) + res-value) + (begin + (if chatty (print " + last try failed- return canned failure value >"failure-value"<")) + failure-value))) + + (else ;; no retries left; result was not accepted and res-type can only be 'exception + (if final-failure-returns-actual + (begin + (if chatty (print " + last try failed with exception- re-throw it >"res-value"<")) + (abort res-value)); re-raise the exception. TODO: find a way for call-history to show as though from entry to this function + (begin + (if chatty (print " + last try failed with exception- return canned failure value >"failure-value"<")) + failure-value)))))))) + ADDED utils/homehost_check.sh Index: utils/homehost_check.sh ================================================================== --- /dev/null +++ utils/homehost_check.sh @@ -0,0 +1,17 @@ +#! /bin/bash + +#exits 1 when current host is not homehost. + +if [[ ! -e .homehost ]]; then + exit 0 +fi + +homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) +hostname=$( hostname -f ) + +if [[ $homehostname == $hostname ]]; then + exit 0 +fi +echo "ERROR: this host ($homehostname) is not the megatest homehost ($hostname)" +exit 1 + Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -27,10 +27,22 @@ # echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "#!/bin/bash" > $target if [[ $cmd =~ dboard ]]; then cat >> $target <<'EOF' + +# disable if not running on homehost +if [[ -e .homehost ]]; then + homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) + hostname=$( hostname -f ) + + if [[ ! ($homehostname == $hostname) ]]; then + echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area. Cannot start dashboard." + echo " Please log into homehost before launching dashboard." + exit 1 + fi +fi # check that $DISPLAY is set if [[ -z $DISPLAY ]]; then echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' exit 1 Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -70,7 +70,7 @@ if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely - ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" + ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi Index: utils/plot-code.scm ================================================================== --- utils/plot-code.scm +++ utils/plot-code.scm @@ -8,17 +8,19 @@ ;; third param is list of files to scan (use regex srfi-69 srfi-13) (define targs #f) -(define files (cddddr (argv))) +(define files (cdr (cddddr (argv)))) (let ((targdat (cadddr (argv)))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) +(define function-patt (car (cdr (cdddr (argv))))) +(define function-rx (regexp function-patt)) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) (define all-regexs (make-hash-table)) @@ -32,10 +34,11 @@ (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", ")) (print-err "Looking at files: " (string-intersperse files ", ")) +(print-err "Function regex: " function-patt) ;; Gather the functions ;; (for-each (lambda (fname) @@ -46,16 +49,18 @@ (if (not (eof-object? inl)) (let ((match (string-match defn-rx inl))) (if match (let ((fnname (cadr match))) ;; (print " " fnname) - (set! all-fns (cons fnname all-fns)) - (hash-table-set! - filedat-defns - fname - (cons fnname (hash-table-ref/default filedat-defns fname '()))) - )) + (if (string-match function-rx fnname) + (begin + (set! all-fns (cons fnname all-fns))) + (hash-table-set! + filedat-defns + fname + (cons fnname (hash-table-ref/default filedat-defns fname '()))) + ))) (loop (read-line)))))))) files) ;; fill up the regex hash (print-err "Make the huge regex hash")