@@ -22,11 +22,10 @@ (declare (uses pgdb)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses dbmod)) (declare (uses margsmod)) -(declare (uses rmtmod)) (module tasks * (import scheme chicken data-structures extras) @@ -36,11 +35,10 @@ (import commonmod) (import configfmod) (import dbmod) (import margsmod) (import pgdb) -(import rmtmod) (include "task_records.scm") ;; (include "db_records.scm") ;;====================================================================== @@ -490,52 +488,10 @@ 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))) @@ -612,30 +568,10 @@ (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)) @@ -659,123 +595,11 @@ (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 10 *default-log-port* "db-contour" 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 - (base-target (rmt:get-target run-id)) - (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) "/")) base-target) base-target)) ;; 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 (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f))) - (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 4 *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 (or (not state) (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 @@ -795,168 +619,10 @@ #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 4 *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 4 *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 4 *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 4 *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 (or (not item-path) (string-null? item-path)) - (debug:print-info 0 *default-log-port* "Working on Run id : " run-id "and test name : " test-name)) - (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 4 *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 4 *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 @@ -982,81 +648,6 @@ (debug:print-info 4 *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" (current-seconds)))) - (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))))) - )