︙ | | | ︙ | |
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
(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)
(http-transport:client-send-receive serverdat msg numretries: (- numretries 1))))
(begin
(debug:print-info 11 "fullurl=" fullurl "\n")
;; set up the http-client here
(max-retry-attempts 5)
;; consider all requests indempotent
(retry-request? (lambda (request)
#t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
|
<
>
>
|
>
|
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
(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))
(if (> numretries 0)
(begin
(thread-sleep! 2)
(http-transport:client-send-receive serverdat msg numretries: (- numretries 1)))
#f))
(begin
(debug:print-info 11 "fullurl=" fullurl "\n")
;; set up the http-client here
(max-retry-attempts 5)
;; consider all requests indempotent
(retry-request? (lambda (request)
#t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
|
︙ | | | ︙ | |
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
(debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
(exit 1))))
(res #f))
(handle-exceptions
exn
(begin
;; TODO: Send this output to a log file so it isn't lost when running as daemon
(print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
(if (> numretries 0)
(begin
(if (> (random 100) 80)(server:ensure-running run-id)) ;; every so often try starting a server
(http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1)))))
(begin
(debug:print-info 11 "fullurl=" fullurl "\n")
;; set up the http-client here
(max-retry-attempts 5)
;; consider all requests indempotent
(retry-request? (lambda (request)
#t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
;; (set! numretries (- numretries 1))
;; #t))
|
<
>
>
|
>
|
|
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
|
(debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
(exit 1))))
(res #f))
(handle-exceptions
exn
(begin
;; TODO: Send this output to a log file so it isn't lost when running as daemon
(if (> numretries 0)
;; on the zeroeth retry do not print the error message - this allows the call to be used as a ping (no junk on output).
(begin
(print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
(if (> (random 100) 80)(server:ensure-running run-id)) ;; every so often try starting a server
(http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1)))
#f))
(begin
(debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
;; set up the http-client here
(max-retry-attempts 5)
;; consider all requests indempotent
(retry-request? (lambda (request)
#t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
;; (set! numretries (- numretries 1))
;; #t))
|
︙ | | | ︙ | |
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
|
(debug:print-info 11 "got res=" res)
res)))))
;;
;; connect
;;
(define (http-transport:client-connect run-id iface port)
(let* ((login-res #f)
(uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
(uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
(serverdat (list iface port uri-dat uri-api-dat)))
(hash-table-set! *runremote* run-id serverdat) ;; may or may not be good ...
(set! login-res (rmt:login run-id))
(if (and (list? login-res)
(car login-res))
(begin
(debug:print-info 2 "Logged in and connected to " iface ":" port)
(hash-table-set! *runremote* run-id serverdat)
serverdat)
(begin
|
<
|
|
>
<
|
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
|
(debug:print-info 11 "got res=" res)
res)))))
;;
;; connect
;;
(define (http-transport:client-connect run-id iface port)
(let* ((uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
(uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
(serverdat (list iface port uri-dat uri-api-dat))
(login-res (rmt:login-no-auto-client-setup serverdat run-id)))
(hash-table-set! *runremote* run-id serverdat) ;; may or may not be good ...
(if (and (list? login-res)
(car login-res))
(begin
(debug:print-info 2 "Logged in and connected to " iface ":" port)
(hash-table-set! *runremote* run-id serverdat)
serverdat)
(begin
|
︙ | | | ︙ | |
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
|
(if (or (not (equal? sdat (list iface port)))
(not server-id))
(begin
(debug:print-info 0 "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))))
;; NOTE: Get rid of this mechanism! It really is not needed...
;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid)
;;
;; NOT USED ANY MORE
;;
;; (tasks:server-update-heartbeat tdb server-id)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
;; Transfer *last-db-access* to last-access to use in checking that we are still alive
(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)
;;
|
<
<
<
<
<
<
<
<
<
<
|
449
450
451
452
453
454
455
456
457
458
459
460
461
462
|
(if (or (not (equal? sdat (list iface port)))
(not server-id))
(begin
(debug:print-info 0 "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))))
;; Transfer *last-db-access* to last-access to use in checking that we are still alive
(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)
;;
|
︙ | | | ︙ | |
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
|
;;
;; start_server?
;;
(define (http-transport:launch run-id)
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
;;
;; set_available
;;
(let ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)))
(if (not server-id)
(begin
(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(open-run-close tasks:server-delete-records-for-this-pid tasks:open-db))
(let* ((th2 (make-thread (lambda ()
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-")
|
<
<
<
>
|
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
|
;;
;; start_server?
;;
(define (http-transport:launch run-id)
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
(let ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)))
(if (not server-id)
(begin
;; since we didn't get the server lock we are going to clean up and bail out
(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(open-run-close tasks:server-delete-records-for-this-pid tasks:open-db))
(let* ((th2 (make-thread (lambda ()
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-")
|
︙ | | | ︙ | |