;;======================================================================
;; Copyright 2019, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit mtmod))
(declare (uses mtconfigf))
(declare (uses commonmod))
(declare (uses rmtmod))
(declare (uses testsmod))
(module mtmod
*
(import scheme chicken data-structures extras posix)
(import (prefix mtconfigf configf:)
commonmod
rmtmod
testsmod)
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
;;======================================================================
;; R U N S
;;======================================================================
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
(let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0))
(res '())
(offset 0)
(limit 500))
;; (print "runsdat: " runsdat)
(let* ((header (vector-ref runsdat 0))
(runslst (vector-ref runsdat 1))
(full-list (append res runslst))
(have-more (eq? (length runslst) limit)))
;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more)
(if have-more
(let ((new-offset (+ offset limit))
(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0)))
(debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.")
(debug:print-info 0 *default-log-port* "next-batch: " next-batch)
(loop next-batch
full-list
new-offset
limit))
(vector header full-list)))))
;;======================================================================
;; T E S T S
;;======================================================================
(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f))
(let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal))
(res '())
(offset 0)
(limit 500))
(let* ((full-list (append res testsdat))
(have-more (eq? (length testsdat) limit)))
(if have-more
(let ((new-offset (+ offset limit)))
(debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.")
(loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal)
full-list
new-offset
limit))
full-list))))
(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) )
(let* ((key (list run-id waitons ref-item-path mode))
(res (hash-table-ref/default *pre-reqs-met-cache* key #f))
(useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
(if last-time
(< (current-seconds)(+ last-time 5))
#f))))
(if useres
(let ((result (vector-ref res 1)))
(debug:print 4 *default-log-port* "Using lazy value res: " result)
result)
(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
(hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
newres))))
(define (mt:get-run-stats dbstruct run-id)
;; Get run stats from local access, move this ... but where?
(db:get-run-stats dbstruct run-id))
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
(remt (cdr tests))
(res '()))
(let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
(waitons (vector-ref test-dat 2)))
;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
(if (null? remt)
(let ((new-res (reverse res)))
;; (print " new-res: " new-res)
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
;;======================================================================
;; S T A T E A N D S T A T U S F O R T E S T S
;;======================================================================
;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(if (not (and run-id test-id))
(begin
(debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
(print-call-chain (current-error-port))
#f)
(begin
;; cond
;; ((and newstate newstatus newcomment)
;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
;; ((and newstate newstatus)
;; (rmt:general-call 'state-status run-id newstate newstatus test-id))
;; (else
;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
(rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
;; (mt:process-triggers run-id test-id newstate newstatus)
#t)))
(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment)
(let* ((test-vec (rmt:get-testinfo-state-status run-id test-id))
(state (vector-ref test-vec 3)))
(if (equal? state "COMPLETED")
#t
(rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment))))
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
;(let ((test-id (rmt:get-test-id run-id test-name item-path)))
(rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
;; (mt:process-triggers run-id test-id new-state new-status)
#t);)
;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
(let ((test-id (rmt:get-test-id run-id test-name item-path)))
(mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
;; 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 (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: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) "/")) (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)))))
;;======================================================================
;; L O C K I N G M E C H A N I S M S
;;======================================================================
;; faux-lock is deprecated. Please use simple-lock below
;;
(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
(if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
(if (> wait-time 0)
(begin
(thread-sleep! 1)
(if (eq? wait-time 1) ;; only one second left, steal the lock
(begin
(debug:print-info 0 *default-log-port* "stealing lock for " keyname)
(common:faux-unlock keyname force: #t)))
(common:faux-lock keyname wait-time: (- wait-time 1)))
#f)
(begin
(rmt:no-sync-set keyname (conc (current-process-id)))
(equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))))
(define (common:faux-unlock keyname #!key (force #f))
(if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))
(begin
(if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
#t)
#f))
;; simple lock. improve and converge on this one.
;;
(define (common:simple-lock keyname)
(rmt:no-sync-get-lock keyname))
(define (common:simple-unlock keyname #!key (force #f))
(rmt:no-sync-del! keyname))
)