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
|
;;
;; 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)
(BB> "TRANSPORT IS "ttype" string?"(string? ttype)" symbol?"(symbol? ttype))
|
<
<
|
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
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
(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.
;; called by launch:setup
(define (server:set-transport)
(let ((ttype (string->symbol
(or (args:get-arg "-transport")
(configf:lookup *configdat* "server" "transport")
"rpc"))))
(set! *transport-type* ttype)
ttype))
;; Get the transport -- DO NOT call this from client code. In client code, this is run-id sensitive and not a global
;; For code communicating with existing run-id with a server, use: (rmt:run-id->transport-type run-id)
(define (server:get-transport)
(if *transport-type*
|
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
;; client:start returns #t if login was successful.
;;
(let* ((transport-type (rmt:run-id->transport-type run-id))
(res (case transport-type
((http)(server:ping-server run-id
(tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server)))
(else
(debug:print-error 0 *default-log-port* "(5) Transport [" transport-type
"] specified for run-id [" run-id
"] is not implemented in rmt:send-receive. Cannot proceed.")
(exit 1)))))
;; if the server didn't respond we must remove the record
(if res
|
>
>
|
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
;; client:start returns #t if login was successful.
;;
(let* ((transport-type (rmt:run-id->transport-type run-id))
(res (case transport-type
((http)(server:ping-server run-id
(tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server)))
((rpc) ((rpc:procedure 'server:login (tasks:hostinfo-get-interface server) (tasks:hostinfo-get-port server)) *toppath*))
(else
(debug:print-error 0 *default-log-port* "(5) Transport [" transport-type
"] specified for run-id [" run-id
"] is not implemented in rmt:send-receive. Cannot proceed.")
(exit 1)))))
;; if the server didn't respond we must remove the record
(if res
|
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
(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)
(set! *last-db-access* (current-seconds))
(BB> "server:login ours="*toppath*" theirs="toppath)
|
<
|
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
(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)
(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)))
|