Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -753,11 +753,10 @@ ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} (define (db:get-tests-for-runs-mindata db run-ids testpatt states status) (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path")) - ;; NB // This is get tests for "runs" (note the plural!!) ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok @@ -1363,12 +1362,14 @@ #t) #f))) (define *db:process-queue-mutex* (make-mutex)) -(define *number-of-writes* 0) -(define *writes-total-delay* 0) +(define *number-of-writes* 0) +(define *writes-total-delay* 0) +(define *total-non-write-delay* 0) +(define *number-non-write-queries* 0) ;; The queue is a list of vectors where the zeroth slot indicates the type of query to ;; apply and the second slot is the time of the query and the third entry is a list of ;; values to be applied ;; @@ -1425,52 +1426,57 @@ #t)))) (debug:print-info 7 "Received " response " from wrapped write") (server:reply return-address qry-sig response response)) ;; otherwise if appropriate flush the queue (this is a read or complex query) (begin - (case *transport-type* - ((http) - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*))) (cond ((member stmt-key db:special-queries) - (debug:print-info 11 "Handling special statement " stmt-key) - (case stmt-key - ((immediate) - (let ((proc (car params)) - (remparams (cdr params))) - ;; we are being handed a procedure so call it - (debug:print-info 11 "Running (apply " proc " " remparams ")") - (server:reply return-address qry-sig #t (apply proc remparams)))) - ((login) - (if (< (length params) 3) ;; should get toppath, version and signature - (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params - (let ((calling-path (car params)) - (calling-vers (cadr params)) - (client-key (caddr params))) - (if (and (equal? calling-path *toppath*) - (equal? megatest-version calling-vers)) - (begin - (hash-table-set! *logged-in-clients* client-key (current-seconds)) - (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... - (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) - ((flush sync) - (server:reply return-address qry-sig #t 1)) ;; (length data))) - ((set-verbosity) - (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) - ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (car *runremote*) - pullport: (cadr *runremote*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply return-address qry-sig #t '(#t "exit process started"))) - (else ;; not a command, i.e. is a query - (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) - (server:reply pubsock return-address qry-sig #f 'failed)))) + (let ((starttime (current-milliseconds))) + (debug:print-info 11 "Handling special statement " stmt-key) + (case stmt-key + ((immediate) + ;; This is a read or mixed read-write query, must clear the cache + (case *transport-type* + ((http) + (mutex-lock! *db:process-queue-mutex*) + (db:process-cached-writes db) + (mutex-unlock! *db:process-queue-mutex*))) + (let* ((proc (car params)) + (remparams (cdr params)) + ;; we are being handed a procedure so call it + ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") + (result (server:reply return-address qry-sig #t (apply proc remparams)))) + (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) + (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) + result)) + ((login) + (if (< (length params) 3) ;; should get toppath, version and signature + (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params + (let ((calling-path (car params)) + (calling-vers (cadr params)) + (client-key (caddr params))) + (if (and (equal? calling-path *toppath*) + (equal? megatest-version calling-vers)) + (begin + (hash-table-set! *logged-in-clients* client-key (current-seconds)) + (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... + (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) + ((flush sync) + (server:reply return-address qry-sig #t 1)) ;; (length data))) + ((set-verbosity) + (set! *verbosity* (car params)) + (server:reply return-address qry-sig #t '(#t *verbosity*))) + ((killserver) + (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") + (open-run-close tasks:server-deregister tasks:open-db + (car *runremote*) + pullport: (cadr *runremote*)) + (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) + (server:reply return-address qry-sig #t '(#t "exit process started"))) + (else ;; not a command, i.e. is a query + (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) + (server:reply return-address qry-sig #f 'failed))))) (else (debug:print-info 11 "Executing " stmt-key " for " params) (apply sqlite3:execute (hash-table-ref queries stmt-key) params) (server:reply return-address qry-sig #t #t))))))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -107,13 +107,11 @@ (send-response body: (conc "ctrl data\n" res "") headers: '((content-type text/plain))))) (else (continue)))))))) - (http-transport:try-start-server ipaddrstr start-port) - ;; lite3:finalize! db))) - )) + (http-transport:try-start-server ipaddrstr start-port))) ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server ipaddrstr portnum) (handle-exceptions @@ -252,11 +250,23 @@ (set! *time-to-exit* #t) (tasks:server-deregister-self tdb (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) - (debug:print-info 0 "Average cached write time " (/ *writes-total-delay* *number-of-writes*) " ms") + (debug:print-info 0 "Average cached write time " + (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms") + (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 "Average non-cached time " + (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms") (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) ;; all routes though here end in exit ... (define (http-transport:launch)