Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -6,11 +6,12 @@ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm + tree.scm rmt.scm api.scm tdb.scm \ + ezsteps.scm lock-queue.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADDED api.scm Index: api.scm ================================================================== --- /dev/null +++ api.scm @@ -0,0 +1,55 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(declare (unit api)) +(declare (uses rmt)) +(declare (uses db)) + +;; These are called by the server on recipt of /api calls + +(define (api:execute-requests db cmd params) + (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params) + (db:process-cached-writes db) + (case (string->symbol cmd) + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) + ;; TESTS + ;; json doesn't do vectors, convert to list + ((get-test-info-by-id) (vector->list (apply db:get-test-info-by-id db params))) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) + ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params))) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) + ;; RUNS + ((get-run-info) (let ((res (apply db:get-run-info db params))) + (list (vector-ref res 0) + (vector->list (vector-ref res 1))))) + (else + (list "ERROR" 0)))) + +;; http-server send-response +;; api:process-request +;; db:* +;; +;; NB// Runs on the server as part of the server loop +;; +(define (api:process-request db $) ;; the $ is the request vars proc + (let* ((cmd ($ 'cmd)) + (paramsj ($ 'params)) + (params (rmt:json-str->dat paramsj)) + (res (api:execute-requests db cmd params))) + (rmt:dat->json-str + (if (or (string? res) + (list? res) + (number? res) + (boolean? res)) + res + (list "ERROR" 1 cmd params res))))) + Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -24,10 +24,11 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) +(declare (uses rmt)) (declare (uses ezsteps)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -206,21 +207,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (open-run-close db:test-set-state-status-by-id #f test-id #f #f b) + (rmt:test-set-state-status-by-id test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id state #f #f) + (rmt:test-set-state-status-by-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -236,11 +237,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id #f status #f) + (rmt:test-set-state-status-by-id test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -284,16 +285,105 @@ ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) +;; get a pretty table to summarize steps +;; +(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (db:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (db:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)) + (case (string->symbol (db:step-get-state step)) + ((start)(vector-set! record 1 (db:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (db:step-get-status step))) + (if (> (string-length (db:step-get-logfile step)) + 0) + (vector-set! record 5 (db:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (db:step-get-event_time step))) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (db:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (db:step-get-logfile step)) + 0) + (vector-set! record 5 (db:step-get-logfile step)))) + (else + (vector-set! record 2 (db:step-get-state step)) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (db:step-get-event_time step)))) + (hash-table-set! res (db:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)))) + ;; (else (vector-set! record 1 (db:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) + ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) + (< (db:step-get-id a) (db:step-get-id b))) + (else #f))))) + res)) + +(define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f)) + (if (or (not work-area) + (file-exists? (conc work-area "/testdat.db"))) + (let* ((steps-data (rmt:get-steps-for-test test-id work-area)) + (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update (handle-exceptions exn - (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (open-run-close db:get-test-info-by-id #f test-id ))))) + (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) + (rmt:get-test-info-by-id test-id ))))) + ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) + (set! teststeps (dashboard-tests:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) (if (eq? curr-mod-time db-mod-time) ;; do only once if same @@ -534,22 +625,22 @@ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (let ((max-row 0)) - (if (not (null? teststeps)) - (let loop ((hed (car teststeps)) - (tal (cdr teststeps)) - (rownum 1) - (colnum 1)) + (if (not (null? teststeps)) + (let loop ((hed (car teststeps)) + (tal (cdr teststeps)) + (rownum 1) + (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) - (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 6) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) @@ -601,11 +692,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (open-run-close db:read-test-data #f test-id "%"))) + (rmt:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -39,10 +39,11 @@ (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2013 @@ -63,10 +64,11 @@ (list "-rows" "-run" "-test" "-debug" "-host" + "-transport" ) (list "-h" "-use-server" "-guimonitor" "-main" @@ -90,12 +92,14 @@ (if (args:get-arg "-host") (begin (set! *runremote* (string-split (args:get-arg "-host" ":"))) (client:launch)) - (if (not (args:get-arg "-use-server")) - (set! *transport-type* 'fs) ;; force fs access + (if (args:get-arg "-transport") + (begin + (set! *transport-type* (string->symbol (args:get-arg "-transport"))) ;; force fs access + (client:launch)) (client:launch))) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (client:setup *db*) @@ -1383,12 +1387,12 @@ (if (not update-is-running) (set! *update-is-running* #t)) (mutex-unlock! *update-mutex*) (if (not update-is-running) (begin - (dashboard:run-update x) + (dashboard:run-update x) (mutex-lock! *update-mutex*) (set! *update-is-running* #f) (mutex-unlock! *update-mutex*)))) 1)))) (iup:main-loop) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -868,12 +868,12 @@ (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) - (if mykeyvals - mykeyvals + (if mykeyvals + mykeyvals (let* ((keys (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) (for-each (lambda (key) @@ -883,13 +883,13 @@ (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) - (let ((final-res (reverse res))) - (hash-table-set! *keyvals* run-id final-res) - final-res))))) + (let ((final-res (reverse res))) + (hash-table-set! *keyvals* run-id final-res) + final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target db run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg @@ -1123,11 +1123,12 @@ (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))) - (db:process-triggers test-id newstate newstatus)) + (db:process-triggers test-id newstate newstatus) + #t) ;; retrun something to keep the remote calls happy ;; Never used ;; (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) ;; (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" ;; state status run-id test-name item-path)) @@ -1297,22 +1298,18 @@ (define (cdb:test-set-rundir-by-test-id serverdat test-id rundir) (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id)) (define (db:test-get-rundir-from-test-id db test-id) - (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f))) - ;; (if res - ;; res - ;; (begin + (let ((res #f)) (sqlite3:for-each-row (lambda (tpath) (set! res tpath)) db "SELECT rundir FROM tests WHERE id=?;" test-id) - ;; (hash-table-set! *test-paths* test-id res) - res)) ;; )) + res)) (define (cdb:test-set-log! serverdat test-id logf) (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id))) ;;====================================================================== @@ -1551,10 +1548,14 @@ (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) (if msg (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id) (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) + +;; Set the test event_time to current time. Call this when setting a test to LAUNCHED or REMOTEHOSTSTART +;; (define (cdb:set-test-start-time! serverdat test-id) +;; (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) (define (cdb:test-rollup-test_data-pass-fail serverdat test-id) (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) (define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) @@ -1959,24 +1960,10 @@ (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist) (sqlite3:finalize! tdb))))) -;; get a list of test_data records matching categorypatt -(define (db:read-test-data db test-id categorypatt #!key (work-area #f)) - (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb - (let ((res '())) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - tdb - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (sqlite3:finalize! tdb) - (reverse res)) - '()))) - ;; NOTE: Run this local with #f for db !!! (define (db:load-test-data db test-id #!key (work-area #f)) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin @@ -2043,86 +2030,10 @@ ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) -;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id #!key (work-area #f)) - (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) - (res '())) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res)) - '()))) - -;; get a pretty table to summarize steps -;; -(define (db:get-steps-table db test-id #!key (work-area #f)) - (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (db:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (db:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)) - (case (string->symbol (db:step-get-state step)) - ((start)(vector-set! record 1 (db:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (db:step-get-status step))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (db:step-get-event_time step))) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (db:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - (else - (vector-set! record 2 (db:step-get-state step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (db:step-get-event_time step)))) - (hash-table-set! res (db:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)))) - ;; (else (vector-set! record 1 (db:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) - ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) - (< (db:step-get-id a) (db:step-get-id b))) - (else #f))))) - res))) - ;; get a pretty table to summarize steps ;; (define (db:get-steps-table-list db test-id #!key (work-area #f)) (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability @@ -2179,38 +2090,10 @@ ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) -(define (db:get-compressed-steps test-id #!key (work-area #f)) - (if (or (not work-area) - (file-exists? (conc work-area "/testdat.db"))) - (let* ((comprsteps (open-run-close db:get-steps-table #f test-id work-area: work-area))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (stringobj dat)) @@ -174,10 +181,52 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) +(define *http-requests-in-progress* 0) +(define *http-connections-next-cleanup* (current-seconds)) + +(define (http-transport:get-time-to-cleanup) + (let ((res #f)) + (mutex-lock! *http-mutex*) + (set! res (> (current-seconds) *http-connections-next-cleanup*)) + (mutex-unlock! *http-mutex*) + res)) + +(define (http-transport:inc-requests-count) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) + ;; Use this opportunity to slow things down iff there are too many requests in flight + (if (> *http-requests-in-progress* 5) + (begin + (debug:print-info 0 "Whoa there buddy, ease up...") + (thread-sleep! 1))) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count proc) + (mutex-lock! *http-mutex*) + (proc) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count-and-close-all-connections) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds + (if (> *http-requests-in-progress* 0) + (if (> etime (current-seconds)) + (begin + (thread-sleep! 0.05) + (loop etime)) + (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (close-all-connections!))) + (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:inc-requests-and-prep-to-close-all-connections) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4") ;; ;; @@ -209,17 +258,34 @@ ;; #t)) ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. (let* ((send-recieve (lambda () - (mutex-lock! *http-mutex*) - (set! res (with-input-from-request - fullurl - (list (cons 'dat msg)) - read-string)) - (close-all-connections!) - (mutex-unlock! *http-mutex*))) + ;; (let ((dat #f) + ;; (cleanup (http-transport:get-time-to-cleanup))) + ;; (if cleanup + ;; (begin + ;; (debug:print-info 0 "Running cleanup mode") + ;; (http-transport:inc-requests-and-prep-to-close-all-connections)) + ;; (http-transport:inc-requests-count)) + ;; ;; Do the actual data transfer + (mutex-lock! *http-mutex*) ;; Hypothesis is that this was *not* the bottleneck + (set! res (with-input-from-request ;; was set! dat + fullurl + (list (cons 'dat msg)) + read-string)) + (close-all-connections!) + (mutex-unlock! *http-mutex*) + )) + ;;(if cleanup + ;; ;; mutex already set + ;; (begin + ;; (set! res dat) + ;; (http-transport:dec-requests-count-and-close-all-connections)) + ;; (http-transport:dec-requests-count + ;; (lambda () + ;; (set! res dat))))))) (time-out (lambda () (thread-sleep! 45) (if (not res) (begin (debug:print 0 "WARNING: communication with the server timed out.") @@ -239,15 +305,95 @@ (let ((match (string-search (regexp "(.*)<.body>") res))) (debug:print-info 11 "match=" match) (let ((final (cadr match))) (debug:print-info 11 "final=" final) final))))))) + +;; Send "cmd" with json payload "params" to serverdat and receive result +;; +(define (http-transport:client-api-send-receive serverdat cmd params #!key (numretries 30)) + (let* ((fullurl (if (list? serverdat) + (cadddr serverdat) ;; this is the uri for /api + (begin + (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info") + (exit 1)))) + (res #f)) + (handle-exceptions + exn + (begin + ;; TODO: Send this output to a log file so it isn't lost when running as daemon + (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 2) + (if (> numretries 0) + (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1)))) + (begin + (debug:print-info 11 "fullurl=" fullurl "\n") + ;; set up the http-client here + (max-retry-attempts 5) + ;; consider all requests indempotent + (retry-request? (lambda (request) + #t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) + ;; (set! numretries (- numretries 1)) + ;; #t)) + ;; send the data and get the response + ;; extract the needed info from the http data and + ;; process and return it. + + ;; (with-input-from-request "http://localhost/echo-service" + ;; '((test . "value")) read-string) + + (let* ((send-recieve (lambda () + ;; (let ((dat #f) + ;; (cleanup (http-transport:get-time-to-cleanup))) + ;; (if cleanup + ;; (http-transport:inc-requests-and-prep-to-close-all-connections) + ;; (http-transport:inc-requests-count)) + ;; ;; Do the actual data transfer NB// KEPP THIS IN SYNC WITH http-transport:client-send-receive + (mutex-lock! *http-mutex*) + (set! res (with-input-from-request ;; was dat + fullurl + (list (cons 'key "thekey") + (cons 'cmd cmd) + (cons 'params params)) + read-string)) + ;; Shouldn't this be a call to the managed call-all-connections stuff above? + (close-all-connections!) + (mutex-unlock! *http-mutex*) + )) + ;; (if cleanup + ;; ;; mutex already set + ;; (begin + ;; (set! res dat) + ;; (http-transport:dec-requests-count-and-close-all-connections)) + ;; (http-transport:dec-requests-count + ;; (lambda () + ;; (set! res dat))))))) + (time-out (lambda () + (thread-sleep! 45) + (if (not res) + (begin + (debug:print 0 "WARNING: communication with the server timed out.") + (mutex-unlock! *http-mutex*) + (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1)) + (if (< numretries 3) ;; on last try just exit + (begin + (debug:print 0 "ERROR: communication with the server timed out. Giving up.") + (exit 1))))))) + (th1 (make-thread send-recieve "with-input-from-request")) + (th2 (make-thread time-out "time out"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (thread-terminate! th2) + (debug:print-info 11 "got res=" res) + res))))) (define (http-transport:client-connect iface port) (let* ((login-res #f) (uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl")))) - (serverdat (list iface port uri-dat))) + (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api")))) + (serverdat (list iface port uri-dat uri-api-dat))) (set! login-res (client:login serverdat)) (if (and (not (null? login-res)) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -137,10 +137,11 @@ (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-full-meta-info #f test-id run-id 0 work-area) (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + ;; (cdb:set-test-start-time! *runremote* test-id) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -674,10 +675,11 @@ ;; clean out step records from previous run if they exist ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") ;; (open-run-close db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + ;; (cdb:set-test-start-time! *runremote* test-id) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -25,10 +25,12 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +(declare (uses mt)) +(declare (uses api)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") ADDED rmt.scm Index: rmt.scm ================================================================== --- /dev/null +++ rmt.scm @@ -0,0 +1,134 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use json) + +(declare (unit rmt)) +(declare (uses api)) +(declare (uses tdb)) +(declare (uses http-transport)) + +;; +;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! +;; + +;;====================================================================== +;; S U P P O R T F U N C T I O N S +;;====================================================================== + +;; cmd is a symbol +;; vars is a json string encoding the parameters for the call +;; +(define (rmt:send-receive cmd params) + (case *transport-type* + ((fs) + (debug:print 0 "ERROR: Not yet (re)supported") + (exit 1)) + ((http) + (let* ((jparams (rmt:dat->json-str params)) + (res (http-transport:client-api-send-receive *runremote* cmd jparams))) + (if res + (rmt:json-str->dat res) + (begin + (debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res) + #f)) + )) + (else + (debug:print 0 "ERROR: Transport not yet (re)supported") + (exit 1)))) + +;; Wrap json library for strings (why the ports crap in the first place?) +(define (rmt:dat->json-str dat) + (with-output-to-string + (lambda () + (json-write dat)))) + +(define (rmt:json-str->dat json-str) + (with-input-from-string json-str + (lambda () + (json-read)))) + +;;====================================================================== +;; +;; A C T U A L A P I C A L L S +;; +;;====================================================================== + +;;====================================================================== +;; K E Y S +;;====================================================================== + +(define (rmt:get-key-val-pairs run-id) + (rmt:send-receive 'get-key-val-pairs (list run-id))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (rmt:get-test-info-by-id test-id) + (list->vector + (rmt:send-receive 'get-test-info-by-id (list test-id)))) + +(define (rmt:test-get-rundir-from-test-id test-id) + (rmt:send-receive 'test-get-rundir-from-test-id (list test-id))) + +(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) + (let* ((test-path (if (string? work-area) + work-area + (rmt:test-get-rundir-from-test-id test-id)))) + (debug:print 3 "TEST PATH: " test-path) + (open-test-db test-path))) + +(define (rmt:testmeta-get-record testname) + (list->vector + (rmt:send-receive 'testmeta-get-record (list testname)))) + +;; WARNING: This currently bypasses the transaction wrapped writes system +(define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment) + (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +(define (rmt:get-run-info run-id) + (let ((res (rmt:send-receive 'get-run-info (list run-id)))) + (vector (car res) + (list->vector (cadr res))))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; Getting steps is more complicated. +;; +;; If given work area +;; 1. Find the testdat.db file +;; 2. Open the testdat.db file and do the query +;; If not given the work area +;; 1. Do a remote call to get the test path +;; 2. Continue as above +;; +(define (rmt:get-steps-for-test test-id #!key (work-area #f)) + (let* ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) + (if tdb + (tdb:get-steps-data tdb test-id) + '()))) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== + +(define (rmt:read-test-data test-id categorypatt #!key (work-area #f)) + (let ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) + (if tdb + (tdb:read-test-data tdb test-id categorypatt) + '()))) ADDED rmtdb.scm Index: rmtdb.scm ================================================================== --- /dev/null +++ rmtdb.scm @@ -0,0 +1,11 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + ADDED tdb.scm Index: tdb.scm ================================================================== --- /dev/null +++ tdb.scm @@ -0,0 +1,64 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Database access +;;====================================================================== + +(require-extension (srfi 18) extras tcp) ;; rpc) +;; (import (prefix rpc rpc:)) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +;; Note, try to remove this dependency +;; (use zmq) + +(declare (unit tdb)) +(declare (uses common)) +(declare (uses keys)) +(declare (uses ods)) +(declare (uses fs-transport)) +(declare (uses client)) +(declare (uses mt)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") + +;;====================================================================== +;; +;; T E S T D A T A B A S E S +;; +;;====================================================================== + +(define (tdb:get-steps-data tdb test-id) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + tdb + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (sqlite3:finalize! tdb) + (reverse res))) + +(define (tdb:read-test-data tdb test-id categorypatt) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + tdb + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) + (sqlite3:finalize! tdb) + (reverse res)))