;; 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))
;; (if 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>")))
;;