30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
;; )
;;======================================================================
;; S U P P O R T F U N C T I O N S
;;======================================================================
;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd rid params)
(let* ((run-id (if rid rid 0))
(connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
(if cinfo
cinfo
;; if read only query and server not already running
;; bypass starting the server.
;;
;; NB// can cache the answer for server running for 10 seconds ...
;;
(if (and (member cmd api:read-only-queries)
(not (open-run-close tasks:get-server tasks:open-db run-id)))
#f
(let loop ((numtries 100))
(let ((res (client:setup run-id)))
(if res
(hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully)
(if (> numtries 0)
(begin
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
;; )
;;======================================================================
;; S U P P O R T F U N C T I O N S
;;======================================================================
(define (rmt:write-frequency-over-limit? cmd run-id)
(or (member cmd api:read-only-queries)
(let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f))
(record (if tmprec tmprec
(let ((v (vector (current-seconds) 0)))
(hash-table-set! *write-frequency* run-id v)
v)))
(count (+ 1 (vector-ref record 1)))
(start (vector-ref record 0)))
(vector-set! record 1 count)
(if (and (> count 1)
(< (/ (- (current-seconds) start)
count) ;; seconds per count
10))
(begin
(debug:print-info 1 "db write rate too high, starting a server")
#t)
#f)))) ;; less than 10 seconds per count - start up a server
;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd rid params)
(let* ((run-id (if rid rid 0))
(connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
(if cinfo
cinfo
;; if read only query and server not already running
;; bypass starting the server.
;;
;; NB// can cache the answer for server running for 10 seconds ...
;;
(if (and (not (rmt:write-frequency-over-limit? cmd run-id))
(not (open-run-close tasks:server-running-or-starting? tasks:open-db run-id)))
#f
(let loop ((numtries 100))
(let ((res (client:setup run-id)))
(if res
(hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully)
(if (> numtries 0)
(begin
|
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
(let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
(db:string->obj res)
(let ((new-connection-info (client:setup run-id)))
(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
(rmt:send-receive cmd run-id params))))
(begin
(debug:print-info 0 "no server and read-only query, bypassing normal channel")
(rmt:open-qry-close-locally cmd run-id params)))))
(define (rmt:open-qry-close-locally cmd run-id params)
(let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dbstruct-local (make-dbr:dbstruct path: dbdir
local: #t))
(db-file-path (db:dbfile-path 0))
|
|
|
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
(let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
(db:string->obj res)
(let ((new-connection-info (client:setup run-id)))
(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
(rmt:send-receive cmd run-id params))))
(begin
(debug:print-info 4 "no server and read-only query, bypassing normal channel")
(rmt:open-qry-close-locally cmd run-id params)))))
(define (rmt:open-qry-close-locally cmd run-id params)
(let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dbstruct-local (make-dbr:dbstruct path: dbdir
local: #t))
(db-file-path (db:dbfile-path 0))
|