29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
(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
;;
|
|
|
>
|
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
(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))
(define *query-count-mutex* (make-mutex))
;;======================================================================
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
;;
|
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
;; This is the /ctrl path where data is handed to the server and
;; responses
((equal? (uri-path (request-uri (current-request)))
'(/ "ctrl"))
(let* ((packet (db:string->obj dat))
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
(if (not (member qtype '(sync ping)))
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)))
;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
;; (set! res (open-run-close db:process-queue-item open-db packet))
|
>
>
|
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
;; This is the /ctrl path where data is handed to the server and
;; responses
((equal? (uri-path (request-uri (current-request)))
'(/ "ctrl"))
(let* ((packet (db:string->obj dat))
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
(if (not (member qtype '(sync ping)))
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)))
;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
;; (set! res (open-run-close db:process-queue-item open-db packet))
|
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
|
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(debug:print 11 "http-transport:launch hostinfo=" hostinfo)
(if hostinfo
(debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo))
(if *toppath*
(let* ((th2 (make-thread (lambda ()
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-"))) "Server run"))
(th3 (make-thread (lambda ()(http-transport:keep-running)) "Keep running"))
|
|
|
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(debug:print 11 "http-transport:launch hostinfo=" hostinfo)
(if hostinfo
(debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
(if *toppath*
(let* ((th2 (make-thread (lambda ()
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-"))) "Server run"))
(th3 (make-thread (lambda ()(http-transport:keep-running)) "Keep running"))
|