| ︙ | | | ︙ | |
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
|
;;
(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
(let loop ((numtries 100))
(thread-sleep! 1)
(loop (- numtries 1))
(begin
(debug:print 0 "ERROR: 100 tries and no server, giving up")
(exit 1)))))))))
(jparams (db:obj->string params))
(res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
(db:string->obj res) ;; (rmt:json-str->dat 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)))))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
|
<
>
>
|
|
|
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
|
;;
(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
(let loop ((numtries 100))
(let ((res (client:setup run-id)))
(if res
(hash-table-ref *runremote* run-id) ;; client:setup filled this in (hopefully)
(if (> numtries 0)
(begin
(thread-sleep! 10)
(loop (- numtries 1)))
(begin
(debug:print 0 "ERROR: 100 tries and no server, giving up")
(exit 1)))))))))
(jparams (db:obj->string params))
(res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
(if res
(db:string->obj res) ;; (rmt:json-str->dat 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)))))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
|
| ︙ | | | ︙ | |
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(json-read))))
;;======================================================================
;;
;; A C T U A L A P I C A L L S
;;
;;======================================================================
;;======================================================================
;; M I S C
;;======================================================================
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
;; This login does no retries under the hood - it acts a bit like a ping.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
(define (rmt:kill-server run-id)
(rmt:send-receive 'kill-server run-id (list run-id)))
|
>
>
>
>
>
>
>
>
>
>
<
<
<
|
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
(json-read))))
;;======================================================================
;;
;; A C T U A L A P I C A L L S
;;
;;======================================================================
;;======================================================================
;; S E R V E R
;;======================================================================
(define (rmt:kill-server run-id)
(rmt:send-receive 'kill-server run-id (list run-id)))
(define (rmt:start-server run-id)
(rmt:send-receive 'start-server 0 (list run-id)))
;;======================================================================
;; M I S C
;;======================================================================
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
;; This login does no retries under the hood - it acts a bit like a ping.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible
;;
(define (rmt:general-call stmtname run-id . params)
(rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
(define (rmt:sync-inmem->db run-id)
|
| ︙ | | | ︙ | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
(define (rmt:runtests user run-id testpatt params)
(rmt:send-receive 'runtests run-id testpatt))
;;======================================================================
;; K E Y S
;;======================================================================
;; These should not require run-id but it is more consistent to have it.
;; run-id can theoretically be #f but how to handle that is not yet done.
(define (rmt:get-key-val-pairs run-id)
(rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
(define (rmt:get-keys)
(rmt:send-receive 'get-keys #f '()))
;;======================================================================
|
|
|
|
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
(define (rmt:runtests user run-id testpatt params)
(rmt:send-receive 'runtests run-id testpatt))
;;======================================================================
;; K E Y S
;;======================================================================
;; These require run-id because the values come from the run!
;;
(define (rmt:get-key-val-pairs run-id)
(rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
(define (rmt:get-keys)
(rmt:send-receive 'get-keys #f '()))
;;======================================================================
|
| ︙ | | | ︙ | |
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
|
(define (rmt:delete-test-records run-id test-id)
(rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
(define (rmt:test-set-status-state run-id test-id status state msg)
(rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))
(define (rmt:get-previous-test-run-record run-id test-name item-path)
(rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
(rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
(define (rmt:test-get-logfile-info run-id test-name)
(rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name)
(rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
(define (rmt:get-testinfo-state-status run-id test-id)
(rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
(define (rmt:test-set-log! run-id test-id logf)
(if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
;; NOTE: This will open and access ALL run databases.
;;
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
(let ((run-ids (rmt:get-all-run-ids))) ;; (rmt:get-run-ids-matching keynames target res)))
(apply append (lambda (run-id)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname)))
run-ids)))
(define (rmt:get-run-ids-matching keynames target res)
(rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))
|
|
|
>
>
>
|
|
>
|
|
|
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
|
(define (rmt:delete-test-records run-id test-id)
(rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
(define (rmt:test-set-status-state run-id test-id status state msg)
(rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))
;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
(rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
(define (rmt:test-get-logfile-info run-id test-name)
(rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name)
(rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
(define (rmt:get-testinfo-state-status run-id test-id)
(rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
(define (rmt:test-set-log! run-id test-id logf)
(if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
(rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
;; NOTE: This will open and access ALL run databases.
;;
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
(let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
(apply append
(map (lambda (run-id)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
run-ids))))
(define (rmt:get-run-ids-matching keynames target res)
(rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))
|
| ︙ | | | ︙ | |
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-all-run-ids)
(rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:lock/unlock-run run-id lock unlock user)
(rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
(define (rmt:update-run-event_time run-id)
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)
(rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))
;;======================================================================
;; S T E P S
;;======================================================================
;; Getting steps is more complicated.
;;
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
|
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-all-run-ids)
(rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:get-prev-run-ids run-id)
(rmt:send-receive 'get-prev-run-ids #f (list run-id)))
(define (rmt:lock/unlock-run run-id lock unlock user)
(rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
(define (rmt:update-run-event_time run-id)
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)
(rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;;
;; Run this at the client end since we have to connect to multiple run-id dbs
;;
(define (rmt:get-previous-test-run-record run-id test-name item-path)
(let* ((keyvals (rmt:get-key-val-pairs run-id))
(keys (rmt:get-keys))
(selstr (string-intersperse keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
(if (not keyvals)
#f
(let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
;;======================================================================
;; S T E P S
;;======================================================================
;; Getting steps is more complicated.
;;
|
| ︙ | | | ︙ | |