| ︙ | | | ︙ | |
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
(if (not (member qtype '(sync ping)))
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)))
(open-run-close db:process-queue-item packet))))))
;; This is recursively run by server:run until sucessful
;;
(define (server:try-start-server ipaddrstr portnum)
(handle-exceptions
exn
|
|
|
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
(if (not (member qtype '(sync ping)))
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)))
(open-run-close db:process-queue-item open-db packet))))))
;; This is recursively run by server:run until sucessful
;;
(define (server:try-start-server ipaddrstr portnum)
(handle-exceptions
exn
|
| ︙ | | | ︙ | |
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
(write (list (current-directory)
(argv)))))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
(define (server:reply pubsock target query-sig success/fail result)
(debug:print-info 11 "server:reply target=" target ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(db:obj->string (vector success/fail query-sig result)))
;;======================================================================
;; C L I E N T S
;;======================================================================
(define (server:get-client-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
(set! *my-client-signature* sig)
*my-client-signature*)))
;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (server:client-send-receive serverdat msg)
(let* ((url (server:make-server-url serverdat))
(fullurl (conc url "/?dat=" msg)))
(print "url=" url ", fullurl=" fullurl)
(let* ((res (with-input-from-request fullurl #f read-string)))
(print "got res=" res)
(let ((match (string-search (regexp "<body>(.*)<.body>") (caddr (string-split res "\n")))))
(cadr match)))))
(define (server:client-login serverdat)
(cdb:login serverdat *toppath* (server:get-client-signature)))
;; Not currently used! But, I think it *should* be used!!!
(define (server:client-logout serverdat)
(let ((ok (and (socket? serverdat)
|
|
|
|
|
|
|
>
|
>
>
|
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
(write (list (current-directory)
(argv)))))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
(define (server:reply return-addr query-sig success/fail result)
(debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(db:obj->string (vector success/fail query-sig result)))
;;======================================================================
;; C L I E N T S
;;======================================================================
(define (server:get-client-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
(set! *my-client-signature* sig)
*my-client-signature*)))
;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (server:client-send-receive serverdat msg)
(let* ((url (server:make-server-url serverdat))
(fullurl (conc url "/?dat=" msg)))
(debug:print-info 11 "fullurl=" fullurl)
(let* ((res (with-input-from-request fullurl #f read-string)))
(debug:print-info 11 "got res=" res)
(let ((match (string-search (regexp "<body>(.*)<.body>") res)))
(debug:print-info 11 "match=" match)
(let ((final (cadr match)))
(debug:print-info 11 "final=" final)
final)))))
(define (server:client-login serverdat)
(cdb:login serverdat *toppath* (server:get-client-signature)))
;; Not currently used! But, I think it *should* be used!!!
(define (server:client-logout serverdat)
(let ((ok (and (socket? serverdat)
|
| ︙ | | | ︙ | |
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
|
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: failed to find megatest.config, exiting")
(exit))))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(if hostinfo
(let ((host (list-ref hostinfo 0))
(iface (list-ref hostinfo 1)))
(debug:print-info 2 "Setting up to connect to " hostinfo)
(server:client-connect iface port)) ;; )
(if (> numtries 0)
(let ((exe (car (argv)))
(pid #f))
(debug:print-info 0 "No server available, attempting to start one...")
;; (set! pid (process-run exe (list "-server" "-" "-debug" (if (list? *verbosity*)
;; (string-intersperse *verbosity* ",")
;; (conc *verbosity*)))))
(set! pid (process-fork (lambda ()
;; (current-input-port (open-input-file "/dev/null"))
;; (current-output-port (open-output-file "/dev/null"))
;; (current-error-port (open-output-file "/dev/null"))
(server:launch)))) ;; should never get here ....
(let loop ((count 0))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(if (not hostinfo)
(begin
(debug:print-info 0 "Waiting for server pid=" pid " to start")
(sleep 2) ;; give server time to start
(if (< count 5)
|
|
>
>
|
|
|
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
|
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: failed to find megatest.config, exiting")
(exit))))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(if hostinfo
(let ((host (list-ref hostinfo 0))
(iface (list-ref hostinfo 1))
(port (list-ref hostinfo 2))
(pid (list-ref hostinfo 3)))
(debug:print-info 2 "Setting up to connect to " hostinfo)
(server:client-connect iface port)) ;; )
(if (> numtries 0)
(let (;; (exe (car (argv)))
(pid #f))
(debug:print-info 0 "No server available, attempting to start one...")
;; (set! pid (process-run exe (list "-server" "-" "-debug" (if (list? *verbosity*)
;; (string-intersperse *verbosity* ",")
;; (conc *verbosity*)))))
(set! pid (process-fork (lambda ()
;; (current-input-port (open-input-file "/dev/null"))
;; (current-output-port (open-output-file "/dev/null"))
;; (current-error-port (open-output-file "/dev/null"))
(server:launch))))
(let loop ((count 0))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(if (not hostinfo)
(begin
(debug:print-info 0 "Waiting for server pid=" pid " to start")
(sleep 2) ;; give server time to start
(if (< count 5)
|
| ︙ | | | ︙ | |
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
(mutex-unlock! *heartbeat-mutex*)
(if sdat sdat
(begin
(sleep 4)
(loop))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0))
;; (print "Keep-running got server-info " server-info)
(let loop ((count 0))
(thread-sleep! 4) ;; no need to do this very often
;; NB// sync currently does NOT return queue-length
(let ((queue-len (cdb:client-call server-info 'sync #t 1)))
;; (print "Server running, count is " count)
(if (< count 1) ;; 3x3 = 9 secs aprox
(loop (+ count 1)))
;; NOTE: Get rid of this mechanism! It really is not needed...
(open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info))
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
(if (> (+ last-access
;; (* 50 60 60) ;; 48 hrs
|
|
>
|
|
|
|
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
(mutex-unlock! *heartbeat-mutex*)
(if sdat sdat
(begin
(sleep 4)
(loop))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0)
(spid (open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f)))
(print "Keep-running got server pid " spid ", using iface " iface " and port " port)
(let loop ((count 0))
(thread-sleep! 4) ;; no need to do this very often
;; NB// sync currently does NOT return queue-length
(let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
;; (print "Server running, count is " count)
(if (< count 1) ;; 3x3 = 9 secs aprox
(loop (+ count 1)))
;; NOTE: Get rid of this mechanism! It really is not needed...
(open-run-close tasks:server-update-heartbeat tasks:open-db spid)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
(if (> (+ last-access
;; (* 50 60 60) ;; 48 hrs
|
| ︙ | | | ︙ | |
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
|
(debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo))
(if *toppath*
(let* ((th2 (make-thread (lambda ()
(server:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-"))) "Server run"))
;; (th3 (make-thread (lambda ()(server:keep-running)) "Keep running"))
)
(set! *client-non-blocking-mode* #t)
;; (thread-start! th1)
;; (thread-start! th3)
(set! *didsomething* #t)
;; (thread-join! th3)
(if (not *received-response*)
(receive-message* *runremote*))) ;; flush out last call if applicable
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 " Done.")
(exit 4))
"exit on ^C timer")))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
|
|
<
<
|
<
<
|
|
|
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
|
(debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo))
(if *toppath*
(let* ((th2 (make-thread (lambda ()
(server:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-"))) "Server run"))
(th3 (make-thread (lambda ()(server:keep-running)) "Keep running"))
)
(thread-start! th2)
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th2)
)
(debug:print 0 "ERROR: Failed to setup for megatest")))
(exit)))
(define (server:client-signal-handler signum)
(handle-exceptions
exn
(debug:print " ... exiting ...")
(let ((th1 (make-thread (lambda ()
"") ;; do nothing for now (was flush out last call if applicable)
"eat response"))
(th2 (make-thread (lambda ()
(debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
(thread-sleep! 1) ;; give the flush one second to do it's stuff
(debug:print 0 " Done.")
(exit 4))
"exit on ^C timer")))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
|
| ︙ | | | ︙ | |