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.
|
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
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
|
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
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
|
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
-
-
+
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
(BB> "server:launch fired for run-id="run-id" transport-type="transport-type)
(case transport-type
((http)(http-transport:launch run-id))
;;((nmsg)(nmsg-transport:launch run-id))
((rpc) (rpc-transport:launch run-id))
(else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; (rpc-transport:launch run-id)))))
(let ((ttype (if (symbol? transport-type) transport-type (string->symbol (->string transport-type)))))
(case ttype
((http)(http-transport:launch run-id))
;;((nmsg)(nmsg-transport:launch run-id))
((rpc) (rpc-transport:launch run-id))
(else (debug:print-error 0 *default-log-port* "unknown server type " ttype)))))
;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; (rpc-transport:launch run-id)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; set global *transport-type* based on -transport switch and serer/transport configuration. default http otherwise.
;; Get the transport
(define (server:get-transport)
;; called by launch:setup
(define (server:set-transport)
(if *transport-type*
*transport-type*
(let ((ttype (string->symbol
(or (args:get-arg "-transport")
(configf:lookup *configdat* "server" "transport")
"rpc"))))
(set! *transport-type* ttype)
ttype)))
((zmq)
(let ((pub-socket (vector-ref *runremote* 1)))
(send-message pub-socket return-addr send-more: #t)
(send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
" -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 &")))))
|
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
|
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
|
-
+
+
-
+
+
-
-
-
-
+
+
+
+
+
+
+
+
-
+
|
(define (server:try-running run-id)
(if (eq? run-id 0)
(server:run run-id)
(rmt:start-server run-id)))
(define (server:check-if-running run-id)
(let ((tdbdat (tasks:open-db)))
(let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id))
(let loop ((server (tasks:get-server-info (db:delay-if-busy tdbdat) run-id))
(trycount 0))
(if server
;; note: client:start will set *runremote*. this needs to be changed
;; also, client:start will login to the server, also need to change that.
;;
;; client:start returns #t if login was successful.
;;
(let* ((transport-type (rmt:run-id->transport-type run-id))
(let ((res (case *transport-type*
;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
;; (tasks:hostinfo-get-port server)
;; timeout: 2))
)))
(server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
(server-db-dat (if (not host-port)(tasks:get-server-info (db:delay-if-busy tdbdat) run-id) #f)))
(if (not run-id)
(begin
(debug:print-error 0 *default-log-port* "must specify run-id when doing ping, -run-id n")
(print "ERROR: No run-id")
(exit 1))
(if (and (not host-port)
(not server-db-dat))
|
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
+
|
(if (eof-object? inl)
(case (string->symbol res)
((NOREPLY) #f)
((LOGIN_OK) #t)
(else #f))
(loop (read-line) inl))))))
;; Client will call this procedure on the server via the low-level transport (http/rpc/etc) to verify its toppath matches the server's toppath.
;; A true result means client and server are associated with same megatest instance, share the same megatest.config, etc...) A false result means the client should not talk to this server.
(define (server:login toppath)
(lambda (toppath)
(set! *last-db-access* (current-seconds))
(if (equal? *toppath* toppath)
(begin
;; (debug:print-info 2 *default-log-port* "login successful")
#t)
(begin
;; (debug:print-info 2 *default-log-port* "login failed")
#f))))
(* 60 1) ;; default to one minute
(* 60 3) ;; default to three minutes
;; (* 60 60 25) ;; default to 25 hours
)))
|