46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id area-dat)
(case *transport-type*
((http)(http-transport:launch run-id area-dat))
((nmsg)(nmsg-transport:launch run-id area-dat))
((rpc) (rpc-transport:launch run-id area-dat))
(else (debug:print 0 "ERROR: unknown server type " *transport-type*))))
;; (else (debug:print 0 "ERROR: 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
;;======================================================================
|
|
|
|
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id area-dat)
(case (megatest:area-transport area-dat)
((http)(http-transport:launch run-id area-dat))
((nmsg)(nmsg-transport:launch run-id area-dat))
((rpc) (rpc-transport:launch run-id area-dat))
(else (debug:print 0 "ERROR: unknown server type " (megatest:area-transport area-dat)))))
;; (else (debug:print 0 "ERROR: 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
;;======================================================================
|
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
|
(lambda ()
(write (list (current-directory)
(argv)))))))
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result #!key (remote #f))
(debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(case (server:get-transport)
((rpc) (db:obj->string (vector success/fail query-sig result)))
((http) (db:obj->string (vector success/fail query-sig result)))
((zmq)
(let ((pub-socket (vector-ref (common:get-remote remote #f) 1)))
(send-message pub-socket return-addr send-more: #t)
(send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
((fs) result)
(else
(debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
result)))
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;;
(define (server:run run-id area-dat)
|
|
|
|
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
|
(lambda ()
(write (list (current-directory)
(argv)))))))
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result area-dat #!key (remote #f))
(debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(case (server:get-transport)
((rpc) (db:obj->string (vector success/fail query-sig result)))
((http) (db:obj->string (vector success/fail query-sig result)))
((zmq)
(let ((pub-socket (vector-ref (common:get-remote remote #f) 1)))
(send-message pub-socket return-addr send-more: #t)
(send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
((fs) result)
(else
(debug:print 0 "ERROR: unrecognised transport type: " (megatest:area-transport area-dat))
result)))
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;;
(define (server:run run-id area-dat)
|
155
156
157
158
159
160
161
162
163
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
|
;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;;
(define (server:try-running run-id area-dat)
(if (eq? run-id 0)
(server:run run-id area-dat)
(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))
(trycount 0))
(if server
;; note: client:start will set (common:get-remote remote). 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 ((res (case *transport-type*
((http)(server:ping-server run-id
(tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server)))
((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server)
timeout: 2)))))
;; if the server didn't respond we must remove the record
(if res
#t
(begin
(debug:print-info 0 "server at " server " not responding, removing record")
(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id
" server:check-if-running")
res)))
#f))))
;; called in megatest.scm, host-port is string hostname:port
;;
(define (server:ping run-id host:port)
(let ((tdbdat (tasks:open-db)))
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
(toppath (launch:setup-for-run))
(server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
(if (not run-id)
|
|
|
|
|
|
|
155
156
157
158
159
160
161
162
163
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
|
;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;;
(define (server:try-running run-id area-dat)
(if (eq? run-id 0)
(server:run run-id area-dat)
(rmt:start-server run-id)))
(define (server:check-if-running run-id area-dat)
(let ((tdbdat (tasks:open-db area-dat)))
(let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id))
(trycount 0))
(if server
;; note: client:start will set (common:get-remote remote). 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 ((res (case (megatest:area-transport area-dat)
((http)(server:ping-server run-id
(tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server)))
((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server)
timeout: 2)))))
;; if the server didn't respond we must remove the record
(if res
#t
(begin
(debug:print-info 0 "server at " server " not responding, removing record")
(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id
" server:check-if-running")
res)))
#f))))
;; called in megatest.scm, host-port is string hostname:port
;;
(define (server:ping run-id host:port area-dat)
(let ((tdbdat (tasks:open-db area-dat)))
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
(toppath (launch:setup-for-run))
(server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
(if (not run-id)
|