91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
(send-response body: (api:process-request db $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
;; 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))
(set! res (db:process-queue-item db packet))
;; (mutex-unlock! *db:process-queue-mutex*)
(debug:print-info 11 "Return value from db:process-queue-item is " res)
(send-response body: (conc "<head>ctrl data</head>\n<body>"
res
"</body>")
headers: '((content-type text/plain)))))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
(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)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
(send-response body: (api:process-request db $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
;; 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))
;; (set! res (db:process-queue-item db packet))
;; ;; (mutex-unlock! *db:process-queue-mutex*)
;; (debug:print-info 11 "Return value from db:process-queue-item is " res)
;; (send-response body: (conc "<head>ctrl data</head>\n<body>"
;; res
;; "</body>")
;; headers: '((content-type text/plain)))))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
(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)))
|
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
(exit 1))))
(res #f))
(handle-exceptions
exn
(if (> numretries 0)
(begin
(mutex-unlock! *http-mutex*)
(thread-sleep! 2)
(close-all-connections!)
(debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries)
(http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1)))
(begin
(mutex-unlock! *http-mutex*)
#f))
(begin
|
|
|
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
(exit 1))))
(res #f))
(handle-exceptions
exn
(if (> numretries 0)
(begin
(mutex-unlock! *http-mutex*)
(thread-sleep! 1)
(close-all-connections!)
(debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries)
(http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1)))
(begin
(mutex-unlock! *http-mutex*)
#f))
(begin
|
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
|
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(thread-terminate! th2)
(debug:print-info 11 "got res=" res)
res)))))
;;
;; connect
;;
(define (http-transport:client-connect iface port)
(let* ((api-url (conc "http://" iface ":" port "/api"))
(uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
;; (uri-dat (make-request method: 'GET uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
(uri-api-dat (make-request method: 'POST uri: api-url)) ;; (uri-reference (conc "http://" iface ":" port "/api"))))
;; (uri-api-dat (make-request method: 'GET uri: (uri-reference (conc "http://" iface ":" port "/api"))))
(server-dat (list iface port uri-dat uri-api-dat api-url)))
;; (login-res (server:ping-server run-id server-dat))) ;; login-no-auto-client-setup server-dat run-id)))
server-dat))
;; (if (and (list? login-res)
;; (car login-res))
;; (begin
;; (hash-table-set! *runremote* run-id server-dat)
;; (debug:print-info 2 "Logged in and connected to " iface ":" port)
;; (hash-table-set! *runremote* run-id server-dat)
;; server-dat)
;; (begin
;; (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
;; #f))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<
|
|
>
|
<
<
<
<
<
<
<
<
<
<
<
|
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
|
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(thread-terminate! th2)
(debug:print-info 11 "got res=" res)
res)))))
;; careful closing of connections stored in *runremote*
;;
(define (http-transport:close-connections run-id)
(let* ((server-dat (hash-table-ref/default *runremote* run-id #f)))
(if (and (list? server-dat)
(>= (length server-dat) 5))
(let ((ctrl-dat (list-ref server-dat 2))
(api-dat (list-ref server-dat 3)))
(close-connection! ctrl-dat)
(close-connection! api-dat)
#t)
#f)))
(define (make-http-transport:server-dat)(make-vector 5))
(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
(define (http-transport:server-dat-get-api-request vec) (vector-ref vec 4))
;;
;; connect
;;
(define (http-transport:client-connect iface port)
(let* ((api-url (conc "http://" iface ":" port "/api"))
(api-uri (uri-reference (conc "http://" iface ":" port "/api")))
(uri-api-dat (make-request method: 'POST uri: api-uri))
;; (uri-ctrl-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
(uri-ctrl-dat #f) ;; not used anymore
(server-dat (vector iface port uri-ctrl-dat uri-api-dat api-url)))
server-dat))
;; 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 server-id)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
|