| ︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
+
+
|
(use srfi-69 posix)
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(import dbmod)
(import dbfile)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
get-keys
|
| ︙ | | |
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
+
|
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
(db:open-no-sync-db) ;; sets *no-sync-db*
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
;; (handle-exceptions
;; exn
;; (let ((call-chain (get-call-chain)))
;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
;; (print-call-chain (current-error-port))
;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(cond
((not (vector? dat)) ;; it is an error to not receive a vector
(vector #f (vector #f "remote must be called with a vector")))
((> *api-process-request-count* 20) ;; 20)
((> *api-process-request-count* 200) ;; 20)
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
(set! *server-overloaded* #t)
(vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
(else
(let* ((cmd-in (vector-ref dat 0))
(cmd (if (symbol? cmd-in)
cmd-in
|
| ︙ | | |
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
-
+
|
;; TEST DATA
((test-data-rollup) (apply db:test-data-rollup dbstruct params))
((csv->test-data) (apply db:csv->test-data dbstruct params))
;; MISC
((sync-inmem->db) (let ((run-id (car params)))
(db:sync-touched dbstruct run-id force-sync: #t)))
(db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
((create-all-triggers) (db:create-all-triggers dbstruct))
((drop-all-triggers) (db:drop-all-triggers dbstruct))
;; TESTMETA
((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
|
| ︙ | | |
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
|
-
+
|
;; MISC
((get-latest-host-load) (apply db:get-latest-host-load dbstruct params))
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
(db:general-call dbstruct stmtname realparams)))
(db:general-call dbstruct run-id stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
|
| ︙ | | |
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
|
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
|
-
+
|
payload: `((params . ,params)
(ok-res . #t)))
(vector #f res))
(begin
#;(common:telemetry-log (conc "api-out:"(->string cmd))
payload: `((params . ,params)
(ok-res . #f)))
(vector #t res))))))))
(vector #t res))))))) ;; )
;; http-server send-response
;; api:process-request
;; db:*
;;
;; NB// Runs on the server as part of the server loop
;;
|
| ︙ | | |