@@ -21,14 +21,10 @@
(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))
@@ -43,638 +39,5 @@
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
(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)
- (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 *alldat*))
- (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-db* $) ;; 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))))))))
- (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
- (print "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 serverdat cmd params #!key (numretries 3)(area-dat #f))
- (let* ((fullurl (if (vector? serverdat)
- (http-transport:server-dat-get-api-req serverdat)
- (begin
- (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
- (exit 1))))
- (res (vector #f "uninitialized"))
- (success #t)
- (sparams (db:obj->string params transport: 'http))
- (areadat (or area-dat *areadat*)))
- (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
- ;; 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)
- (debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
- (debug:print 0 *default-log-port* " call-chain: " call-chain)))
- (if areadat
- (areadat-conndat-set! areadat #f))
- ;; Killing associated server to allow clean retry.")
- ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
- (mutex-unlock! *http-mutex*)
- ;;; (signal (make-composite-condition
- ;;; (make-property-condition 'commfail 'message "failed to connect to server")))
- ;;; "communications failed"
- (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!)
- (mutex-unlock! *http-mutex*)
- ))
- (time-out (lambda ()
- (thread-sleep! 45)
- #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)
- (thread-terminate! th2)
- (debug:print-info 11 *default-log-port* "got res=" res)
- (if (vector? res)
- (if (vector-ref res 0) ;; this is the first flag or the second flag?
- 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 *alldat*
-;;
-(define (http-transport:close-connections #!key (all-dat #f))
- (let* ((alldat (or all-dat *alldat*))
- (server-dat (if alldat
- (alldat-conndat alldat)
- #f))) ;; (hash-table-ref/default *areadat* run-id #f)))
- (if (vector? server-dat)
- (let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
- (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)))
- (close-connection! api-dat)
- ;;(close-idle-connections!)
- #t))
- #f)))
-
-;; http-transport:server-dat definition moved to common_records.scm
-
-;;
-;; connect
-;;
-(define (http-transport:client-connect iface port)
- (let* ((api-url (conc "http://" iface ":" port "/api"))
- (api-uri (uri-reference (conc "http://" iface ":" port "/api")))
- (api-req (make-request method: 'POST uri: api-uri))
- (server-dat (vector iface port api-uri api-url api-req (current-seconds))))
- server-dat))
-
-;; 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* ((tmp-area (common:get-db-tmp-area *alldat*))
- (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"))
- (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))
- (begin
- (debug:print-info 0 *default-log-port* "Received server alive signature")
- (common:save-pkt `((action . alive)
- (T . server)
- (pid . ,(current-process-id))
- (ipaddr . ,(car sdat))
- (port . ,(cadr sdat)))
- *configdat* #t)
- 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
- (begin
- (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
- (common:save-pkt `((action . died)
- (T . server)
- (pid . ,(current-process-id))
- (ipaddr . ,(car sdat))
- (port . ,(cadr sdat))
- (msg . "Transport died?"))
- *configdat* #t)
- (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
-
- (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-db*
- (begin
- (debug:print 0 *default-log-port* "SERVER: dbprep")
- (set! *dbstruct-db* (db:setup #t)) ;; run-id))
- (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.
- (thread-start! *watchdog*)))
-
- ;; 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)
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds))
- (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
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds))
- (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 log file " server-log-file ". Are you out of space on that disk?")
- (if (not *server-overloaded*)
- (change-file-times server-log-file curr-time curr-time)))))
- (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)
- (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 that a server start is in progress, pause or exit if so
- (let* ((tmp-area (common:get-db-tmp-area *alldat*))
- (server-start (conc tmp-area "/.server-start"))
- (server-started (conc tmp-area "/.server-started"))
- (start-time (common:lazy-modification-time server-start))
- (started-time (common:lazy-modification-time server-started))
- (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
- (start-time-old (> (- (current-seconds) start-time) 5))
- (cleanup-proc (lambda (msg)
- (let* ((serv-fname (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
- (full-serv-fname (conc *toppath* "/logs/" serv-fname))
- (new-serv-fname (conc *toppath* "/logs/" "defunct-" serv-fname)))
- (debug:print 0 *default-log-port* msg)
- (if (common:file-exists? full-serv-fname)
- (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname))
- (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
- (exit)))))
- (if (and (not start-time-old) ;; last server start try was less than five seconds ago
- (not server-starting))
- (begin
- (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting")
- (exit)))
- ;; lets not even bother to start if there are already three or more server files ready to go
- (let* ((num-alive (server:get-num-alive (server:get-list *toppath*))))
- (if (> num-alive 3)
- (begin
- (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up"))
- (exit))))
- (common:save-pkt `((action . start)
- (T . server)
- (pid . ,(current-process-id)))
- *configdat* #t)
- (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 "
Dashboard
" bdy "
" )))
-
-(define (http-transport:main-page)
- (let ((linkpath (root-path)))
- (conc "" (pathname-strip-directory *toppath*) "
"
- ""
- "Run area: " *toppath*
- "Server Stats
"
- (http-transport:stats-table)
- "
"
- (http-transport:runs linkpath)
- "
"
- (http-transport:run-stats)
- ""
- )))
-
-(define (http-transport:stats-table)
- (mutex-lock! *heartbeat-mutex*)
- (let ((res
- (conc ""
- ;; "Max cached queries | " *max-cache-size* " |
"
- "Number of cached writes | " *number-of-writes* " |
"
- "Average cached write time | " (if (eq? *number-of-writes* 0)
- "n/a (no writes)"
- (/ *writes-total-delay*
- *number-of-writes*))
- " ms |
"
- "Number non-cached queries | " *number-non-write-queries* " |
"
- ;; "Average non-cached time | " (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- " ms |
"
- "Last access | " (seconds->time-string *db-last-access*) " |
"
- "
")))
- (mutex-unlock! *heartbeat-mutex*)
- res))
-
-(define (http-transport:runs linkpath)
- (conc "Runs
"
- (string-intersperse
- (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
- (map (lambda (p)
- (conc "" p "
"))
- files))
- " ")))
-
-(define (http-transport:run-stats)
- (let ((stats (open-run-close db:get-running-stats #f)))
- (conc ""
- (string-intersperse
- (map (lambda (stat)
- (conc "" (car stat) " | " (cadr stat) " |
"))
- stats)
- " ")
- "
")))