Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -23,115 +23,12 @@ (declare (unit api)) (declare (uses rmt)) (declare (uses db)) (declare (uses tasks)) -;; allow these queries through without starting a server -;; -(define api:read-only-queries - '(get-key-val-pairs - get-var - get-keys - get-key-vals - test-toplevel-num-items - get-test-info-by-id - get-steps-info-by-id - get-data-info-by-id - test-get-rundir-from-test-id - get-count-tests-running-for-testname - get-count-tests-running - get-count-tests-running-in-jobgroup - get-previous-test-run-record - get-matching-previous-test-run-records - test-get-logfile-info - test-get-records-for-index-file - get-testinfo-state-status - test-get-top-process-pid - test-get-paths-matching-keynames-target-new - get-prereqs-not-met - get-count-tests-running-for-run-id - get-run-info - get-run-status - get-run-state - get-run-stats - get-run-times - get-targets - get-target - ;; register-run - get-tests-tags - get-test-times - get-tests-for-run - get-test-id - get-tests-for-runs-mindata - get-tests-for-run-mindata - get-run-name-from-id - get-runs - simple-get-runs - get-num-runs - get-runs-cnt-by-patt - get-all-run-ids - get-prev-run-ids - get-run-ids-matching-target - get-runs-by-patt - get-steps-data - get-steps-for-test - read-test-data - read-test-data* - login - tasks-get-last - testmeta-get-record - have-incompletes? - synchash-get - get-changed-record-ids - get-run-record-ids - get-not-completed-cnt)) - -(define api:write-queries - '( - get-keys-write ;; dummy "write" query to force server start - - ;; SERVERS - start-server - kill-server - - ;; TESTS - test-set-state-status-by-id - delete-test-records - delete-old-deleted-test-records - test-set-state-status - test-set-top-process-pid - set-state-status-and-roll-up-items - - update-pass-fail-counts - top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") - - ;; RUNS - register-run - set-tests-state-status - delete-run - lock/unlock-run - update-run-event_time - mark-incomplete - set-state-status-and-roll-up-run - ;; STEPS - teststep-set-status! - delete-steps-for-test - ;; TEST DATA - test-data-rollup - csv->test-data - - ;; MISC - sync-inmem->db - - ;; TESTMETA - testmeta-add-record - testmeta-update-field - - ;; TASKS - tasks-add - tasks-set-state-given-param-key - )) +;; 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 ) @@ -159,11 +56,11 @@ (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 + #;(foo (begin (common:telemetry-log (conc "api-in:"(->string cmd)) payload: `((params . ,params))) #t)) (res @@ -329,12 +226,12 @@ (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)) + ((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)) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -24,18 +24,20 @@ ;; globals - modules that include this need these here (define *verbosity-cache* (make-hash-table)) (define *verbosity* 0) (define *default-log-port* (current-error-port)) (define *logging* #f) -(define *functions* (make-hash-table)) ;; symbol => fn +(define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!! ;; (define *toppath* #f) (define *transport-type* 'http) (define (exec-fn fn . params) (if (hash-table-exists? *functions* fn) (apply (hash-table-ref *functions* fn) params) - #f)) + (begin + (debug:print-error 0 "exec-fn " fn " not found") + #f))) (define (set-fn fn-name fn) (hash-table-set! *functions* fn-name fn)) (include "altdb.scm") @@ -79,10 +81,132 @@ (vector-set! vec 5 (current-seconds)) (begin (print-call-chain (current-error-port)) (debug:print-error 0 *default-log-port* "call to http-transport:server-dat-update-last-access with non-vector!!")))) +;;====================================================================== +;; +;;====================================================================== + + +;; allow these queries through without starting a server +;; +(define api:read-only-queries + '(get-key-val-pairs + get-var + get-keys + get-key-vals + test-toplevel-num-items + get-test-info-by-id + get-steps-info-by-id + get-data-info-by-id + test-get-rundir-from-test-id + get-count-tests-running-for-testname + get-count-tests-running + get-count-tests-running-in-jobgroup + get-previous-test-run-record + get-matching-previous-test-run-records + test-get-logfile-info + test-get-records-for-index-file + get-testinfo-state-status + test-get-top-process-pid + test-get-paths-matching-keynames-target-new + get-prereqs-not-met + get-count-tests-running-for-run-id + get-run-info + get-run-status + get-run-state + get-run-stats + get-run-times + get-targets + get-target + ;; register-run + get-tests-tags + get-test-times + get-tests-for-run + get-test-id + get-tests-for-runs-mindata + get-tests-for-run-mindata + get-run-name-from-id + get-runs + simple-get-runs + get-num-runs + get-runs-cnt-by-patt + get-all-run-ids + get-prev-run-ids + get-run-ids-matching-target + get-runs-by-patt + get-steps-data + get-steps-for-test + read-test-data + read-test-data* + login + tasks-get-last + testmeta-get-record + have-incompletes? + synchash-get + get-changed-record-ids + get-run-record-ids + get-not-completed-cnt)) + +(define api:write-queries + '( + get-keys-write ;; dummy "write" query to force server start + + ;; SERVERS + start-server + kill-server + + ;; TESTS + test-set-state-status-by-id + delete-test-records + delete-old-deleted-test-records + test-set-state-status + test-set-top-process-pid + set-state-status-and-roll-up-items + + update-pass-fail-counts + top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") + + ;; RUNS + register-run + set-tests-state-status + delete-run + lock/unlock-run + update-run-event_time + mark-incomplete + set-state-status-and-roll-up-run + ;; STEPS + teststep-set-status! + delete-steps-for-test + ;; TEST DATA + test-data-rollup + csv->test-data + + ;; MISC + sync-inmem->db + + ;; TESTMETA + testmeta-add-record + testmeta-update-field + + ;; TASKS + tasks-add + tasks-set-state-given-param-key + )) + +;;====================================================================== +;; ALLDATA +;;====================================================================== +;; +;; attempt to consolidate a bunch of global information into one struct to toss around +(defstruct alldat + (toppath #f) + (read-only-queries api:read-only-queries) + (write-queries api:write-queries)) + +(define *alldata* (make-alldat)) ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -28,10 +28,11 @@ (import rmtmod) (set-fn 'server:expiration-timeout server:expiration-timeout) (set-fn 'common:get-homehost common:get-homehost) (set-fn 'server:check-if-running server:check-if-running) +(set-fn 'api:execute-requests api:execute-requests) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; @@ -69,11 +70,11 @@ (begin (mutex-lock! *send-receive-mutex*) (let ((ulex:conn (remote-ulex:conn runremote))) (if (not ulex:conn)(remote-ulex:conn-set! runremote (rmtmod:setup-ulex areapath))) (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat))) - (rmt:send-receive-orig *default-log-port* runremote *rmt-mutex* areapath *db-multi-sync-mutex* cmd rid params attemptnum: attemptnum area-dat: area-dat ro-queries: api:read-only-queries)))) + (rmt:send-receive-orig *default-log-port* runremote *rmt-mutex* areapath *db-multi-sync-mutex* cmd rid params *alldata* attemptnum: attemptnum area-dat: area-dat)))) ;; bunch of small functions factored out of send-receive to make debug easier ;; ;; (define (rmt:update-db-stats run-id rawcmd params duration) @@ -690,13 +691,13 @@ (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) (set-functions http-transport:client-api-send-receive ;; a http-transport:close-connections ;; b api:execute-requests ;; c - api:read-only-queries ;; d + #f client:setup ;; e server:kind-run ;; f server:start-and-wait ;; g server:check-if-running ;; h server:ping ;; i common:force-server? ;; j ) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -33,12 +33,11 @@ ;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time. ;; (define (rmt:send-receive . params) #f) (define (http-transport:close-connections . params) #f) ;; from remote defstruct in common.scm -(define (api:execute-requests . params) #f) -(define (api:read-only-queries . params) #f) +;; (define (api:execute-requests . params) #f) (define (http-transport:client-api-send-receive . params) #f) (define (client:setup . params) #f) (define (server:kind-run . params) #f) (define (server:start-and-wait . params) #f) (define (server:check-if-running . params) #f) @@ -49,27 +48,29 @@ (match alldata ((a b c d e f g h i j) ;; e f g h i j k l) (set! http-transport:client-api-send-receive a) (set! http-transport:close-connections b) - (set! apt:execute-requests d) + ;; (set! api:execute-requests c) + ;; d (set! client:setup e) (set! server:kind-run f) (set! server:start-and-wait g) (set! server:check-if-running h) (set! server:ping i) (set! common:force-server? j) ))) -(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params #!key (ro-queries '())(remretries 5)) - (let* ((qry-is-write (not (member cmd ro-queries))) +(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params alldat #!key (remretries 5)) + (let* ((ro-queries (alldat-read-only-queries alldat)) + (qry-is-write (not (member cmd ro-queries))) (db-file-path (exec-fn 'db:dbfile-path)) ;; 0)) (dbstruct-local (exec-fn 'db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) - (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) + (let ((v (exec-fn 'api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned 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)) (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy @@ -87,11 +88,11 @@ (if (not success) (if (> remretries 0) (begin (debug:print-error 0 log-port "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params ro-queries: ro-queries remretries: (- remretries 1))) + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params alldat remretries: (- remretries 1))) (begin (debug:print-error 0 log-port "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) @@ -122,21 +123,21 @@ ;;(mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 3") (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) #f) -(define (extras-transport-failed log-port rmt-mutex attemptnum runremote areapath cmd rid params) +(define (extras-transport-failed log-port rmt-mutex attemptnum runremote areapath cmd rid params alldat) (debug:print 0 log-port "WARNING: communication failed. Trying again, try num: " attemptnum) ;;(mutex-lock! rmt-mutex) (remote-conndat-set! runremote #f) (http-transport:close-connections area-dat: runremote) (remote-server-url-set! runremote #f) ;;(mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 9.1") - (rmt:send-receive-orig log-port runremote rmt-mutex areapath cmd rid params attemptnum: (+ attemptnum 1))) + (rmt:send-receive-orig log-port runremote rmt-mutex areapath cmd rid params alldat attemptnum: (+ attemptnum 1))) -(define (extras-transport-succeded log-port rmt-mutex attemptnum runremote areapath res params rid cmd) +(define (extras-transport-succeded log-port rmt-mutex attemptnum runremote areapath res params rid cmd alldat) (if (and (vector? res) (eq? (vector-length res) 2) (eq? (vector-ref res 1) 'overloaded)) ;; since we are ;; looking at the ;; data to carry the @@ -159,18 +160,18 @@ (http-transport:close-connections area-dat: runremote) ;; (set! *runremote* #f) ;; force starting over (remote-server-url-set! runremote #f) ;; I am hoping this will force a redo on server connection. NOT TESTED ;;(mutex-unlock! rmt-mutex) (thread-sleep! wait-delay) - (rmt:send-receive-orig log-port runremote rmt-mutex areapath cmd rid params attemptnum: (+ attemptnum 1))) + (rmt:send-receive-orig log-port runremote rmt-mutex areapath cmd rid params alldat attemptnum: (+ attemptnum 1))) res)) ;; All good, return res ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; ;; add multi-sync-mutex ;; -(define (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected +(define (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params alldat #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected #;(common:telemetry-log (conc "rmt:"(->string cmd)) payload: `((rid . ,rid) (params . ,params))) @@ -198,11 +199,11 @@ ;; readonly mode, read request- handle it - case 2 ((and readonly-mode (member cmd api:read-only-queries)) ;; (mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 2") - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params ro-queries: api:read-only-queries) + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat) ) ;; readonly mode, write request. Do nothing, return #f (readonly-mode (extras-readonly-mode rmt-mutex log-port cmd params)) @@ -218,21 +219,21 @@ (remote-server-timeout runremote)))) (debug:print-info 0 log-port "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") (http-transport:close-connections area-dat: runremote) (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. ;; (mutex-unlock! rmt-mutex) - (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params attemptnum: attemptnum)) + (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) ;; on homehost and this is a read ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required (pair? (remote-hh-dat runremote)) (cdr (remote-hh-dat runremote)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read ;; (mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 5") - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params ro-queries: api:read-only-queries)) + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)) ;; on homehost and this is a write, we already have a server, but server has died ((and (cdr (remote-hh-dat runremote)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write (remote-server-url runremote) ;; have a server @@ -239,20 +240,20 @@ (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. ;; (set! *runremote* (make-remote)) ;; WARNING - broken this. (remote-force-server-set! runremote (common:force-server?)) ;; (mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 6") - (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params attemptnum: attemptnum)) + (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) ;; on homehost and this is a write, we already have a server ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required (cdr (remote-hh-dat runremote)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write (remote-server-url runremote)) ;; have a server ;;(mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 4.1") - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params ro-queries: api:read-only-queries)) + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)) ;; on homehost, no server contact made and this is a write, passively start a server ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required (cdr (remote-hh-dat runremote)) ;; have homehost (not (remote-server-url runremote)) ;; no connection yet @@ -265,11 +266,11 @@ (server:start-and-wait toppath) (server:kind-run toppath)))) (remote-force-server-set! runremote (common:force-server?)) ;; (mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 8.1") - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params ro-queries: api:read-only-queries)) + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd 0 params alldat)) ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one (not (remote-conndat runremote))) (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost (not (remote-conndat runremote)))) ;; and no connection @@ -276,23 +277,23 @@ (debug:print-info 12 log-port "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote)) ;;(mutex-unlock! rmt-mutex) (if (not (server:check-if-running toppath)) ;; who knows, maybe one has started up? (server:start-and-wait toppath)) (remote-conndat-set! runremote (rmt:get-connection-info runremote toppath)) ;; calls client:setup which calls client:setup-http - (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as + (rmt:send-receive-orig log-port runremote rmt-mutex toppath multi-sync-mutex cmd rid params alldat attemptnum: attemptnum)) ;; TODO: add back-off timeout as ;; all set up if get this far, dispatch the query ((and (not (remote-force-server runremote)) (cdr (remote-hh-dat runremote))) ;; we are on homehost ;;(mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 10") - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd (if rid rid 0) params ro-queries: api:read-only-queries)) + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd (if rid rid 0) params alldat)) ;; not on homehost, do server query - (else (extras-case-11 log-port rmt-mutex runremote toppath cmd params attemptnum rid))))) + (else (extras-case-11 log-port rmt-mutex runremote toppath cmd params attemptnum rid alldat))))) -(define (extras-case-11 log-port rmt-mutex runremote areapath cmd params attemptnum rid) +(define (extras-case-11 log-port rmt-mutex runremote areapath cmd params attemptnum rid alldat) ;; (mutex-unlock! rmt-mutex) (debug:print-info 12 log-port "rmt:send-receive, case 9") ;; (mutex-lock! rmt-mutex) (let* ((conninfo (remote-conndat runremote)) (dat (case (remote-transport runremote) @@ -322,12 +323,12 @@ (debug:print-info 13 log-port "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) ;; (mutex-unlock! rmt-mutex) (if success ;; success only tells us that the transport was ;; successful, have to examine the data to see if ;; there was a detected issue at the other end - (extras-transport-succeded log-port rmt-mutex attemptnum runremote areapath res params rid cmd) - (extras-transport-failed log-port rmt-mutex attemptnum runremote areapath cmd rid params) + (extras-transport-succeded log-port rmt-mutex attemptnum runremote areapath res params rid cmd alldat) + (extras-transport-failed log-port rmt-mutex attemptnum runremote areapath cmd rid params alldat) ))) ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;;