@@ -7,10 +7,11 @@
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(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)
@@ -29,11 +30,13 @@
(declare (uses portlogger))
(declare (uses rmt))
(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))))
@@ -56,12 +59,15 @@
;; (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))) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (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)
@@ -100,13 +106,26 @@
'(/ 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"
+ (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)
@@ -238,10 +257,11 @@
(msg ((condition-property-accessor 'exn 'message) exn)))
(set! success #f)
(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 runremote
(remote-conndat-set! runremote #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*)
@@ -249,11 +269,11 @@
;;; (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 "thekey")
+ (list (cons 'key (or *server-id* "thekey"))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))
transport: 'http)
0)) ;; added this speculatively
@@ -300,10 +320,11 @@
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)))
(define (make-http-transport:server-dat)(make-vector 6))
@@ -347,11 +368,13 @@
(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* ((server-start-time (current-seconds))
+ (let* ((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"))
(let ((sdat #f))
(thread-sleep! 0.01)
@@ -389,13 +412,16 @@
(equal? sdat last-sdat)
sdat)))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0)
- (server-timeout (server:get-timeout))
+ (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
@@ -443,21 +469,15 @@
(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))
- (adjusted-timeout (if (> hrs-since-start 1) ;; never used!
- (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour
- server-timeout)))
- (if (common:low-noise-print 120 "server timeout")
- (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
+ (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
(cond
((and *server-run*
(> (+ last-access server-timeout)
- (current-seconds))
- (< (- (current-seconds) server-start-time) 3600)) ;; do not update log or touch log if we've been running for more than one hour.
+ (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
@@ -507,60 +527,116 @@
;; all routes though here end in exit ...
;;
;; start_server?
;;
(define (http-transport:launch)
- ;; 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)
+ ;; check that a server start is in progress, pause or exit if so
+ (let* ((tmp-area (common:get-db-tmp-area))
+ (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
- (debug:print 0 *default-log-port* "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up")
- (exit))))
+ (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))))
+ (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*