Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -164,13 +164,14 @@ dcommon.o : run_records.scm migrate-fix.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm # for the modularized stuff -mofiles/dbmod.o : mofiles/commonmod.o mofiles/keysmod.o +mofiles/dbmod.o : mofiles/commonmod.o mofiles/keysmod.o mofiles/tasksmod.o mofiles/commonmod.o : mofiles/configfmod.o -mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o +mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o mofiles/apimod.o +mofiles/apimod.o : mofiles/dbmod.o # $(MOFILES) : mofiles/commonmod.o megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -19,273 +19,15 @@ ;;====================================================================== (use srfi-69 posix) (declare (unit api)) -(declare (uses rmt)) +;; (declare (uses rmt)) (declare (uses db)) (declare (uses tasks)) (declare (uses apimod)) (import apimod) ;; api:read-only-queries and api:execute-requests have been moved into common_records -;; These are called by the server on recipt of /api calls -;; - keep it simple, only return the actual result of the call, i.e. no meta info here -;; -;; - returns #( flag result ) -;; -(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, dat=" dat) - (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 - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f (vector #f "remote must be called with a vector"))) - ((> *api-process-request-count* 20) ;; 20) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") - (set! *server-overloaded* #t) - (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! - (else - (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)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - #;(foo (begin - (common:telemetry-log (conc "api-in:"(->string cmd)) - payload: `((params . ,params))) - - #t)) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (case cmd - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - - ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) - ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. - ((test-set-state-status-by-id) - - ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) - (db:set-state-status-and-roll-up-items - dbstruct - (list-ref params 0) ; run-id - (list-ref params 1) ; test-name - #f ; item-path - (list-ref params 2) ; state - (list-ref params 3) ; status - (list-ref params 4) ; comment - )) - - ((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)) - ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run 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)) - ((del-var) (apply db:del-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - ((delete-steps-for-test!) (apply db:delete-steps-for-test! 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)) - - ;; NO SYNC DB - ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) - ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) - ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) - ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* 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)) - ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - ((get-test-times) (apply db:get-test-times dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((get-run-state) (apply db:get-run-state dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((set-run-state-status) (apply db:set-run-state-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-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt 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)) - ((get-run-times) (apply db:get-run-times 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)) - ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - ((read-test-data*) (apply db:read-test-data* dbstruct params)) - ((get-data-info-by-id) (apply db:get-data-info-by-id 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)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) - (else - (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) - (conc "ERROR: BAD api call " cmd)))))) - - - ;; save all stats - (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 '())))) - (if writecmd-in-readonly-mode - (begin - (common:telemetry-log (conc "api-out:"(->string cmd)) - payload: `((params . ,params) - (ok-res . #t))) - (vector #f res)) - (begin - (common:telemetry-log (conc "api-out:"(->string cmd)) - payload: `((params . ,params) - (ok-res . #f))) - (vector #t 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)) ;; incoming data from the POST (or is it a GET?) - (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result ) - (success (vector-ref resdat 0)) - (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?) - (if (not success) - (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) - (if (> *api-process-request-count* *max-api-process-requests*) - (set! *max-api-process-requests* *api-process-request-count*)) - (set! *api-process-request-count* (- *api-process-request-count* 1)) - ;; 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) - ;; (boolean? res)) - ;; res - ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) - (db:obj->string res transport: 'http))) - Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -18,18 +18,318 @@ ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) +(declare (uses dbmod)) (module apimod * (import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable + s11n z3 (prefix base64 base64:) regex) (import commonmod) +(import dbmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") +(define *api-process-request-count* 0) +(define *max-api-process-requests* 0) +(define *db-api-call-time* (make-hash-table)) + +;; NOTE: Can remove the regex and base64 encoding for zmq +(define (api:obj->string obj #!key (transport 'http)) + (case transport + ;; ((fs) obj) + ((http fs) + (string-substitute + (regexp "=") "_" + (base64:base64-encode + (z3:encode-buffer + (with-output-to-string + (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest. + #t)) + ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj)))) + (else obj))) ;; rpc + +(define (api:string->obj msg #!key (transport 'http)) + (case transport + ;; ((fs) msg) + ((http fs) + (if (string? msg) + (with-input-from-string + (z3:decode-buffer + (base64:base64-decode + (string-substitute + (regexp "_") "=" msg #t))) + (lambda ()(deserialize))) + (begin + (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.") + (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 + + + +;; These are called by the server on recipt of /api calls +;; - keep it simple, only return the actual result of the call, i.e. no meta info here +;; +;; - returns #( flag result ) +;; +(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, dat=" dat) + (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 + (cond + ((not (vector? dat)) ;; it is an error to not receive a vector + (vector #f (vector #f "remote must be called with a vector"))) + ((> *api-process-request-count* 20) ;; 20) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") + (set! *server-overloaded* #t) + (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! + (else + (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)) + (readonly-mode (dbr:dbstruct-read-only dbstruct)) + (readonly-command (member cmd api:read-only-queries)) + (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) + #;(foo (begin + (common:telemetry-log (conc "api-in:"(->string cmd)) + payload: `((params . ,params))) + + #t)) + (res + (if writecmd-in-readonly-mode + (conc "attempt to run write command "cmd" on a read-only database") + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl + + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + + ((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)) + ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run 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)) + ((del-var) (apply db:del-var dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + ((delete-steps-for-test!) (apply db:delete-steps-for-test! 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)) + + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* 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)) + ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) + ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + ((get-test-times) (apply db:get-test-times dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((get-run-state) (apply db:get-run-state dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((set-run-state-status) (apply db:set-run-state-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-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt 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)) + ((get-run-times) (apply db:get-run-times 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)) + ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ((read-test-data*) (apply db:read-test-data* dbstruct params)) + ((get-data-info-by-id) (apply db:get-data-info-by-id 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)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) + (else + (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) + (conc "ERROR: BAD api call " cmd)))))) + + + ;; save all stats + (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 '())))) + (if writecmd-in-readonly-mode + (begin + #;(common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #t))) + (vector #f res)) + (begin + #;(common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #f))) + (vector #t 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 (api:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?) + (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result ) + (success (vector-ref resdat 0)) + (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?) + (if (not success) + (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) + (if (> *api-process-request-count* *max-api-process-requests*) + (set! *max-api-process-requests* *api-process-request-count*)) + (set! *api-process-request-count* (- *api-process-request-count* 1)) + ;; 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) + ;; (boolean? res)) + ;; res + ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) + (api:obj->string res transport: 'http))) + ) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -151,11 +151,11 @@ (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) + ;; no sync db (define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) @@ -169,12 +169,10 @@ (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) (define *server-overloaded* #f) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -24,11 +24,12 @@ (module commonmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 - srfi-69 ports srfi-1 files format srfi-13 matchable + srfi-1 files format srfi-13 matchable + srfi-69 ports regex-case regex) (import configfmod) (include "common_records.scm") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2860,43 +2860,10 @@ ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== -;; NOTE: Can remove the regex and base64 encoding for zmq -(define (db:obj->string obj #!key (transport 'http)) - (case transport - ;; ((fs) obj) - ((http fs) - (string-substitute - (regexp "=") "_" - (base64:base64-encode - (z3:encode-buffer - (with-output-to-string - (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest. - #t)) - ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj)))) - (else obj))) ;; rpc - -(define (db:string->obj msg #!key (transport 'http)) - (case transport - ;; ((fs) msg) - ((http fs) - (if (string? msg) - (with-input-from-string - (z3:decode-buffer - (base64:base64-decode - (string-substitute - (regexp "_") "=" msg #t))) - (lambda ()(deserialize))) - (begin - (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.") - (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 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")) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -20,10 +20,11 @@ (declare (unit dbmod)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses keysmod)) +(declare (uses tasksmod)) (module dbmod * (import scheme chicken data-structures extras) @@ -32,10 +33,12 @@ srfi-13) (import commonmod) (import configfmod) (import keysmod) (import files) +(import tasksmod) + ;; (use (prefix ulex ulex:)) (include "common_records.scm") ;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -51,11 +51,12 @@ ;; by the client ;; when things go ;; wrong.. exn ;; This is an attempt to detect that situation and recover gracefully (begin - (debug:print 0 log-port "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 log-port "ERROR: bad data from server " v " message: " + ((condition-property-accessor 'exn 'message) exn)) (vector #t '())) ;; should always ;; get a vector but ;; if something ;; goes wrong ;; return a dummy Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -32,1068 +32,5 @@ (import commonmod) (include "task_records.scm") (include "db_records.scm") -;;====================================================================== -;; Tasks db -;;====================================================================== - -;; wait up to aprox n seconds for a journal to go away -;; -(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) - (if (not (string? path)) - (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") - (let ((fullpath (conc path "-journal"))) - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* " exn=" (condition->list exn)) - (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") - #t) ;; if stuff goes wrong just allow it to move on - (let loop ((journal-exists (common:file-exists? fullpath)) - (count n)) ;; wait ten times ... - (if journal-exists - (begin - (if (and waiting-msg - (eq? (modulo n 30) 0)) - (debug:print 0 *default-log-port* waiting-msg)) - (if (> count 0) - (begin - (thread-sleep! 1) - (loop (common:file-exists? fullpath) - (- count 1))) - (begin - (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") - (if remove (system (conc "rm -rf " fullpath))) - #f))) - #t)))))) - -(define (tasks:get-task-db-path) - (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") - (configf:lookup *configdat* "setup" "dbdir") - (conc (common:get-linktree) "/.db")))) - (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 file exists AND -;; file readable -;; ==> open it -;; If file exists AND -;; file NOT readable -;; ==> open in-mem version -;; If file NOT exists -;; ==> open in-mem version -;; -(define (tasks:open-db #!key (numretries 4)) - (if *task-db* - *task-db* - (handle-exceptions - exn - (if (> numretries 0) - (begin - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* " exn=" (condition->list exn)) - (thread-sleep! 1) - (tasks:open-db numretries (- numretries 1))) - (begin - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) - (let* ((dbpath (common:get-db-tmp-area *alldat*)) ;; (tasks:get-task-db-path)) - (dbfile (conc dbpath "/monitor.db")) - (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away - (exists (common:file-exists? dbpath)) - (write-access (file-write-access? dbpath)) - (mdb (cond ;; what the hek is *toppath* doing here? - ((and (string? *toppath*)(file-write-access? *toppath*)) - (sqlite3:open-database dbfile)) - ((file-read-access? dbpath) (sqlite3:open-database dbfile)) - (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) - (if (and exists - (not write-access)) - (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (sqlite3:set-busy-handler! mdb handler) - (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) - ;; (if (or (and (not exists) - ;; (file-write-access? *toppath*)) - ;; (not (file-read-access? dbpath))) - ;; (begin - ;; - ;; TASKS QUEUE MOVED TO main.db - ;; - ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, - ;; action TEXT DEFAULT '', - ;; owner TEXT, - ;; state TEXT DEFAULT 'new', - ;; target TEXT DEFAULT '', - ;; name TEXT DEFAULT '', - ;; testpatt TEXT DEFAULT '', - ;; keylock TEXT, - ;; params TEXT, - ;; creation_time TIMESTAMP, - ;; execution_time TIMESTAMP);") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, - pid INTEGER, - start_time TIMESTAMP, - last_update TIMESTAMP, - hostname TEXT, - username TEXT, - CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, - pid INTEGER, - interface TEXT, - hostname TEXT, - port INTEGER, - pubport INTEGER, - start_time TIMESTAMP, - priority INTEGER, - state TEXT, - mt_version TEXT, - heartbeat TIMESTAMP, - transport TEXT, - run_id INTEGER);") - ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, - server_id INTEGER, - pid INTEGER, - hostname TEXT, - cmdline TEXT, - login_time TIMESTAMP, - logout_time TIMESTAMP DEFAULT -1, - CONSTRAINT clients_constraint UNIQUE (pid,hostname));") - - ;)) - (set! *task-db* (cons mdb dbpath)) - *task-db*)))) - -;;====================================================================== -;; Server and client management -;;====================================================================== - -;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname -(define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) -(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) -(define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) -(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) -(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) -(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) -(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) - -(define (tasks:need-server run-id) - (equal? (configf:lookup *configdat* "server" "required") "yes")) - -;; no elegance here ... -;; -(define (tasks:kill-server hostname pid #!key (kill-switch "")) - (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) - (setenv "TARGETHOST" hostname) - (let* ((logdir (if (directory-exists? "logs") - "logs/" - "")) - (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f)) - (gzfile (if logfile (conc logfile ".gz")))) - (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) - - (system (conc "nbfake kill "kill-switch" "pid)) - - (when logfile - (thread-sleep! 0.5) - (if (common:file-exists? gzfile) (delete-file gzfile)) - (system (conc "gzip " logfile)) - - (unsetenv "TARGETHOST_LOGF") - (unsetenv "TARGETHOST")))) - - -;;====================================================================== -;; M O N I T O R S -;;====================================================================== - -(define (tasks:remove-monitor-record mdb) - (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;" - (current-process-id) - (get-host-name))) - -(define (tasks:get-monitors mdb) - (let ((res '())) - (sqlite3:for-each-row - (lambda (a . rem) - (set! res (cons (apply vector a rem) res))) - mdb - "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;") - (reverse res) - )) - -(define (tasks:monitors->text-table monitors) - (let ((fmtstr "~4a~8a~20a~20a~10a~10a")) - (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n" - (string-intersperse - (map (lambda (monitor) - (format #f fmtstr - (tasks:monitor-get-id monitor) - (tasks:monitor-get-pid monitor) - (tasks:monitor-get-start_time monitor) - (tasks:monitor-get-last_update monitor) - (tasks:monitor-get-hostname monitor) - (tasks:monitor-get-username monitor))) - monitors) - "\n")))) - -;; update the last_update field with the current time and -;; if any monitors appear dead, remove them -(define (tasks:monitors-update mdb) - (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" - (current-process-id) - (get-host-name)) - (let ((deadlist '())) - (sqlite3:for-each-row - (lambda (id pid host last-update delta) - (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") - (set! deadlist (cons id deadlist))) - mdb - "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") - (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) - ) -(define (tasks:register-monitor db port) - (let* ((pid (current-process-id)) - (hostname (get-host-name)) - (userinfo (user-information (current-user-id))) - (username (car userinfo))) - (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) - (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" - pid hostname username))) - -(define (tasks:get-num-alive-monitors mdb) - (let ((res 0)) - (sqlite3:for-each-row - (lambda (count) - (set! res count)) - mdb - "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" - (car (user-information (current-user-id)))) - res)) - -;; -(define (tasks:start-monitor db mdb) - (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more - (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") - (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc (common:get-db-tmp-area *alldat*) "/monitor.db")) - (last-db-update 0)) ;; (file-modification-time megatestdb))) - (task:register-monitor mdb) - (let loop ((count 0) - (next-touch 0)) ;; next-touch is the time where we need to update last_update - ;; if the db has been modified we'd best look at the task queue - (let ((modtime (file-modification-time megatestdbpath ))) - (if (> modtime last-db-update) - (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch)) - ;; WARNING: Possible race conditon here!! - ;; should this update be immediately after the task-get-action call above? - (if (> (current-seconds) next-touch) - (begin - (tasks:monitors-update mdb) - (loop (+ count 1)(+ (current-seconds) 240))) - (loop (+ count 1) next-touch))))))) - -;;====================================================================== -;; T A S K S Q U E U E -;; -;; NOTE:: These operate on task_queue which is in main.db -;; -;;====================================================================== - -;; NOTE: It might be good to add one more layer of checking to ensure -;; that no task gets run in parallel. - -;; id INTEGER PRIMARY KEY, -;; action TEXT DEFAULT '', -;; owner TEXT, -;; state TEXT DEFAULT 'new', -;; target TEXT DEFAULT '', -;; name TEXT DEFAULT '', -;; testpatt TEXT DEFAULT '', -;; keylock TEXT, -;; params TEXT, -;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')), -;; execution_time TIMESTAMP); - - -;; register a task -(define (tasks:add dbstruct action owner target runname testpatt params) - (db:with-db - dbstruct #f #t - (lambda (db) - (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) - VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" - action - owner - target - runname - testpatt - (if params params ""))))) - -(define (keys:key-vals-hash->target keys key-params) - (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) - (if (> (length keys) 1) - (for-each (lambda (key) - (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) "")))) - (cdr keys))) - tmp)) - -;; for use from the gui, not ported -;; -;; (define (tasks:add-from-params mdb action keys key-params var-params) -;; (let ((target (keys:key-vals-hash->target keys key-params)) -;; (owner (car (user-information (current-user-id)))) -;; (runname (hash-table-ref/default var-params "runname" #f)) -;; (testpatts (hash-table-ref/default var-params "testpatts" "%")) -;; (params (hash-table-ref/default var-params "params" ""))) -;; (tasks:add mdb action owner target runname testpatts params))) - -;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old -;; -(define (tasks:snag-a-task dbstruct) - (let ((res #f) - (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id)))))) - (db:with-db - dbstruct #f #t - (lambda (db) - ;; first randomly set a new to pid-hostname-hostname - (sqlite3:execute - db - "UPDATE tasks_queue SET keylock=? WHERE id IN - (SELECT id FROM tasks_queue - WHERE state='new' OR - (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR - state='reset' - ORDER BY RANDOM() LIMIT 1);" keytxt) - - (sqlite3:for-each-row - (lambda (id . rem) - (set! res (apply vector id rem))) - db - "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt) - (if res ;; yep, have work to be done - (begin - (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;" - (tasks:task-get-id res)) - res) - #f))))) - -(define (tasks:reset-stuck-tasks dbstruct) - (let ((res '())) - (db:with-db - dbstruct #f #t - (lambda (db) - (sqlite3:for-each-row - (lambda (id delta) - (set! res (cons id res))) - db - "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;") - (sqlite3:execute - db - (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');") - ))))) - -;; return all tasks in the tasks_queue table -;; -(define (tasks:get-tasks dbstruct types states) - (let ((res '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id . rem) - (set! res (cons (apply vector id rem) res))) - db - (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time - FROM tasks_queue " - ;; WHERE - ;; state IN " statesstr " AND - ;; action IN " actionsstr - " ORDER BY creation_time DESC;")) - res)))) - -(define (tasks:get-last dbstruct target runname) - (let ((res #f)) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id . rem) - (set! res (apply vector id rem))) - db - (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time - FROM tasks_queue - WHERE - target = ? AND name =? - ORDER BY creation_time DESC LIMIT 1;") - target runname) - res)))) - -;; remove tasks given by a string of numbers comma separated -(define (tasks:remove-queue-entries dbstruct task-ids) - (db:with-db - dbstruct #f #t - (lambda (db) - (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) - -(define (tasks:process-queue dbstruct) - (let* ((task (tasks:snag-a-task dbstruct)) - (action (if task (tasks:task-get-action task) #f))) - (if action (print "tasks:process-queue task: " task)) - (if action - (case (string->symbol action) - ((run) (tasks:start-run dbstruct task)) - ((remove) (tasks:remove-runs dbstruct task)) - ((lock) (tasks:lock-runs dbstruct task)) - ;; ((monitor) (tasks:start-monitor db task)) - ((rollup) (tasks:rollup-runs dbstruct task)) - ((updatemeta)(tasks:update-meta dbstruct task)) - ((kill) (tasks:kill-monitors dbstruct task)))))) - -(define (tasks:tasks->text tasks) - (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a")) - (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n" - (string-intersperse - (map (lambda (task) - (format #f fmtstr - (tasks:task-get-id task) - (tasks:task-get-action task) - (tasks:task-get-owner task) - (tasks:task-get-state task) - (tasks:task-get-target task) - (tasks:task-get-name task) - (tasks:task-get-test task) - ;; (tasks:task-get-item task) - (tasks:task-get-params task))) - tasks) "\n")))) - -(define (tasks:set-state dbstruct task-id state) - (db:with-db - dbstruct #f #t - (lambda (db) - (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" - state - task-id)))) - -;;====================================================================== -;; Access using task key (stored in params; (hash-table->alist flags) hostname pid -;;====================================================================== - -(define (tasks:param-key->id dbstruct task-params) - (db:with-db - dbstruct #f #f - (lambda (db) - (handle-exceptions - exn - #f - (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;" - task-params))))) - -(define (tasks:set-state-given-param-key dbstruct param-key new-state) - (db:with-db - dbstruct #f #t - (lambda (db) - (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)))) - -(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt) - (db:with-db - dbstruct #f #f - (lambda (db) - (handle-exceptions - exn - '() - (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE - params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" - param-key state-patt action-patt test-patt))))) - -(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))) - (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 - WHERE - target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" - target run-name state-patt action-patt test-patt) - res)) ;; ) - -;; kill any runner processes (i.e. processes handling -runtests) that match target/runname -;; -;; do a remote call to get the task queue info but do the killing as self here. -;; -(define (tasks:kill-runner target run-name testpatt) - (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests")) - (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string - (if (null? records) - (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) - (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill.")) - (for-each - (lambda (record) - (let* ((param-key (list-ref record 8)) - (match-dat (string-search hostpid-rx param-key))) - (if match-dat - (let ((hostname (cadr match-dat)) - (pid (string->number (caddr match-dat)))) - (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname) - (if (equal? (get-host-name) hostname) - (if (process:alive? pid) - (begin - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - #t) - (process-signal pid signal/int) - (thread-sleep! 5) - (if (process:alive? pid) - (process-signal pid signal/kill))))) - ;; (call-with-environment-variables - (let ((old-targethost (getenv "TARGETHOST"))) - (setenv "TARGETHOST" hostname) - (setenv "TARGETHOST_LOGF" "server-kills.log") - (system (conc "nbfake kill " pid)) - (if old-targethost (setenv "TARGETHOST" old-targethost)) - (unsetenv "TARGETHOST") - (unsetenv "TARGETHOST_LOGF")))) - (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) - records))) - -;; (define (tasks:start-run dbstruct mdb task) -;; (let ((flags (make-hash-table))) -;; (hash-table-set! flags "-rerun" "NOT_STARTED") -;; (if (not (string=? (tasks:task-get-params task) "")) -;; (hash-table-set! flags "-setvars" (tasks:task-get-params task))) -;; (print "Starting run " task) -;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY -;; (runs:run-tests db -;; (tasks:task-get-target task) -;; (tasks:task-get-name task) -;; (tasks:task-get-test task) -;; (tasks:task-get-item task) -;; (tasks:task-get-owner task) -;; flags) -;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) -;; -;; (define (tasks:rollup-runs db mdb task) -;; (let* ((flags (make-hash-table)) -;; (keys (db:get-keys db)) -;; (keyvals (keys:target-keyval keys (tasks:task-get-target task)))) -;; ;; (hash-table-set! flags "-rerun" "NOT_STARTED") -;; (print "Starting rollup " task) -;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY -;; (runs:rollup-run db -;; keys -;; keyvals -;; (tasks:task-get-name task) -;; (tasks:task-get-owner task)) -;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) - -;;====================================================================== -;; S Y N C T O P O S T G R E S Q L -;;====================================================================== - -;; In the spirit of "dump your junk in the tasks module" I'll put the -;; sync to postgres here for now. - -;; attempt to automatically set up an area. call only if get area by path -;; returns naught of interest -;; -(define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated? - (let loop ((area-name (or (configf:lookup configdat "setup" "area-name") - (common:get-area-name *alldat*))) - (modifier 'none)) - (let ((success (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn)) - #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception - (pgdb:add-area dbh area-name (or toppath *toppath*))))) - (or success - (case modifier - ((none)(loop (conc (current-user-name) "_" area-name) 'user)) - ((user)(loop (conc (substring (common:get-area-path-signature) 0 4) - area-name) 'areasig)) - (else #f)))))) ;; give up - -(define (task:print-runtime run-times saperator) -(for-each - (lambda (run-time-info) - (let* ((run-name (vector-ref run-time-info 0)) - (run-time (vector-ref run-time-info 1)) - (target (vector-ref run-time-info 2))) - (print target saperator run-name saperator run-time ))) - run-times)) - -(define (task:print-runtime-as-json run-times) - (let loop ((run-time-info (car run-times)) - (rema (cdr run-times)) - (str "")) - (let* ((run-name (vector-ref run-time-info 0)) - (run-time (vector-ref run-time-info 1)) - (target (vector-ref run-time-info 2))) - ;(print (not (equal? str ""))) - (if (not (equal? str "")) - (set! str (conc str ","))) - (if (null? rema) - (print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]") - (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}")))))) - -(define (task:get-run-times) - (let* ( - (run-patt (if (args:get-arg "-run-patt") - (args:get-arg "-run-patt") - "%")) - (target-patt (if (args:get-arg "-target-patt") - (args:get-arg "-target-patt") - "%")) - - (run-times (rmt:get-run-times run-patt target-patt ))) - (if (eq? (length run-times) 0) - (begin - (print "Data not found!!") - (exit))) - (if (equal? (args:get-arg "-dumpmode") "json") - (task:print-runtime-as-json run-times) - (if (equal? (args:get-arg "-dumpmode") "csv") - (task:print-runtime run-times ",") - (task:print-runtime run-times " "))))) - - -(define (task:print-testtime test-times saperator) -(for-each - (lambda (test-time-info) - (let* ((test-name (vector-ref test-time-info 0)) - (test-time (vector-ref test-time-info 2)) - (test-item (if (eq? (string-length (vector-ref test-time-info 1)) 0) - "N/A" - (vector-ref test-time-info 1)))) - (print test-name saperator test-item saperator test-time ))) - test-times)) - -(define (task:print-testtime-as-json test-times) - (let loop ((test-time-info (car test-times)) - (rema (cdr test-times)) - (str "")) - (let* ((test-name (vector-ref test-time-info 0)) - (test-time (vector-ref test-time-info 2)) - (item (vector-ref test-time-info 1))) - ;(print (not (equal? str ""))) - (if (not (equal? str "")) - (set! str (conc str ","))) - (if (null? rema) - (print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]") - (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}")))))) - - - (define (task:get-test-times) - (let* ((runname (if (args:get-arg "-runname") - (args:get-arg "-runname") - #f)) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - #f)) - - (test-times (rmt:get-test-times runname target ))) - (if (not runname) - (begin - (print "Error: Missing argument -runname") - (exit))) - (if (string-contains runname "%") - (begin - (print "Error: Invalid runname, '%' not allowed (" runname ") ") - (exit))) - (if (not target) - (begin - (print "Error: Missing argument -target") - (exit))) - (if (string-contains target "%") - (begin - (print "Error: Invalid target, '%' not allowed (" target ") ") - (exit))) - - (if (eq? (length test-times) 0) - (begin - (print "Data not found!!") - (exit))) - (if (equal? (args:get-arg "-dumpmode") "json") - (task:print-testtime-as-json test-times) - (if (equal? (args:get-arg "-dumpmode") "csv") - (task:print-testtime test-times ",") - (task:print-testtime test-times " "))))) - - - -;; gets mtpg-run-id and syncs the record if different -;; -(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time) - (let* ((runs-ht (hash-table-ref cached-info 'runs)) - (runinf (hash-table-ref/default runs-ht run-id #f)) - (area-id (vector-ref area-info 0))) - (if runinf - runinf ;; already cached - (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > - (run-name (rmt:get-run-name-from-id run-id)) - (row (db:get-rows run-dat)) ;; yes, this returns a single row - (header (db:get-header run-dat)) - (state (db:get-value-by-header row header "state")) - (status (db:get-value-by-header row header "status")) - (owner (db:get-value-by-header row header "owner")) - (event-time (db:get-value-by-header row header "event_time")) - (comment (db:get-value-by-header row header "comment")) - (fail-count (db:get-value-by-header row header "fail_count")) - (pass-count (db:get-value-by-header row header "pass_count")) - (db-contour (db:get-value-by-header row header "contour")) - (contour (if (args:get-arg "-prepend-contour") - (if (and db-contour (not (equal? db-contour "")) (string? db-contour )) - (begin - (debug:print-info 1 *default-log-port* "db-contour") - db-contour) - (args:get-arg "-contour")))) - (run-tag (if (args:get-arg "-run-tag") - (args:get-arg "-run-tag") - "")) - (last-update (db:get-value-by-header row header "last_update")) - (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) - (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform - (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) - (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name *alldat*) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu - (spec-id (pgdb:get-ttype dbh keytarg)) - (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime") - event-time - (current-seconds))) - (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))) - (if new-run-id - (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) - (hash-table-set! runs-ht run-id new-run-id) - ;; ensure key fields are up to date - ;; if last_update == pgdb_last_update do not update smallest-last-update-time - (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id)) - (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) - (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) - (hash-table-set! smallest-last-update-time "smallest-time" last-update))) - (pgdb:refresh-run-info - dbh - new-run-id - state status owner event-time comment fail-count pass-count area-id last-update publish-time) - (debug:print-info 0 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id ) - (if (not (equal? run-tag "")) - (task:add-run-tag dbh new-run-id run-tag)) - new-run-id) - - (if (equal? state "deleted") - (begin - (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) - (if (handle-exceptions - exn - (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) - #f) - - (pgdb:insert-run - dbh - spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) - (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) - (if (or (not smallest-time) (< last-update smallest-time)) - (hash-table-set! smallest-last-update-time "smallest-time" last-update)) - (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) - #f))))))) - -(define (task:add-run-tag dbh run-id tag) - (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) - (if (not tag-info) - (begin - (if (handle-exceptions - exn - (begin - (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) - #f) - (pgdb:insert-tag dbh tag)) - (set! tag-info (pgdb:get-tag-info-by-name dbh tag)) - #f))) - ;;add to area_tags - (handle-exceptions - exn - (begin - (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) - #f) - (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id)) - (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id))))) - - -(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) - ; (print "Sync Steps " test-step-ids ) - (let ((test-ht (hash-table-ref cached-info 'tests)) - (step-ht (hash-table-ref cached-info 'steps))) - (for-each - (lambda (test-step-id) - (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id)) - (step-id (tdb:step-get-id test-step-info)) - (test-id (tdb:step-get-test_id test-step-info)) - (stepname (tdb:step-get-stepname test-step-info)) - (state (tdb:step-get-state test-step-info)) - (status (tdb:step-get-status test-step-info)) - (event_time (tdb:step-get-event_time test-step-info)) - (comment (tdb:step-get-comment test-step-info)) - (logfile (tdb:step-get-logfile test-step-info)) - (last-update (tdb:step-get-last_update test-step-info)) - (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) - (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) - (pgdb-step-id (if pgdb-test-id - (pgdb:get-test-step-id dbh pgdb-test-id stepname state) - #f))) - (if step-id - (begin - (if pgdb-test-id - (begin - (if pgdb-step-id - (begin - (debug:print-info 1 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id ) - (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id))) - (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) - (hash-table-set! smallest-last-update-time "smallest-time" last-update))) - (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update)) - (begin - (debug:print-info 1 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id) - (if (or (not smallest-time) (< last-update smallest-time)) - (hash-table-set! smallest-last-update-time "smallest-time" last-update)) - (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update ) - (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state)))) - (hash-table-set! step-ht step-id pgdb-step-id )) - (debug:print-info 1 *default-log-port* "Error: Test not cashed"))) - (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug - test-step-ids))) - -(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) - (let ((test-ht (hash-table-ref cached-info 'tests)) - (data-ht (hash-table-ref cached-info 'data))) - (for-each - (lambda (test-data-id) - (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) - (data-id (db:test-data-get-id test-data-info)) - (test-id (db:test-data-get-test_id test-data-info)) - (category (db:test-data-get-category test-data-info)) - (variable (db:test-data-get-variable test-data-info)) - (value (db:test-data-get-value test-data-info)) - (expected (db:test-data-get-expected test-data-info)) - (tol (db:test-data-get-tol test-data-info)) - (units (db:test-data-get-units test-data-info)) - (comment (db:test-data-get-comment test-data-info)) - (status (db:test-data-get-status test-data-info)) - (type (db:test-data-get-type test-data-info)) - (last-update (db:test-data-get-last_update test-data-info)) - (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) - - (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) - (pgdb-data-id (if pgdb-test-id - (pgdb:get-test-data-id dbh pgdb-test-id category variable) - #f))) - (if data-id - (begin - (if pgdb-test-id - (begin - (if pgdb-data-id - (begin - (debug:print-info 1 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id) - (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id))) - (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) - (hash-table-set! smallest-last-update-time "smallest-time" last-update))) - (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update)) - (begin - (debug:print-info 1 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) - (if (handle-exceptions - exn - (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) - #f) - - (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update)) - ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) - (begin - ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) - (if (or (not smallest-time) (< last-update smallest-time)) - (hash-table-set! smallest-last-update-time "smallest-time" last-update)) - (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))) - #f))) - (hash-table-set! data-ht data-id pgdb-data-id )) - (begin - (debug:print-info 1 *default-log-port* "Error: Test not in pgdb")))) - - (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug - test-data-ids))) - - - -(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) - (let ((test-ht (hash-table-ref cached-info 'tests))) - (for-each - (lambda (test-id) - ; (print test-id) - (let* ((test-info (rmt:get-test-info-by-id #f test-id)) - (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm - (test-id (db:test-get-id test-info)) - (test-name (db:test-get-testname test-info)) - (item-path (db:test-get-item-path test-info)) - (state (db:test-get-state test-info)) - (status (db:test-get-status test-info)) - (host (db:test-get-host test-info)) - (pid (db:test-get-process_id test-info)) - (cpuload (db:test-get-cpuload test-info)) - (diskfree (db:test-get-diskfree test-info)) - (uname (db:test-get-uname test-info)) - (run-dir (db:test-get-rundir test-info)) - (log-file (db:test-get-final_logf test-info)) - (run-duration (db:test-get-run_duration test-info)) - (comment (db:test-get-comment test-info)) - (event-time (db:test-get-event_time test-info)) - (archived (db:test-get-archived test-info)) - (last-update (db:test-get-last_update test-info)) - (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) - (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) - (pgdb-test-id (if pgdb-run-id - (begin - ;(print pgdb-run-id) - (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) - #f))) - ;; "id" "run_id" "testname" "state" "status" "event_time" - ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" - ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" - (if pgdb-run-id - (begin - (if pgdb-test-id ;; have a record - (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) - (debug:print-info 0 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id) - (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id))) - (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time. - (hash-table-set! smallest-last-update-time "smallest-time" last-update))) - (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)) - (begin - (debug:print-info 0 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) - (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) - (if (or (not smallest-time) (< last-update smallest-time)) - (hash-table-set! smallest-last-update-time "smallest-time" last-update)) - (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) - (hash-table-set! test-ht test-id pgdb-test-id)) - (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) - test-ids))) - -(define (task:add-area-tag dbh area-info tag) - (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) - (if (not tag-info) - (begin - (if (handle-exceptions - exn - (begin - (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) - #f) - (pgdb:insert-tag dbh tag)) - (set! tag-info (pgdb:get-tag-info-by-name dbh tag)) - #f))) - ;;add to area_tags - (handle-exceptions - exn - (begin - (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) - #f) - (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))) - (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))))) - -(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) - (for-each - (lambda (run-id) - (debug:print-info 1 *default-log-port* "Check if run with " run-id " needs to be synced" ) - (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) -run-ids)) - - -;; get runs changed since last sync -;; (define (tasks:sync-test-data dbh cached-info area-info) -;; (let* (( - -(define (tasks:sync-to-postgres configdat dest) - (print "In sync") - (let* ((dbh (pgdb:open configdat dbname: dest)) - (area-info (pgdb:get-area-by-path dbh *toppath*)) - (cached-info (make-hash-table)) - (start (current-seconds)) - (test-patt (if (args:get-arg "-testpatt") - (args:get-arg "-testpatt") - "%")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - #f)) - (run-name (if (args:get-arg "-runname") - (args:get-arg "-runname") - #f))) - (if (and target (not run-name)) - (begin - (print "Error: Provide runname") - (exit 1))) - (if (and (not target) run-name) - (begin - (print "Error: Provide target") - (exit 1))) - ;(print "123") - ;(exit 1) - (for-each (lambda (dtype) - (hash-table-set! cached-info dtype (make-hash-table))) - '(runs targets tests steps data)) - (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this - (if area-info - (let* ((last-sync-time (vector-ref area-info 3)) - (smallest-last-update-time (make-hash-table)) - (changed (if (and target run-name) - (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt) - (rmt:get-changed-record-ids last-sync-time))) - (run-ids (alist-ref 'runs changed)) - (test-ids (alist-ref 'tests changed)) - (test-step-ids (alist-ref 'test_steps changed)) - (test-data-ids (alist-ref 'test_data changed)) - (run-stat-ids (alist-ref 'run_stats changed)) - (area-tag (if (args:get-arg "-area-tag") - (args:get-arg "-area-tag") - (if (args:get-arg "-area") - (args:get-arg "-area") - "")))) - (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) - (set! area-tag *default-area-tag*)) - (if (not (equal? area-tag "")) - (task:add-area-tag dbh area-info area-tag)) - (if (or (not (null? test-ids)) (not (null? run-ids))) - (begin - (debug:print-info 0 *default-log-port* "syncing runs") - (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing tests") - (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing test steps") - (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing test data") - (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) - (print "----------done---------------"))) - (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) - (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time) - (if (not (and target run-name)) - (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) - (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed - (if (tasks:set-area dbh configdat) - (tasks:sync-to-postgres configdat dest) - (begin - (debug:print 0 *default-log-port* "ERROR: unable to create an area record") - #f))))) - Index: tasksmod.scm ================================================================== --- tasksmod.scm +++ tasksmod.scm @@ -28,8 +28,1071 @@ (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") + +;;====================================================================== +;; Tasks db +;;====================================================================== + +;; wait up to aprox n seconds for a journal to go away +;; +(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) + (if (not (string? path)) + (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") + (let ((fullpath (conc path "-journal"))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + #t) ;; if stuff goes wrong just allow it to move on + (let loop ((journal-exists (common:file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (begin + (if (and waiting-msg + (eq? (modulo n 30) 0)) + (debug:print 0 *default-log-port* waiting-msg)) + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (common:file-exists? fullpath) + (- count 1))) + (begin + (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") + (if remove (system (conc "rm -rf " fullpath))) + #f))) + #t)))))) + +(define (tasks:get-task-db-path) + (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") + (configf:lookup *configdat* "setup" "dbdir") + (conc (common:get-linktree) "/.db")))) + (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 file exists AND +;; file readable +;; ==> open it +;; If file exists AND +;; file NOT readable +;; ==> open in-mem version +;; If file NOT exists +;; ==> open in-mem version +;; +(define (tasks:open-db #!key (numretries 4)) + (if *task-db* + *task-db* + (handle-exceptions + exn + (if (> numretries 0) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* " exn=" (condition->list exn)) + (thread-sleep! 1) + (tasks:open-db numretries (- numretries 1))) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) + (let* ((dbpath (common:get-db-tmp-area *alldat*)) ;; (tasks:get-task-db-path)) + (dbfile (conc dbpath "/monitor.db")) + (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away + (exists (common:file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (mdb (cond ;; what the hek is *toppath* doing here? + ((and (string? *toppath*)(file-write-access? *toppath*)) + (sqlite3:open-database dbfile)) + ((file-read-access? dbpath) (sqlite3:open-database dbfile)) + (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 36000))) + (if (and exists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control + (sqlite3:set-busy-handler! mdb handler) + (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) + ;; (if (or (and (not exists) + ;; (file-write-access? *toppath*)) + ;; (not (file-read-access? dbpath))) + ;; (begin + ;; + ;; TASKS QUEUE MOVED TO main.db + ;; + ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + ;; action TEXT DEFAULT '', + ;; owner TEXT, + ;; state TEXT DEFAULT 'new', + ;; target TEXT DEFAULT '', + ;; name TEXT DEFAULT '', + ;; testpatt TEXT DEFAULT '', + ;; keylock TEXT, + ;; params TEXT, + ;; creation_time TIMESTAMP, + ;; execution_time TIMESTAMP);") + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, + pid INTEGER, + start_time TIMESTAMP, + last_update TIMESTAMP, + hostname TEXT, + username TEXT, + CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, + pid INTEGER, + interface TEXT, + hostname TEXT, + port INTEGER, + pubport INTEGER, + start_time TIMESTAMP, + priority INTEGER, + state TEXT, + mt_version TEXT, + heartbeat TIMESTAMP, + transport TEXT, + run_id INTEGER);") + ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, + server_id INTEGER, + pid INTEGER, + hostname TEXT, + cmdline TEXT, + login_time TIMESTAMP, + logout_time TIMESTAMP DEFAULT -1, + CONSTRAINT clients_constraint UNIQUE (pid,hostname));") + + ;)) + (set! *task-db* (cons mdb dbpath)) + *task-db*)))) + +;;====================================================================== +;; Server and client management +;;====================================================================== + +;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname +(define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) +(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) +(define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) +(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) +(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) +(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) +(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) + +(define (tasks:need-server run-id) + (equal? (configf:lookup *configdat* "server" "required") "yes")) + +;; no elegance here ... +;; +(define (tasks:kill-server hostname pid #!key (kill-switch "")) + (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) + (setenv "TARGETHOST" hostname) + (let* ((logdir (if (directory-exists? "logs") + "logs/" + "")) + (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f)) + (gzfile (if logfile (conc logfile ".gz")))) + (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) + + (system (conc "nbfake kill "kill-switch" "pid)) + + (when logfile + (thread-sleep! 0.5) + (if (common:file-exists? gzfile) (delete-file gzfile)) + (system (conc "gzip " logfile)) + + (unsetenv "TARGETHOST_LOGF") + (unsetenv "TARGETHOST")))) + + +;;====================================================================== +;; M O N I T O R S +;;====================================================================== + +(define (tasks:remove-monitor-record mdb) + (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;" + (current-process-id) + (get-host-name))) + +(define (tasks:get-monitors mdb) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . rem) + (set! res (cons (apply vector a rem) res))) + mdb + "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;") + (reverse res) + )) + +(define (tasks:monitors->text-table monitors) + (let ((fmtstr "~4a~8a~20a~20a~10a~10a")) + (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n" + (string-intersperse + (map (lambda (monitor) + (format #f fmtstr + (tasks:monitor-get-id monitor) + (tasks:monitor-get-pid monitor) + (tasks:monitor-get-start_time monitor) + (tasks:monitor-get-last_update monitor) + (tasks:monitor-get-hostname monitor) + (tasks:monitor-get-username monitor))) + monitors) + "\n")))) + +;; update the last_update field with the current time and +;; if any monitors appear dead, remove them +(define (tasks:monitors-update mdb) + (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" + (current-process-id) + (get-host-name)) + (let ((deadlist '())) + (sqlite3:for-each-row + (lambda (id pid host last-update delta) + (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") + (set! deadlist (cons id deadlist))) + mdb + "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") + (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) + ) +(define (tasks:register-monitor db port) + (let* ((pid (current-process-id)) + (hostname (get-host-name)) + (userinfo (user-information (current-user-id))) + (username (car userinfo))) + (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) + (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" + pid hostname username))) + +(define (tasks:get-num-alive-monitors mdb) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + mdb + "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" + (car (user-information (current-user-id)))) + res)) + +;; +(define (tasks:start-monitor db mdb) + (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more + (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") + (let* ((megatestdb (conc *toppath* "/megatest.db")) + (monitordbf (conc (common:get-db-tmp-area *alldat*) "/monitor.db")) + (last-db-update 0)) ;; (file-modification-time megatestdb))) + (task:register-monitor mdb) + (let loop ((count 0) + (next-touch 0)) ;; next-touch is the time where we need to update last_update + ;; if the db has been modified we'd best look at the task queue + (let ((modtime (file-modification-time megatestdbpath ))) + (if (> modtime last-db-update) + (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch)) + ;; WARNING: Possible race conditon here!! + ;; should this update be immediately after the task-get-action call above? + (if (> (current-seconds) next-touch) + (begin + (tasks:monitors-update mdb) + (loop (+ count 1)(+ (current-seconds) 240))) + (loop (+ count 1) next-touch))))))) + +;;====================================================================== +;; T A S K S Q U E U E +;; +;; NOTE:: These operate on task_queue which is in main.db +;; +;;====================================================================== + +;; NOTE: It might be good to add one more layer of checking to ensure +;; that no task gets run in parallel. + +;; id INTEGER PRIMARY KEY, +;; action TEXT DEFAULT '', +;; owner TEXT, +;; state TEXT DEFAULT 'new', +;; target TEXT DEFAULT '', +;; name TEXT DEFAULT '', +;; testpatt TEXT DEFAULT '', +;; keylock TEXT, +;; params TEXT, +;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')), +;; execution_time TIMESTAMP); + + +;; register a task +(define (tasks:add dbstruct action owner target runname testpatt params) + (db:with-db + dbstruct #f #t + (lambda (db) + (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) + VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" + action + owner + target + runname + testpatt + (if params params ""))))) + +(define (keys:key-vals-hash->target keys key-params) + (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) + (if (> (length keys) 1) + (for-each (lambda (key) + (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) "")))) + (cdr keys))) + tmp)) + +;; for use from the gui, not ported +;; +;; (define (tasks:add-from-params mdb action keys key-params var-params) +;; (let ((target (keys:key-vals-hash->target keys key-params)) +;; (owner (car (user-information (current-user-id)))) +;; (runname (hash-table-ref/default var-params "runname" #f)) +;; (testpatts (hash-table-ref/default var-params "testpatts" "%")) +;; (params (hash-table-ref/default var-params "params" ""))) +;; (tasks:add mdb action owner target runname testpatts params))) + +;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old +;; +(define (tasks:snag-a-task dbstruct) + (let ((res #f) + (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id)))))) + (db:with-db + dbstruct #f #t + (lambda (db) + ;; first randomly set a new to pid-hostname-hostname + (sqlite3:execute + db + "UPDATE tasks_queue SET keylock=? WHERE id IN + (SELECT id FROM tasks_queue + WHERE state='new' OR + (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR + state='reset' + ORDER BY RANDOM() LIMIT 1);" keytxt) + + (sqlite3:for-each-row + (lambda (id . rem) + (set! res (apply vector id rem))) + db + "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt) + (if res ;; yep, have work to be done + (begin + (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;" + (tasks:task-get-id res)) + res) + #f))))) + +(define (tasks:reset-stuck-tasks dbstruct) + (let ((res '())) + (db:with-db + dbstruct #f #t + (lambda (db) + (sqlite3:for-each-row + (lambda (id delta) + (set! res (cons id res))) + db + "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;") + (sqlite3:execute + db + (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');") + ))))) + +;; return all tasks in the tasks_queue table +;; +(define (tasks:get-tasks dbstruct types states) + (let ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id . rem) + (set! res (cons (apply vector id rem) res))) + db + (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time + FROM tasks_queue " + ;; WHERE + ;; state IN " statesstr " AND + ;; action IN " actionsstr + " ORDER BY creation_time DESC;")) + res)))) + +(define (tasks:get-last dbstruct target runname) + (let ((res #f)) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id . rem) + (set! res (apply vector id rem))) + db + (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time + FROM tasks_queue + WHERE + target = ? AND name =? + ORDER BY creation_time DESC LIMIT 1;") + target runname) + res)))) + +;; remove tasks given by a string of numbers comma separated +(define (tasks:remove-queue-entries dbstruct task-ids) + (db:with-db + dbstruct #f #t + (lambda (db) + (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) + +(define (tasks:process-queue dbstruct) + (let* ((task (tasks:snag-a-task dbstruct)) + (action (if task (tasks:task-get-action task) #f))) + (if action (print "tasks:process-queue task: " task)) + (if action + (case (string->symbol action) + ((run) (tasks:start-run dbstruct task)) + ((remove) (tasks:remove-runs dbstruct task)) + ((lock) (tasks:lock-runs dbstruct task)) + ;; ((monitor) (tasks:start-monitor db task)) + ((rollup) (tasks:rollup-runs dbstruct task)) + ((updatemeta)(tasks:update-meta dbstruct task)) + ((kill) (tasks:kill-monitors dbstruct task)))))) + +(define (tasks:tasks->text tasks) + (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a")) + (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n" + (string-intersperse + (map (lambda (task) + (format #f fmtstr + (tasks:task-get-id task) + (tasks:task-get-action task) + (tasks:task-get-owner task) + (tasks:task-get-state task) + (tasks:task-get-target task) + (tasks:task-get-name task) + (tasks:task-get-test task) + ;; (tasks:task-get-item task) + (tasks:task-get-params task))) + tasks) "\n")))) + +(define (tasks:set-state dbstruct task-id state) + (db:with-db + dbstruct #f #t + (lambda (db) + (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" + state + task-id)))) + +;;====================================================================== +;; Access using task key (stored in params; (hash-table->alist flags) hostname pid +;;====================================================================== + +(define (tasks:param-key->id dbstruct task-params) + (db:with-db + dbstruct #f #f + (lambda (db) + (handle-exceptions + exn + #f + (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;" + task-params))))) + +(define (tasks:set-state-given-param-key dbstruct param-key new-state) + (db:with-db + dbstruct #f #t + (lambda (db) + (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)))) + +(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt) + (db:with-db + dbstruct #f #f + (lambda (db) + (handle-exceptions + exn + '() + (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE + params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" + param-key state-patt action-patt test-patt))))) + +(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))) + (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 + WHERE + target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" + target run-name state-patt action-patt test-patt) + res)) ;; ) + +;; kill any runner processes (i.e. processes handling -runtests) that match target/runname +;; +;; do a remote call to get the task queue info but do the killing as self here. +;; +(define (tasks:kill-runner target run-name testpatt) + (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests")) + (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string + (if (null? records) + (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) + (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill.")) + (for-each + (lambda (record) + (let* ((param-key (list-ref record 8)) + (match-dat (string-search hostpid-rx param-key))) + (if match-dat + (let ((hostname (cadr match-dat)) + (pid (string->number (caddr match-dat)))) + (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname) + (if (equal? (get-host-name) hostname) + (if (process:alive? pid) + (begin + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + #t) + (process-signal pid signal/int) + (thread-sleep! 5) + (if (process:alive? pid) + (process-signal pid signal/kill))))) + ;; (call-with-environment-variables + (let ((old-targethost (getenv "TARGETHOST"))) + (setenv "TARGETHOST" hostname) + (setenv "TARGETHOST_LOGF" "server-kills.log") + (system (conc "nbfake kill " pid)) + (if old-targethost (setenv "TARGETHOST" old-targethost)) + (unsetenv "TARGETHOST") + (unsetenv "TARGETHOST_LOGF")))) + (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) + records))) + +;; (define (tasks:start-run dbstruct mdb task) +;; (let ((flags (make-hash-table))) +;; (hash-table-set! flags "-rerun" "NOT_STARTED") +;; (if (not (string=? (tasks:task-get-params task) "")) +;; (hash-table-set! flags "-setvars" (tasks:task-get-params task))) +;; (print "Starting run " task) +;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY +;; (runs:run-tests db +;; (tasks:task-get-target task) +;; (tasks:task-get-name task) +;; (tasks:task-get-test task) +;; (tasks:task-get-item task) +;; (tasks:task-get-owner task) +;; flags) +;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) +;; +;; (define (tasks:rollup-runs db mdb task) +;; (let* ((flags (make-hash-table)) +;; (keys (db:get-keys db)) +;; (keyvals (keys:target-keyval keys (tasks:task-get-target task)))) +;; ;; (hash-table-set! flags "-rerun" "NOT_STARTED") +;; (print "Starting rollup " task) +;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY +;; (runs:rollup-run db +;; keys +;; keyvals +;; (tasks:task-get-name task) +;; (tasks:task-get-owner task)) +;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) + +;;====================================================================== +;; S Y N C T O P O S T G R E S Q L +;;====================================================================== + +;; In the spirit of "dump your junk in the tasks module" I'll put the +;; sync to postgres here for now. + +;; attempt to automatically set up an area. call only if get area by path +;; returns naught of interest +;; +(define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated? + (let loop ((area-name (or (configf:lookup configdat "setup" "area-name") + (common:get-area-name *alldat*))) + (modifier 'none)) + (let ((success (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn)) + #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception + (pgdb:add-area dbh area-name (or toppath *toppath*))))) + (or success + (case modifier + ((none)(loop (conc (current-user-name) "_" area-name) 'user)) + ((user)(loop (conc (substring (common:get-area-path-signature) 0 4) + area-name) 'areasig)) + (else #f)))))) ;; give up + +(define (task:print-runtime run-times saperator) +(for-each + (lambda (run-time-info) + (let* ((run-name (vector-ref run-time-info 0)) + (run-time (vector-ref run-time-info 1)) + (target (vector-ref run-time-info 2))) + (print target saperator run-name saperator run-time ))) + run-times)) + +(define (task:print-runtime-as-json run-times) + (let loop ((run-time-info (car run-times)) + (rema (cdr run-times)) + (str "")) + (let* ((run-name (vector-ref run-time-info 0)) + (run-time (vector-ref run-time-info 1)) + (target (vector-ref run-time-info 2))) + ;(print (not (equal? str ""))) + (if (not (equal? str "")) + (set! str (conc str ","))) + (if (null? rema) + (print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]") + (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}")))))) + +(define (task:get-run-times) + (let* ( + (run-patt (if (args:get-arg "-run-patt") + (args:get-arg "-run-patt") + "%")) + (target-patt (if (args:get-arg "-target-patt") + (args:get-arg "-target-patt") + "%")) + + (run-times (rmt:get-run-times run-patt target-patt ))) + (if (eq? (length run-times) 0) + (begin + (print "Data not found!!") + (exit))) + (if (equal? (args:get-arg "-dumpmode") "json") + (task:print-runtime-as-json run-times) + (if (equal? (args:get-arg "-dumpmode") "csv") + (task:print-runtime run-times ",") + (task:print-runtime run-times " "))))) + + +(define (task:print-testtime test-times saperator) +(for-each + (lambda (test-time-info) + (let* ((test-name (vector-ref test-time-info 0)) + (test-time (vector-ref test-time-info 2)) + (test-item (if (eq? (string-length (vector-ref test-time-info 1)) 0) + "N/A" + (vector-ref test-time-info 1)))) + (print test-name saperator test-item saperator test-time ))) + test-times)) + +(define (task:print-testtime-as-json test-times) + (let loop ((test-time-info (car test-times)) + (rema (cdr test-times)) + (str "")) + (let* ((test-name (vector-ref test-time-info 0)) + (test-time (vector-ref test-time-info 2)) + (item (vector-ref test-time-info 1))) + ;(print (not (equal? str ""))) + (if (not (equal? str "")) + (set! str (conc str ","))) + (if (null? rema) + (print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]") + (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}")))))) + + + (define (task:get-test-times) + (let* ((runname (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f)) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + + (test-times (rmt:get-test-times runname target ))) + (if (not runname) + (begin + (print "Error: Missing argument -runname") + (exit))) + (if (string-contains runname "%") + (begin + (print "Error: Invalid runname, '%' not allowed (" runname ") ") + (exit))) + (if (not target) + (begin + (print "Error: Missing argument -target") + (exit))) + (if (string-contains target "%") + (begin + (print "Error: Invalid target, '%' not allowed (" target ") ") + (exit))) + + (if (eq? (length test-times) 0) + (begin + (print "Data not found!!") + (exit))) + (if (equal? (args:get-arg "-dumpmode") "json") + (task:print-testtime-as-json test-times) + (if (equal? (args:get-arg "-dumpmode") "csv") + (task:print-testtime test-times ",") + (task:print-testtime test-times " "))))) + + + +;; gets mtpg-run-id and syncs the record if different +;; +(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time) + (let* ((runs-ht (hash-table-ref cached-info 'runs)) + (runinf (hash-table-ref/default runs-ht run-id #f)) + (area-id (vector-ref area-info 0))) + (if runinf + runinf ;; already cached + (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > + (run-name (rmt:get-run-name-from-id run-id)) + (row (db:get-rows run-dat)) ;; yes, this returns a single row + (header (db:get-header run-dat)) + (state (db:get-value-by-header row header "state")) + (status (db:get-value-by-header row header "status")) + (owner (db:get-value-by-header row header "owner")) + (event-time (db:get-value-by-header row header "event_time")) + (comment (db:get-value-by-header row header "comment")) + (fail-count (db:get-value-by-header row header "fail_count")) + (pass-count (db:get-value-by-header row header "pass_count")) + (db-contour (db:get-value-by-header row header "contour")) + (contour (if (args:get-arg "-prepend-contour") + (if (and db-contour (not (equal? db-contour "")) (string? db-contour )) + (begin + (debug:print-info 1 *default-log-port* "db-contour") + db-contour) + (args:get-arg "-contour")))) + (run-tag (if (args:get-arg "-run-tag") + (args:get-arg "-run-tag") + "")) + (last-update (db:get-value-by-header row header "last_update")) + (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) + (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform + (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) + (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name *alldat*) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu + (spec-id (pgdb:get-ttype dbh keytarg)) + (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime") + event-time + (current-seconds))) + (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))) + (if new-run-id + (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) + (hash-table-set! runs-ht run-id new-run-id) + ;; ensure key fields are up to date + ;; if last_update == pgdb_last_update do not update smallest-last-update-time + (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:refresh-run-info + dbh + new-run-id + state status owner event-time comment fail-count pass-count area-id last-update publish-time) + (debug:print-info 0 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id ) + (if (not (equal? run-tag "")) + (task:add-run-tag dbh new-run-id run-tag)) + new-run-id) + + (if (equal? state "deleted") + (begin + (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) + (if (handle-exceptions + exn + (begin (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + + (pgdb:insert-run + dbh + spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) + (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) + #f))))))) + +(define (task:add-run-tag dbh run-id tag) + (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) + (if (not tag-info) + (begin + (if (handle-exceptions + exn + (begin + (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + #f) + (pgdb:insert-tag dbh tag)) + (set! tag-info (pgdb:get-tag-info-by-name dbh tag)) + #f))) + ;;add to area_tags + (handle-exceptions + exn + (begin + (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + #f) + (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id)) + (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id))))) + + +(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) + ; (print "Sync Steps " test-step-ids ) + (let ((test-ht (hash-table-ref cached-info 'tests)) + (step-ht (hash-table-ref cached-info 'steps))) + (for-each + (lambda (test-step-id) + (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id)) + (step-id (tdb:step-get-id test-step-info)) + (test-id (tdb:step-get-test_id test-step-info)) + (stepname (tdb:step-get-stepname test-step-info)) + (state (tdb:step-get-state test-step-info)) + (status (tdb:step-get-status test-step-info)) + (event_time (tdb:step-get-event_time test-step-info)) + (comment (tdb:step-get-comment test-step-info)) + (logfile (tdb:step-get-logfile test-step-info)) + (last-update (tdb:step-get-last_update test-step-info)) + (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) + (pgdb-step-id (if pgdb-test-id + (pgdb:get-test-step-id dbh pgdb-test-id stepname state) + #f))) + (if step-id + (begin + (if pgdb-test-id + (begin + (if pgdb-step-id + (begin + (debug:print-info 1 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id ) + (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update)) + (begin + (debug:print-info 1 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update ) + (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state)))) + (hash-table-set! step-ht step-id pgdb-step-id )) + (debug:print-info 1 *default-log-port* "Error: Test not cashed"))) + (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug + test-step-ids))) + +(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) + (let ((test-ht (hash-table-ref cached-info 'tests)) + (data-ht (hash-table-ref cached-info 'data))) + (for-each + (lambda (test-data-id) + (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) + (data-id (db:test-data-get-id test-data-info)) + (test-id (db:test-data-get-test_id test-data-info)) + (category (db:test-data-get-category test-data-info)) + (variable (db:test-data-get-variable test-data-info)) + (value (db:test-data-get-value test-data-info)) + (expected (db:test-data-get-expected test-data-info)) + (tol (db:test-data-get-tol test-data-info)) + (units (db:test-data-get-units test-data-info)) + (comment (db:test-data-get-comment test-data-info)) + (status (db:test-data-get-status test-data-info)) + (type (db:test-data-get-type test-data-info)) + (last-update (db:test-data-get-last_update test-data-info)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) + + (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) + (pgdb-data-id (if pgdb-test-id + (pgdb:get-test-data-id dbh pgdb-test-id category variable) + #f))) + (if data-id + (begin + (if pgdb-test-id + (begin + (if pgdb-data-id + (begin + (debug:print-info 1 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id) + (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update)) + (begin + (debug:print-info 1 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) + (if (handle-exceptions + exn + (begin (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + + (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update)) + ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) + (begin + ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))) + #f))) + (hash-table-set! data-ht data-id pgdb-data-id )) + (begin + (debug:print-info 1 *default-log-port* "Error: Test not in pgdb")))) + + (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug + test-data-ids))) + + + +(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) + (let ((test-ht (hash-table-ref cached-info 'tests))) + (for-each + (lambda (test-id) + ; (print test-id) + (let* ((test-info (rmt:get-test-info-by-id #f test-id)) + (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm + (test-id (db:test-get-id test-info)) + (test-name (db:test-get-testname test-info)) + (item-path (db:test-get-item-path test-info)) + (state (db:test-get-state test-info)) + (status (db:test-get-status test-info)) + (host (db:test-get-host test-info)) + (pid (db:test-get-process_id test-info)) + (cpuload (db:test-get-cpuload test-info)) + (diskfree (db:test-get-diskfree test-info)) + (uname (db:test-get-uname test-info)) + (run-dir (db:test-get-rundir test-info)) + (log-file (db:test-get-final_logf test-info)) + (run-duration (db:test-get-run_duration test-info)) + (comment (db:test-get-comment test-info)) + (event-time (db:test-get-event_time test-info)) + (archived (db:test-get-archived test-info)) + (last-update (db:test-get-last_update test-info)) + (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) + (pgdb-test-id (if pgdb-run-id + (begin + ;(print pgdb-run-id) + (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) + #f))) + ;; "id" "run_id" "testname" "state" "status" "event_time" + ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" + ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" + (if pgdb-run-id + (begin + (if pgdb-test-id ;; have a record + (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) + (debug:print-info 0 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id) + (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time. + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)) + (begin + (debug:print-info 0 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) + (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) + (hash-table-set! test-ht test-id pgdb-test-id)) + (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) + test-ids))) + +(define (task:add-area-tag dbh area-info tag) + (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) + (if (not tag-info) + (begin + (if (handle-exceptions + exn + (begin + (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + #f) + (pgdb:insert-tag dbh tag)) + (set! tag-info (pgdb:get-tag-info-by-name dbh tag)) + #f))) + ;;add to area_tags + (handle-exceptions + exn + (begin + (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + #f) + (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))) + (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))))) + +(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) + (for-each + (lambda (run-id) + (debug:print-info 1 *default-log-port* "Check if run with " run-id " needs to be synced" ) + (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) +run-ids)) + + +;; get runs changed since last sync +;; (define (tasks:sync-test-data dbh cached-info area-info) +;; (let* (( + +(define (tasks:sync-to-postgres configdat dest) + (print "In sync") + (let* ((dbh (pgdb:open configdat dbname: dest)) + (area-info (pgdb:get-area-by-path dbh *toppath*)) + (cached-info (make-hash-table)) + (start (current-seconds)) + (test-patt (if (args:get-arg "-testpatt") + (args:get-arg "-testpatt") + "%")) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + (run-name (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f))) + (if (and target (not run-name)) + (begin + (print "Error: Provide runname") + (exit 1))) + (if (and (not target) run-name) + (begin + (print "Error: Provide target") + (exit 1))) + ;(print "123") + ;(exit 1) + (for-each (lambda (dtype) + (hash-table-set! cached-info dtype (make-hash-table))) + '(runs targets tests steps data)) + (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this + (if area-info + (let* ((last-sync-time (vector-ref area-info 3)) + (smallest-last-update-time (make-hash-table)) + (changed (if (and target run-name) + (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt) + (rmt:get-changed-record-ids last-sync-time))) + (run-ids (alist-ref 'runs changed)) + (test-ids (alist-ref 'tests changed)) + (test-step-ids (alist-ref 'test_steps changed)) + (test-data-ids (alist-ref 'test_data changed)) + (run-stat-ids (alist-ref 'run_stats changed)) + (area-tag (if (args:get-arg "-area-tag") + (args:get-arg "-area-tag") + (if (args:get-arg "-area") + (args:get-arg "-area") + "")))) + (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) + (set! area-tag *default-area-tag*)) + (if (not (equal? area-tag "")) + (task:add-area-tag dbh area-info area-tag)) + (if (or (not (null? test-ids)) (not (null? run-ids))) + (begin + (debug:print-info 0 *default-log-port* "syncing runs") + (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing tests") + (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing test steps") + (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing test data") + (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) + (print "----------done---------------"))) + (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) + (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time) + (if (not (and target run-name)) + (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) + (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed + (if (tasks:set-area dbh configdat) + (tasks:sync-to-postgres configdat dest) + (begin + (debug:print 0 *default-log-port* "ERROR: unable to create an area record") + #f))))) )