Artifact 7539e23e31a74c362c1fec5d637ef9331ac70060:
- File
http-transport.scm
— part of check-in
[67b18cc991]
at
2023-01-16 10:00:35
on branch v1.80-refactor
— Major refactor/clean up of client connection stuff. Removed old crufty approach of having both client and server side calls in http-transport. Plan would be to eventually get rid of http-transport.
Open files slowly grows. bad argument type in http-transport. Line 285 (close-connection! fullurl) is wrong. (user: matt, size: 30306) [annotate] [blame] [check-ins using]
;; Copyright 2006-2012, 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/>. (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (declare (unit http-transport)) (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) ;; (declare (uses daemon)) (declare (uses portlogger)) (declare (uses rmt)) (declare (uses dbfile)) (declare (uses commonmod)) (include "common_records.scm") (include "db_records.scm") (include "js-path.scm") (import dbfile commonmod) (require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) ;;====================================================================== ;; S E R V E R ;; ====================================================================== ;; Call this to start the actual server ;; (define *db:process-queue-mutex* (make-mutex)) (define (http-transport:run hostn) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (debug:print 2 *default-log-port* "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (common:get-linktree)) (tmp-area (common:get-db-tmp-area)) (start-file (conc tmp-area "/.server-start"))) (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port) ;; set some parameters for the server (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) (handle-exception (lambda (exn chain) (signal (make-composite-condition (make-property-condition 'server 'message "server error"))))) ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *db-last-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) '(/ "json_api")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) '(/ "runs")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) '(/ any)) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "jquery3.1.0.js")) (send-response body: (http-transport:show-jquery) headers: '((content-type application/javascript)))) ((equal? (uri-path (request-uri (current-request))) '(/ "test_log")) (send-response body: (http-transport:html-test-log $) headers: '((content-type text/HTML)))) ((equal? (uri-path (request-uri (current-request))) '(/ "dashboard")) (send-response body: (http-transport:html-dboard $) headers: '((content-type text/HTML)))) (else (continue)))))))) (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn) (with-output-to-file start-file (lambda ()(print (current-process-id))))) (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) (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes"))) (if (not config-use-proxy) (determine-proxy (constantly #f))) (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname) (handle-exceptions exn (begin ;; (print-error-message exn) (if (< portnum 64000) (begin (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; get_next_port goes here (http-transport:try-start-server ipaddrstr (portlogger:open-run-close portlogger:find-port))) (begin (debug:print 0 *default-log-port* "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL ;; (start-server bind-address: ipaddrstr port: portnum) (if config-hostname ;; this is a hint to bind directly (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-") ;; ipaddrstr ;; config-hostname)) (start-server port: portnum)) (portlogger:open-run-close portlogger:set-port portnum "released") (debug:print 1 *default-log-port* "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) ;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here ;; I'm pretty sure it is defunct. ;; This next block all imported en-mass from the api branch (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 *default-log-port* "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-error 0 *default-log-port* "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*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; (define (http-transport:client-api-send-receive run-id runremote cmd params #!key (numretries 3)) (assert (remote? runremote) "FATAL: http-transport:client-api-send-receive called with serverdat="serverdat) (let* ((fullurl (remote-api-req runremote)) (res (vector #f "uninitialized")) (success #t) (sparams (db:obj->string params transport: 'http)) (server-id (remote-server-id runremote))) (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds)) ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) #f)) ;; 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*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) (set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time. success (db:string->obj (handle-exceptions exn (let ((call-chain (get-call-chain)) (msg ((condition-property-accessor 'exn 'message) exn))) (set! success #f) (if (debug:debug-mode 1) (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...") (begin (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 *default-log-port* " message: " msg ", exn=" exn) (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey")) (debug:print 0 *default-log-port* " call-chain: " call-chain))) ;; what if another thread is communicating ok? Can't happen due to mutex (http-transport:close-connections runremote) (mutex-unlock! *http-mutex*) (close-connection! fullurl) (db:obj->string #f)) (with-input-from-request ;; was dat fullurl (list (cons 'key (or server-id "thekey")) (cons 'cmd cmd) (cons 'params sparams)) read-string)) transport: 'http) 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections? (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") #f)) (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) (vector-set! res 0 success) (thread-terminate! th2) (if (vector? res) (if (vector-ref res 0) ;; this is the first flag or the second flag? (let* ((res-dat (vector-ref res 1))) (if (and (string? res-dat) (string-contains res-dat "server-id mismatch")) (signal (make-composite-condition (make-property-condition 'servermismatch 'message (vector-ref res 1)))) res)) ;; this is the *inner* vector? seriously? why? (if (debug:debug-mode 11) (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it (print-call-chain (current-error-port)) (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 11 *default-log-port* " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref res 0))) res)) (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) ;; careful closing of connections stored in *runremote* ;; (define (http-transport:close-connections runremote) (if (remote? runremote) (let ((api-dat (remote-api-uri runremote))) (handle-exceptions exn (begin (print-call-chain *default-log-port*) (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) (if (args:any-defined? "-server" "-execute" "-run") (debug:print-info 0 *default-log-port* "Closing connections to "api-dat)) (close-connection! api-dat) (remote-conndat-set! runremote #f) #t)) #f)) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (http-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") (let* ((servinfofile #f) (sdat #f) (no-sync-db (db:open-no-sync-db)) (tmp-area (common:get-db-tmp-area)) (started-file (conc tmp-area "/.server-started")) (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (begin ;; let ((sdat #f)) (thread-sleep! 0.01) (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) (let* ((servinfodir (server:get-servinfo-dir *toppath*)) ;; (conc *toppath*"/.servinfo")) (ipaddr (car sdat)) (port (cadr sdat)) (servinf (conc servinfodir"/"ipaddr":"port))) (set! servinfofile servinf) (if (not (file-exists? servinfodir)) (create-directory servinfodir #t)) (with-output-to-file servinf (lambda () (let* ((serv-id (server:mk-signature))) (set! *server-id* serv-id) (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)) (print "started: "(seconds->year-week/day-time (current-seconds)))))) (set! *on-exit-procs* (cons (lambda () (delete-file* servinf)) *on-exit-procs*)) ;; put data about this server into a simple flat file host.port (debug:print-info 0 *default-log-port* "Received server alive signature") sdat) (begin (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (if sdat (let* ((ipaddr (car sdat)) (port (cadr sdat)) (servinf (conc (server:get-servinfo-dir *toppath*)"/"ipaddr":"port))) (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") (exit)) (exit) ) (loop start-time (equal? sdat last-sdat) sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (server-timeout (server:expiration-timeout)) (server-going #f) (server-log-file (args:get-arg "-log"))) ;; always set when we are a server (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn) (with-output-to-file started-file (lambda ()(print (current-process-id))))) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-dbs* (begin (debug:print 0 *default-log-port* "SERVER: dbprep") (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!! (set! server-going #t) (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version))) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. (if (and no-sync-db (common:low-noise-print 10 "sync-all")) ;; cheesy way to reduce frequency of running sync :) (begin (if (common:low-noise-print 120 "sync-all-print") (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S"))) (db:all-db-sync *dbstruct-dbs*) ))) ;; when things go wrong we don't want to be doing the various queries too often ;; so we strive to run this stuff only every four seconds or so. (let* ((sync-time (- (current-milliseconds) start-time)) (rem-time (quotient (- 4000 sync-time) 1000))) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time))) (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1) 'running bad-sync-count (current-milliseconds))) ;; Check that iface and port have not changed (can happen if server port collides) (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (not (equal? sdat (list iface port))) (let ((new-iface (car sdat)) (new-port (cadr sdat))) (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") (set! iface new-iface) (set! port new-port) (if (not *server-id*) (set! *server-id* (server:mk-signature))) (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) (flush-output *default-log-port*))) ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *db-last-access*) (mutex-unlock! *heartbeat-mutex*) (if (common:low-noise-print 120 (conc "server running on " iface ":" port)) (begin (if (not *server-id*) (set! *server-id* (server:mk-signature))) (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv)) (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) (flush-output *default-log-port*))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((and *server-run* (> (+ last-access server-timeout) (current-seconds))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (let ((curr-time (current-seconds))) (handle-exceptions exn (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn) (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter (not *server-overloaded*) (file-exists? servinfofile)) (change-file-times servinfofile curr-time curr-time))) (if (and (common:low-noise-print 120 "start new server") (> *api-process-request-count* 50)) ;; if this server is kind of busy start up another (begin (debug:print-info 0 *default-log-port* "Server is busy, api-count "*api-process-request-count*", start another if possible...") (server:kind-run *toppath*) (if (> *api-process-request-count* 100) (begin (debug:print-info 0 *default-log-port* "Server is overloaded at api-count=" *api-process-request-count*", removing "servinfofile) (delete-file* servinfofile))))))) (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port))))))) (define (http-transport:server-shutdown port) (begin ;;(BB> "http-transport:server-shutdown called") (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; ;; start_shutdown ;; (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up (portlogger:open-run-close portlogger:set-port port "released") (thread-sleep! 1) ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*) ;; (debug:print-info 0 *default-log-port* "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 *default-log-port* "Number non-cached queries " *number-non-write-queries*) ;; (debug:print-info 0 *default-log-port* "Average non-cached time " ;; (if (eq? *number-non-write-queries* 0) ;; "n/a (no queries)" ;; (/ *total-non-write-delay* ;; *number-non-write-queries*)) ;; " ms") (db:print-current-query-stats) #;(common:save-pkt `((action . exit) (T . server) (pid . ,(current-process-id))) *configdat* #t) ;; remove .servinfo file(s) here (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch) ;; check the .servinfo directory, are there other servers running on this ;; or another host? (let* ((server-start-is-ok (server:minimal-check *toppath*))) (if (not server-start-is-ok) (begin (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.") (exit 1)))) ;; check that a server start is in progress, pause or exit if so (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running) "Keep running")))) (thread-start! th2) (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (exit))) ;; (define (http-transport:server-signal-handler signum) ;; (signal-mask! signum) ;; (handle-exceptions ;; exn ;; (debug:print 0 *default-log-port* " ... exiting ...") ;; (let ((th1 (make-thread (lambda () ;; (thread-sleep! 1)) ;; "eat response")) ;; (th2 (make-thread (lambda () ;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") ;; (thread-sleep! 3) ;; give the flush three seconds to do it's stuff ;; (debug:print 0 *default-log-port* " Done.") ;; (exit 4)) ;; "exit on ^C timer"))) ;; (thread-start! th2) ;; (thread-start! th1) ;; (thread-join! th2)))) ;;=============================================== ;; Java script ;;=============================================== (define (http-transport:show-jquery) (let* ((data (tests:readlines *java-script-lib*))) (string-join data "\n"))) ;;====================================================================== ;; web pages ;;====================================================================== (define (http-transport:html-test-log $) (let* ((run-id ($ 'runid)) (test-item ($ 'testname)) (parts (string-split test-item ":")) (test-name (car parts)) (item-name (if (equal? (length parts) 1) "" (cadr parts)))) ;(print $) (tests:get-test-log run-id test-name item-name))) (define (http-transport:html-dboard $) (let* ((page ($ 'page)) (oup (open-output-string)) (bdy "--------------------------") (ret (tests:dynamic-dboard page))) (s:output-new oup ret) (close-output-port oup) (set! bdy (get-output-string oup)) (conc "<h1>Dashboard</h1>" bdy "<br/> <br/> " ))) (define (http-transport:main-page) (let ((linkpath (root-path))) (conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>" "<body>" "Run area: " *toppath* "<h2>Server Stats</h2>" (http-transport:stats-table) "<hr>" (http-transport:runs linkpath) "<hr>" ;; (http-transport:run-stats) "</body>" ))) (define (http-transport:stats-table) (mutex-lock! *heartbeat-mutex*) (let ((res (conc "<table>" ;; "<tr><td>Max cached queries</td> <td>" *max-cache-size* "</td></tr>" "<tr><td>Number of cached writes</td> <td>" *number-of-writes* "</td></tr>" "<tr><td>Average cached write time</td> <td>" (if (eq? *number-of-writes* 0) "n/a (no writes)" (/ *writes-total-delay* *number-of-writes*)) " ms</td></tr>" "<tr><td>Number non-cached queries</td> <td>" *number-non-write-queries* "</td></tr>" ;; "<tr><td>Average non-cached time</td> <td>" (if (eq? *number-non-write-queries* 0) ;; "n/a (no queries)" ;; (/ *total-non-write-delay* ;; *number-non-write-queries*)) " ms</td></tr>" "<tr><td>Last access</td><td>" (seconds->time-string *db-last-access*) "</td></tr>" "</table>"))) (mutex-unlock! *heartbeat-mutex*) res)) (define (http-transport:runs linkpath) (conc "<h3>Runs</h3>" (string-intersperse (let ((files (map pathname-strip-directory (glob (conc linkpath "/*"))))) (map (lambda (p) (conc "<a href=\"" p "\">" p "</a><br>")) files)) " "))) #;(define (http-transport:run-stats) (let ((stats (open-run-close db:get-running-stats #f))) (conc "<table>" (string-intersperse (map (lambda (stat) (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>")) stats) " ") "</table>")))