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
|
chicken.base
chicken.process-context.posix
chicken.string
chicken.time
chicken.condition
chicken.process
chicken.random
;; (prefix sqlite3 sqlite3:)
typed-records
srfi-18
srfi-69
commonmod
dbmod
debugprint
tasksmod
servermod
)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
|
>
>
|
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
|
chicken.base
chicken.process-context.posix
chicken.string
chicken.time
chicken.condition
chicken.process
chicken.random
chicken.file
;; (prefix sqlite3 sqlite3:)
typed-records
srfi-18
srfi-69
commonmod
dbmod
debugprint
tasksmod
servermod
matchable
)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
|
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
testmeta-update-field
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
(define (api:dispatch-cmd dbstruct cmd params)
(case cmd
;;===============================================
;; READ/WRITE QUERIES
;;===============================================
((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
;; SERVERS
;; ((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
((get-server) (apply db:get-server-info dbstruct params))
;; TESTS
;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
((test-set-state-status-by-id)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
testmeta-update-field
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
(define (api:run-server-process apath dbname)
(let* ((cmd (conc "nbfake megatest -server - -area "apath
" -db "dbname))
(cleandbname (string-translate dbname "./" "_-"))
(logd (conc apath "/logs"))
(logf (conc logd "/server-"(current-seconds)cleandbname".log")))
(if (not (directory-exists? logd))
(create-directory logd #t))
(system (conc "NBFAKE_LOG="logf" "cmd))))
;; special function to get server
;; look up in db
;; if found -> return it
;; if not found -> start server, return starting
;;
(define (api:start-server dbstruct params)
(let* ((res (apply db:get-server-info dbstruct params)))
(if res
res
(match params
((apath dbname)
(api:run-server-process apath dbname)
'server-started)
(else
(debug:print-info 0 *default-log-port* "api:start-server called with wrong params: "params)
'bad-params)))))
(define (api:dispatch-cmd dbstruct cmd params)
(case cmd
;;===============================================
;; READ/WRITE QUERIES
;;===============================================
((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
;; SERVERS
;; ((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
((get-server) (api:start-server dbstruct params))
;; TESTS
;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
((test-set-state-status-by-id)
|
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
|
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
(else
(debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
(conc "ERROR: BAD api call " cmd))))
;; (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)
;; (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
;; (string->symbol cmd-in)))
;; (params (vector-ref dat 1))
(start-t (current-milliseconds))
;; (readonly-mode (dbr:dbstruct-read-only dbstruct))
;; (readonly-command (member cmd api:read-only-queries))
(res (api:dispatch-cmd dbstruct cmd params)))
;; (if writecmd-in-readonly-mode
;; (conc "attempt to run write command "cmd" on a read-only database")
;; save all stats
(let ((delta-t (- (current-milliseconds)
start-t)))
(hash-table-set! *db-api-call-time* cmd
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
(else
(debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
(conc "ERROR: BAD api call " cmd))))
;; 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 cmd params)
(let* ((start-t (current-milliseconds))
;; (readonly-mode (dbr:dbstruct-read-only dbstruct))
;; (readonly-command (member cmd api:read-only-queries))
;; (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
(res (api:dispatch-cmd dbstruct cmd params)))
;; (if writecmd-in-readonly-mode
;; (conc "attempt to run write command "cmd" on a read-only database")
;; save all stats
(let ((delta-t (- (current-milliseconds)
start-t)))
(hash-table-set! *db-api-call-time* cmd
|
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
|
;; http-server send-response
;; api:process-request
;; db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
(debug:print 4 *default-log-port* "server-id:" *server-id*)
(let* ((cmd ($ 'cmd))
(params (string->sexpr ($ 'params)))
(key ($ 'key)) ;; TODO - add this back
)
(debug:print 0 *default-log-port* "cmd:" cmd " with params " params "key " key)
(if (equal? key "nokey") ;; *server-id*) ;; TODO - get real key involved
(begin
|
|
|
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
;; http-server send-response
;; api:process-request
;; db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
(debug:print 0 *default-log-port* "server-id:" *server-id*)
(let* ((cmd ($ 'cmd))
(params (string->sexpr ($ 'params)))
(key ($ 'key)) ;; TODO - add this back
)
(debug:print 0 *default-log-port* "cmd:" cmd " with params " params "key " key)
(if (equal? key "nokey") ;; *server-id*) ;; TODO - get real key involved
(begin
|