;; 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/>.
(declare (unit http-transport))
(declare (uses common))
(declare (uses debugprint))
(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))
(declare (uses mtargs))
(module http-transport
*
(import srfi-1 posix regex regex-case srfi-69 hostinfo md5
message-digest posix-extras spiffy uri-common intarweb http-client
spiffy-request-vars intarweb spiffy-directory-listing
(srfi 18) extras tcp s11n)
(import scheme
chicken
(prefix mtargs args:)
debugprint)
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
(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))
(if api-dat (close-connection! api-dat))
;; Would it be better to set *runremote* to #f? I don't think so. But we may
;; need to clear more of the runremote fields
(remote-api-url-set! runremote #f) ;; used as a flag for connection up and running
#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>")))
)