| ︙ | | | ︙ | |
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
;; 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)))
|
>
>
>
|
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
;; 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)))
|
| ︙ | | | ︙ | |
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
|
(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
|
|
|
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
|
(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
|
| ︙ | | | ︙ | |
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
|
;; 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))
(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)
|
>
|
|
|
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
|
;; 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* ((sdat #f)
(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)
|
| ︙ | | | ︙ | |
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
|
(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)
(iface (car server-info))
|
|
|
|
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
|
(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))))
|
| ︙ | | | ︙ | |
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
|
"<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>"
|
|
|
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
|
"<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>"
|
| ︙ | | | ︙ | |
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
|
(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>")))
|
|
|
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
|
(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>")))
|