| ︙ | | | ︙ | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))
(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb spiffy-directory-listing)
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
(declare (unit http-transport))
|
|
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))
(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))
|
| ︙ | | | ︙ | |
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
(include "db_records.scm")
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))
;;======================================================================
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
|
|
|
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
(include "db_records.scm")
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))
;;======================================================================
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
|
| ︙ | | | ︙ | |
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (http-transport:run hostn)
(debug:print 2 "Attempting to start the server ...")
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
(exit))))
(let* (;; (iface (if (string=? "-" hostn)
;; #f ;; (get-host-name)
;; hostn))
(db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
|
|
|
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (http-transport:run hostn)
(debug:print 2 "Attempting to start the server ...")
(if (not *toppath*)
(if (not (launch:setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
(exit))))
(let* (;; (iface (if (string=? "-" hostn)
;; #f ;; (get-host-name)
;; hostn))
(db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
|
| ︙ | | | ︙ | |
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (http-transport:client-send-receive serverdat msg #!key (numretries 30))
(let* (;; (url (http-transport:make-server-url serverdat))
(fullurl (caddr serverdat)) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
(res #f))
(handle-exceptions
exn
(begin
(print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 2)
(if (> numretries 0)
|
>
>
>
>
|
|
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (http-transport:client-send-receive serverdat msg #!key (numretries 30))
(let* (;; (url (http-transport:make-server-url serverdat))
(fullurl (if (list? serverdat)
(caddr serverdat)
(begin
(debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
(exit 1)))) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
(res #f))
(handle-exceptions
exn
(begin
(print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 2)
(if (> numretries 0)
|
| ︙ | | | ︙ | |
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
(set! res (with-input-from-request
fullurl
(list (cons 'dat msg))
read-string))
(close-all-connections!)
(mutex-unlock! *http-mutex*)))
(time-out (lambda ()
(thread-sleep! 5)
(if (not res)
(begin
(debug:print 0 "WARNING: communication with the server timed out.")
(mutex-unlock! *http-mutex*)
(http-transport:client-send-receive serverdat msg numretries: (- numretries 1))
(if (< numretries 3) ;; on last try just exit
(begin
|
|
|
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
(set! res (with-input-from-request
fullurl
(list (cons 'dat msg))
read-string))
(close-all-connections!)
(mutex-unlock! *http-mutex*)))
(time-out (lambda ()
(thread-sleep! 45)
(if (not res)
(begin
(debug:print 0 "WARNING: communication with the server timed out.")
(mutex-unlock! *http-mutex*)
(http-transport:client-send-receive serverdat msg numretries: (- numretries 1))
(if (< numretries 3) ;; on last try just exit
(begin
|
| ︙ | | | ︙ | |
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
|
(tasks:server-update-heartbeat tdb spid)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
(if (> (+ last-access server-timeout)
(current-seconds))
(debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
(thread-sleep! 1)
|
>
|
|
|
|
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(tasks:server-update-heartbeat tdb spid)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
(if (and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
(begin
(debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
(thread-sleep! 1)
|
| ︙ | | | ︙ | |
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
|
" ms")
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)))))))
;; all routes though here end in exit ...
(define (http-transport:launch)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(if (args:get-arg "-daemonize")
(daemon:ize))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
|
|
|
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
" ms")
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)))))))
;; all routes though here end in exit ...
(define (http-transport:launch)
(if (not *toppath*)
(if (not (launch:setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(if (args:get-arg "-daemonize")
(daemon:ize))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
|
| ︙ | | | ︙ | |