Overview
Context
Changes
Modified rmt.scm
from [a08625c798]
to [a521022e85].
1
2
3
4
5
6
7
8
9
|
1
2
3
4
5
6
7
8
9
|
-
-
+
+
|
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
|
| ︙ | | |
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
|
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
|
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
|
(rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1)))
(else
(debug:print-error 0 *default-log-port* "(3) Transport [" transport-type
"] specified for run-id [" run-id
"] is not implemented in rmt:send-receive. Cannot proceed.")
#f)))))
;; no connection info; try to start a server, or access locally if no
;; no connection info; try to start a server
;; server and the query is read-only
(if (and (< attemptnum 15)
(member cmd api:write-queries))
(let* ((faststart (configf:lookup *configdat* "server" "faststart")))
(hash-table-delete! *runremote* run-id)
;; (mutex-unlock! *send-receive-mutex*)
(if (and faststart (equal? faststart "no"))
(begin
(tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10)
(thread-sleep! (random 5)) ;; give some time to settle and minimize collison?
(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
(let ((start-time (current-milliseconds))
(max-query (string->number (or (configf:lookup *configdat* "server" "server-query-threshold")
"300")))
(newres (rmt:open-qry-close-locally cmd run-id params)))
(let ((delta (- (current-milliseconds) start-time)))
(if (> delta max-query)
(begin
(debug:print-info 0 *default-log-port* "Starting server as query time " delta " is over the limit of " max-query)
(server:kind-run run-id)))
;; return the result!
newres)
)))
(begin
;; (debug:print-error 0 *default-log-port* "Communication failed!")
;; (mutex-unlock! *send-receive-mutex*)
;; (exit)
(rmt:open-qry-close-locally cmd run-id params)
)))))
|
| ︙ | | |
Modified rpc-transport.scm
from [5d1e126bbe]
to [ba86436e70].
1
2
3
4
5
6
7
8
9
|
1
2
3
4
5
6
7
8
9
|
-
+
|
;; Copyright 2006-2012, Matthew Welland.
;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
|
| ︙ | | |
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
-
-
-
-
-
-
+
+
+
+
+
+
|
;; all routes though here end in exit ...
;;
;; start_server?
;;
(define (rpc-transport:launch run-id)
(set! *run-id* run-id)
;; send to background if requested
(when (args:get-arg "-daemonize")
(daemon:ize)
(when *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
(current-error-port *alt-log-file*)
(current-output-port *alt-log-file*)))
;; ;; send to background if requested
;; (when (args:get-arg "-daemonize")
;; (daemon:ize)
;; (when *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
;; (current-error-port *alt-log-file*)
;; (current-output-port *alt-log-file*)))
;; double check we dont alrady have a running server for this run-id
(when (server:check-if-running run-id)
(debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
(exit 0))
;; let's get a server-id for this server
|
| ︙ | | |
Modified server.scm
from [6406fc4f02]
to [262f305ebc].
1
2
3
4
5
6
7
8
9
|
1
2
3
4
5
6
7
8
9
|
-
+
|
;; Copyright 2006-2012, Matthew Welland.
;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
|
| ︙ | | |
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
-
-
+
+
-
-
+
|
(define (server:run run-id)
(let* ((curr-host (get-host-name))
(curr-ip (server:get-best-guess-address curr-host))
(target-host (configf:lookup *configdat* "server" "homehost" ))
(testsuite (common:get-testsuite-name))
(logfile (conc *toppath* "/logs/" run-id ".log"))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
" -server " (or target-host "-")
" -run-id " run-id " -log " logfile
"")
" -m testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &")))))
|
| ︙ | | |