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
|
;;======================================================================
;; 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 run-id params)
(case *transport-type*
((fs-aint-here)
(debug:print 0 "ERROR: Not yet (re)supported")
(exit 1))
((fs http)
;; if run-id is #f send the request to run-id = 0 server. This will be for main.db
;;
(let* ((connection-info (client:setup (if run-id run-id 0)))
(jparams (db:obj->string params)) ;; (rmt:dat->json-str 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)
(begin
(debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res)
#f))))
(else
(debug:print 0 "ERROR: Transport " *transport-type* " not yet (re)supported")
(exit 1))))
|
|
|
>
>
|
>
>
>
>
>
>
>
>
|
|
>
>
|
>
>
>
|
|
>
|
|
|
|
|
|
<
|
<
<
<
|
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
;;======================================================================
;; 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
(let loop ((numtries 100))
(thread-sleep! 1)
(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)
(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)
(let* ((run-id (if run-id run-id 0))
(jparams (db:obj->string params)) ;; (rmt:dat->json-str params))
(res (http-transport:client-api-send-receive run-id connection-info cmd jparams numretries: 3)))
(if res
(db:string->obj res) ;; (rmt:json-str->dat res)
;; this one does NOT keep trying
res)))
;; Wrap json library for strings (why the ports crap in the first place?)
(define (rmt:dat->json-str dat)
(with-output-to-string
(lambda ()
(json-write dat))))
|
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
;;======================================================================
;;======================================================================
;; M I S C
;;======================================================================
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))
(define (rmt:kill-server run-id)
(rmt:send-receive 'kill-server run-id (list run-id)))
;; 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)
|
|
>
>
>
>
>
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
;;======================================================================
;;======================================================================
;; 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)))
;; 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)
|
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
(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:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
(let ((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-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)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
;; Statistical queries
|
>
>
|
>
>
>
|
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
|
(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)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
;; Statistical queries
|