65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
+
-
-
-
-
-
+
+
-
-
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
((http)(make-remote))
((tcp) (tt:make-remote areapath))
(else #f)))
;;======================================================================
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define *ttdat* #f)
;; how to make area-dat
(define (rmt:set-ttdat areapath ttdat)
(if ttdat
ttdat
(if *ttdat*
*ttdat*
(begin
(debug:print-info 2 *default-log-port* "rmt:set-ttdat: Initialize new ttdat")
(let* ((newremote (make-and-init-remote areapath)))
(set! *ttdat* newremote)
newremote
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
)
)
)
)
)
;; NB// area-dat replaced by ttdat
;;
(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
(assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f")
(assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
;; 3. do the query, if on homehost use local access
;;
(let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
(areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
(runremote (or area-dat
*runremote*))
(attemptnum (+ 1 attemptnum))
(readonly-mode (rmtmod:calc-ro-mode runremote *toppath*))
(testsuite (common:get-testsuite-name))
(mtexe (common:find-local-megatest)))
((http)(http-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode))
((tcp) (tcp-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode testsuite mtexe))
((nfs) (nfs-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode testsuite mtexe))
)))
(attemptnum (+ 1 attemptnum))
(mtexe (common:find-local-megatest))
(dbfname (conc (dbfile:run-id->dbnum run-id)".db"))
(ttdat (rmt:set-ttdat areapath ttdat))
(conn (tt:get-conn ttdat dbfname))
(is-main (equal? dbfname "main.db")) ;; why not (not run-id) ?
(server-start-proc (if is-main
#f
(lambda ()
;; (debug:print-info 0 *default-log-port* "starting server for dbfname: "dbfname)
(rmt:start-server ;; tt:server-process-run
areapath
testsuite ;; (dbfile:testsuite-name)
mtexe
run-id)))))
;; here we look at ttdat, if dbfname is NOT main.db we check that a conn exists for it
;; and if there is no conn we first send a request to the main.db server to start a
;; server for the dbfname.
#;(if (and (not is-main)(not conn)) ;; no existing connection to non-main server, call in a start up request
(begin
(server-start-proc)
(thread-sleep! 1)))
(tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)))
((nfs)
(nfs-transport-handler cmd run-id params attemptnum areapath readonly-mode testsuite))
(else
(debug:print-info 0 *default-log-port* "rmt:transport-mode is "(rmt:transport-mode))
(assert #f "FATAL: rmt:transport-mode set to invalid value.")))))
(define (nfs-transport-handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode testsuite mtexe)
(define (nfs-transport-handler cmd run-id params attemptnum areapath readonly-mode testsuite)
(let* ((keys (common:get-fields *configdat*))
(dbstruct (dbmod:nfs-get-dbstruct run-id keys (dbfile:db-init-proc) areapath)))
(api:dispatch-request dbstruct cmd run-id params)))
(define (tcp-transport-handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode testsuite mtexe)
(if (not runremote)
(let* ((newremote (make-and-init-remote areapath)))
(set! *runremote* newremote)
(set! runremote newremote)))
(let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id)))
(tt:handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
(debug:print 18 *default-log-port* "DB Stats\n========")
(debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
(debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
(sort (hash-table-keys *db-stats*)
(lambda (a b)
(> (vector-ref (hash-table-ref *db-stats* a) 0)
(vector-ref (hash-table-ref *db-stats* b) 0)))))))
|
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
-
+
|
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
(let* ((qry-is-write (not (member cmd api:read-only-queries)))
(db-file-path (common:make-tmpdir-name *toppath* "")) ;; 0))
(dbstructs-local (db:setup #t))
(dbstructs-local (db:setup))
(read-only (not (file-write-access? db-file-path)))
(start (current-milliseconds))
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
;; (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
;; exn ;; This is an attempt to detect that situation and recover gracefully
;; (begin
|
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
|
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
|
-
+
-
-
+
+
-
+
-
+
|
#f))
(begin
;; (rmt:update-db-stats run-id cmd params duration)
;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
(if qry-is-write
(let ((start-time (current-seconds)))
(mutex-lock! *db-multi-sync-mutex*)
/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
(define (rmt:start-server run-id)
(rmt:send-receive 'start-server 0 (list run-id)))
(define (rmt:start-server areapath testsuite mtexe run-id) ;; run on main.db server
(rmt:send-receive 'start-server #f (list areapath testsuite mtexe run-id)))
;;======================================================================
;; M I S C
;;======================================================================
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature))))
;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
;; (define (rmt:login-no-auto-client-setup runremote)
;; (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))
;; (rmt:send-receive-no-auto-client-setup runremote 'login #f (list *toppath* megatest-version (client:get-signature))))
;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host
(define (rmt:get-latest-host-load hostname)
(rmt:send-receive 'get-latest-host-load 0 (list hostname)))
(rmt:send-receive 'get-latest-host-load #f (list hostname)))
(define (rmt:sdb-qry qry val run-id)
;; add caching if qry is 'getid or 'getstr
(rmt:send-receive 'sdb-qry run-id (list qry val)))
;; NOT COMPLETED
(define (rmt:runtests user run-id testpatt params)
|
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
|
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
-
-
+
+
|
(define (rmt:delete-run run-id)
(rmt:send-receive 'delete-run #f (list run-id)))
(define (rmt:update-run-stats run-id stats)
(rmt:send-receive 'update-run-stats #f (list run-id stats)))
(define (rmt:delete-old-deleted-test-records)
(rmt:send-receive 'delete-old-deleted-test-records #f '()))
(define (rmt:delete-old-deleted-test-records run-id)
(rmt:send-receive 'delete-old-deleted-test-records run-id (list run-id)))
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:simple-get-runs runpatt count offset target last-update)
(rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))
|
775
776
777
778
779
780
781
|
788
789
790
791
792
793
794
795
796
797
|
+
+
+
|
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
(let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
(test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
(rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)))
;; orphaned from cherrypick merge
;; (debug:print 0 *default-log-port* "Inserting " (length tests-data) " tests in run " runname)
|