︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
+
-
+
|
;;======================================================================
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(include "common_records.scm")
;; (declare (uses rmtmod))
;; (import rmtmod)
(import dbfile) ;; rmtmod)
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;
;; generate entries for ~/.megatestrc with the following
;;
|
︙ | | |
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
-
+
|
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
#;(common:telemetry-log (conc "rmt:"(->string cmd))
payload: `((rid . ,rid)
(params . ,params)))
(if (> attemptnum 2)
(debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
(cond
((> attemptnum 2) (thread-sleep! 0.05))
((> attemptnum 10) (thread-sleep! 0.5))
((> attemptnum 20) (thread-sleep! 1)))
|
︙ | | |
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
+
+
+
+
+
+
+
|
;; ensure we have a homehost record
(if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
(remote-hh-dat-set! runremote (common:get-homehost)))
;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
(cond
((> (- (current-seconds)(remote-connect-time runremote)) 180) ;; reconnect to server every 180 seconds
(debug:print 0 *default-log-port* "Forcing reconnect to server(s) due to 180 second timeout.")
(set! *runremote* #f)
;; BUG: close-connections should go here?
(mutex-unlock! *rmt-mutex*)
(rmt:send-receive cmd rid params attemptnum: 1 area-dat: area-dat))
;;DOT EXIT;
;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
;; give up if more than 150 attempts
((> attemptnum 150)
(debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.")
(exit 1))
|
︙ | | |
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
|
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
-
-
-
-
-
+
+
+
+
+
-
+
|
(let* ((qry-is-write (not (member cmd api:read-only-queries)))
(db-file-path (db:dbfile-path)) ;; 0))
(dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
(read-only (not (file-write-access? db-file-path)))
(start (current-milliseconds))
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
exn ;; This is an attempt to detect that situation and recover gracefully
(begin
(debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
;; (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
;; exn ;; This is an attempt to detect that situation and recover gracefully
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
;; (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
(if (and (vector? v)
(> (vector-length v) 1))
(let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
(vector #t '())))) ;; we could also check that the returned types are valid
(vector #t '()))) ;; ) ;; we could also check that the returned types are valid
(vector #t '())))
(success (vector-ref resdat 0))
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (and read-only qry-is-write)
(debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
(if (not success)
|
︙ | | |
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
|
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
|
-
-
-
-
-
-
+
+
+
+
+
+
|
(mutex-lock! *db-multi-sync-mutex*)
/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
(mutex-unlock! *db-multi-sync-mutex*)))))
res))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
(res (handle-exceptions
exn
(begin
(print "transport failed. exn=" exn)
#f)
(http-transport:client-api-send-receive run-id connection-info cmd params))))
(res ;; (handle-exceptions
;; exn
;; (begin
;; (print "transport failed. exn=" exn)
;; #f)
(http-transport:client-api-send-receive run-id connection-info cmd params))) ;; )
(if (and res (vector-ref res 0))
(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
#f)))
;;======================================================================
;;
;; A C T U A L A P I C A L L S
|
︙ | | |