| ︙ | | | ︙ | |
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
;; Call this to start the actual server
;;
;; 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)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Get the transport
(define (server:get-transport)
(if *transport-type*
|
|
>
>
>
>
>
|
>
|
|
|
|
|
<
<
|
|
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
|
;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type-raw)
(let ((transport-type
(cond
((string? transport-type-raw) (string->symbol transport-type-raw))
(else transport-type-raw))))
(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)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Get the transport
(define (server:get-transport)
(if *transport-type*
|
| ︙ | | | ︙ | |
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
(curr-ip (server:get-best-guess-address curr-host))
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
(testsuite (common:get-testsuite-name))
(logfile (conc *toppath* "/logs/server.log"))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
"")
|
|
>
|
|
>
|
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
(curr-ip (server:get-best-guess-address curr-host))
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
(testsuite (common:get-testsuite-name))
(logfile (conc *toppath* "/logs/server.log"))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") " -run-id " 0
(if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
"")
" -transport " (server:get-transport)
" -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
(log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")))
;; we want the remote server to start in *toppath* so push there
(push-directory *toppath*)
(debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
(thread-start! log-rotate)
|
| ︙ | | | ︙ | |
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
(let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db)))
(if dotserver
(let* ((res (case *transport-type*
((http)(server:ping-server dotserver))
;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
)))
(if res
dotserver
#f))
#f)))
|
|
|
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
(let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db)))
(if dotserver
(let* ((res (case *transport-type*
((http rpc)(server:ping-server dotserver))
;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
)))
(if res
dotserver
#f))
#f)))
|
| ︙ | | | ︙ | |
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
|
(begin
(if host-port-in
(debug:print 0 *default-log-port* "ERROR: bad host:port"))
(if do-exit (exit 1))
#f)
(let* ((iface (car host-port))
(port (cadr host-port))
(server-dat (http-transport:client-connect iface port))
|
>
>
|
>
>
>
>
|
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
(begin
(if host-port-in
(debug:print 0 *default-log-port* "ERROR: bad host:port"))
(if do-exit (exit 1))
#f)
(let* ((iface (car host-port))
(port (cadr host-port))
(server-dat
(case (remote-transport *runremote*)
((http) (http-transport:client-connect iface port))
((rpc) (rpc-transport:client-connect iface port))
(else
(debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (4)")
(exit))))
(login-res (rmt:login-no-auto-client-setup server-dat)))
(if (and (list? login-res)
(car login-res))
(begin
(print "LOGIN_OK")
(if do-exit (exit 0)))
(begin
|
| ︙ | | | ︙ | |