97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
))
;; 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)
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
(print-call-chain (current-error-port))
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(if (not (vector? dat)) ;; it is an error to not receive a vector
|
|
|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
))
;; 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 area-dat dat)
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
(print-call-chain (current-error-port))
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(if (not (vector? dat)) ;; it is an error to not receive a vector
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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
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
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
;;===============================================
;; SERVERS
((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
;; TESTS
((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params))
((delete-test-records) (apply db:delete-test-records dbstruct params))
((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
((test-set-status-state) (apply db:test-set-status-state dbstruct params))
((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params))
((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params))
((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
;; RUNS
((register-run) (apply db:register-run dbstruct params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
;; 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)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
;; TESTMETA
((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
;; TASKS
((tasks-add) (apply tasks:add dbstruct params))
((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
;; KEYS
((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
((get-keys) (db:get-keys dbstruct))
;; ARCHIVES
((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
;; TESTS
((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
((synchash-get) (apply synchash:server-get dbstruct params))
;; RUNS
((get-run-info) (apply db:get-run-info dbstruct params))
((get-run-status) (apply db:get-run-status dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((get-all-run-ids) (db:get-all-run-ids dbstruct))
((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
;; STEPS
((get-steps-data) (apply db:get-steps-data dbstruct params))
((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
;; MISC
((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:with-db dbstruct run-id #t ;; these are all for modifying the db
(lambda (db)
(db:general-call db stmtname realparams)))))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))))))))
;; 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
(let* ((cmd ($ 'cmd))
(paramsj ($ 'params))
(params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj))
(resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result )
(res (vector-ref resdat 1)))
;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
;; (rmt:dat->json-str
;; (if (or (string? res)
;; (list? res)
;; (number? res)
;; (boolean? res))
;; res
;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
(db:obj->string res transport: 'http)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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
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
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
;;===============================================
;; SERVERS
((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
;; TESTS
((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct area-dat params))
((delete-test-records) (apply db:delete-test-records dbstruct area-dat params))
((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct area-dat params))
((test-set-status-state) (apply db:test-set-status-state dbstruct area-dat params))
((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct area-dat params))
((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct area-dat params))
((update-fail-pass-counts) (apply db:general-call dbstruct area-dat 'update-pass-fail-counts params))
((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct area-dat params))
;; RUNS
((register-run) (apply db:register-run dbstruct area-dat params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct area-dat params))
((delete-run) (apply db:delete-run dbstruct area-dat params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct area-dat params))
((update-run-event_time) (apply db:update-run-event_time dbstruct area-dat params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct area-dat params))
;; TEST DATA
((test-data-rollup) (apply db:test-data-rollup dbstruct area-dat params))
((csv->test-data) (apply db:csv->test-data dbstruct area-dat params))
;; MISC
((sync-inmem->db) (let ((run-id (car params)))
(db:sync-touched dbstruct area-dat run-id force-sync: #t)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct area-dat params))
;; TESTMETA
((testmeta-add-record) (apply db:testmeta-add-record dbstruct area-dat params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct area-dat params))
;; TASKS
((tasks-add) (apply tasks:add dbstruct area-dat params))
((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct area-dat params))
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct area-dat params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct area-dat params))
((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct area-dat block-id testsuite-name areakey))
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
;; KEYS
((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct area-dat params))
((get-keys) (db:get-keys dbstruct area-dat))
;; ARCHIVES
((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct area-dat params))
;; TESTS
((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct area-dat params))
((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct area-dat params))
((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct area-dat params))
((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct area-dat params))
((get-count-tests-running) (apply db:get-count-tests-running dbstruct area-dat params))
((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct area-dat params))
;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct area-dat params))
((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct area-dat params))
((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct area-dat params))
((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct area-dat params))
((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct area-dat params))
((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct area-dat params))
((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct area-dat params))
((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct area-dat params))
((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct area-dat params))
((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct area-dat params))
((synchash-get) (apply synchash:server-get dbstruct area-dat params))
;; RUNS
((get-run-info) (apply db:get-run-info dbstruct area-dat params))
((get-run-status) (apply db:get-run-status dbstruct area-dat params))
((set-run-status) (apply db:set-run-status dbstruct area-dat params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct area-dat params))
((get-test-id) (apply db:get-test-id dbstruct area-dat params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct area-dat params))
((get-runs) (apply db:get-runs dbstruct area-dat params))
((get-all-run-ids) (db:get-all-run-ids dbstruct area-dat))
((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct area-dat params))
((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct area-dat params))
((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct area-dat params))
((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct area-dat params))
;; STEPS
((get-steps-data) (apply db:get-steps-data dbstruct area-dat params))
((get-steps-for-test) (apply db:get-steps-for-test dbstruct area-dat params))
;; MISC
((have-incompletes?) (apply db:have-incompletes? dbstruct area-dat params))
((login) (apply db:login dbstruct area-dat params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
(db:with-db dbstruct area-dat run-id #t ;; these are all for modifying the db
(lambda (db)
(db:general-call db stmtname realparams)))))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct area-dat params))
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct area-dat params))))))))
;; http-server send-response
;; api:process-request
;; db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct area-dat $) ;; the $ is the request vars proc
(let* ((cmd ($ 'cmd))
(paramsj ($ 'params))
(params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj))
(resdat (api:execute-requests dbstruct area-dat (vector cmd params))) ;; #( flag result )
(res (vector-ref resdat 1)))
;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
;; (rmt:dat->json-str
;; (if (or (string? res)
;; (list? res)
;; (number? res)
;; (boolean? res))
;; res
;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
(db:obj->string res transport: 'http)))
|