| ︙ | | | ︙ | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "tcp://" (car hostport) ":" (cadr hostport))))
(define *time-to-exit* #f)
|
<
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "tcp://" (car hostport) ":" (cadr hostport))))
(define (server:run hostn)
(debug:print 0 "Attempting to start the server ...")
(if (not *toppath*)(setup-for-run))
(let* ((zmq-socket #f)
(hostname (if (string=? "-" hostn)
(get-host-name)
|
| ︙ | | | ︙ | |
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
|
(define (server:keep-running)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 3) ;; no need to do this very often
(db:write-cached-data)
;; (print "Server running, count is " count)
(if (< count 10)
(loop (+ count 1))
(let ((numrunning (open-run-close db:get-count-tests-running #f)))
(if (or (> numrunning 0) ;; stay alive for two days after last access
(> (+ *last-db-access* (* 48 60 60))(current-seconds)))
(begin
(debug:print-info 2 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db #f)
(thread-sleep! 1)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)))))))
(define (server:find-free-port-and-open host s port #!key (trynum 50))
(let ((s (if s s (make-socket 'rep)))
|
|
>
|
|
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
|
(define (server:keep-running)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 3) ;; no need to do this very often
(db:write-cached-data)
;; (print "Server running, count is " count)
(if (< count 2) ;; 3x3 = 9 secs aprox
(loop (+ count 1))
(let ((numrunning (open-run-close db:get-count-tests-running #f)))
(open-run-close tasks:server-update-heartbeat tasks:open-db *server-id*)
(if (or (> numrunning 0) ;; stay alive for two days after last access
(> (+ *last-db-access* (* 48 60 60))(current-seconds)))
(begin
(debug:print-info 2 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db)
(thread-sleep! 1)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)))))))
(define (server:find-free-port-and-open host s port #!key (trynum 50))
(let ((s (if s s (make-socket 'rep)))
|
| ︙ | | | ︙ | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
(debug:print-info 0 "Tried ports from " (- p trynum) " to " p
" but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")))
(let ((zmq-url (conc "tcp://" host ":" p)))
(print "Trying to start server on " zmq-url)
(bind-socket s zmq-url)
(set! *runremote* #f)
(debug:print 0 "Server started on " zmq-url)
(open-run-close tasks:server-register tasks:open-db (current-process-id) host p 0 'live)
s))))
(define (server:mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list (current-directory)
|
|
|
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
(debug:print-info 0 "Tried ports from " (- p trynum) " to " p
" but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")))
(let ((zmq-url (conc "tcp://" host ":" p)))
(print "Trying to start server on " zmq-url)
(bind-socket s zmq-url)
(set! *runremote* #f)
(debug:print 0 "Server started on " zmq-url)
(set! *server-id* (open-run-close tasks:server-register tasks:open-db (current-process-id) host p 0 'live))
s))))
(define (server:mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list (current-directory)
|
| ︙ | | | ︙ | |
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
;; Do all the connection work, start a server if not already running
(define (server:client-setup #!key (numtries 10)(do-ping #f))
(if (not *toppath*)(setup-for-run))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db do-ping: do-ping)))
(if hostinfo
(let ((host (car hostinfo))
(port (cadr hostinfo))
(zsocket (caddr hostinfo)))
;; (set! *runremote* zsocket))
(let* ((host (car hostinfo))
(port (cadr hostinfo)))
(debug:print-info 2 "Setting up to connect to " hostinfo)
(handle-exceptions
exn
(begin
|
|
|
|
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
;; Do all the connection work, start a server if not already running
(define (server:client-setup #!key (numtries 10)(do-ping #f))
(if (not *toppath*)(setup-for-run))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db do-ping: do-ping)))
(if hostinfo
(let ((host (car hostinfo))
(port (cadr hostinfo)))
;; (zsocket (caddr hostinfo)))
;; (set! *runremote* zsocket))
(let* ((host (car hostinfo))
(port (cadr hostinfo)))
(debug:print-info 2 "Setting up to connect to " hostinfo)
(handle-exceptions
exn
(begin
|
| ︙ | | | ︙ | |
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th3))
(debug:print 0 "ERROR: Failed to setup for megatest"))))))
(define (server:client-launch #!key (do-ping #f))
(if (server:client-setup do-ping: do-ping)
(debug:print-info 0 "connected as client")
(begin
(debug:print 0 "ERROR: Failed to connect as client")
(exit))))
;; ping a server and return number of clients or #f (if no response)
(define (server:ping host port #!key (secs 10)(return-socket #f))
(cdb:use-non-blocking-mode
|
|
|
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th3))
(debug:print 0 "ERROR: Failed to setup for megatest"))))))
(define (server:client-launch #!key (do-ping #f))
(if (server:client-setup do-ping: do-ping)
(debug:print-info 2 "connected as client")
(begin
(debug:print 0 "ERROR: Failed to connect as client")
(exit))))
;; ping a server and return number of clients or #f (if no response)
(define (server:ping host port #!key (secs 10)(return-socket #f))
(cdb:use-non-blocking-mode
|
| ︙ | | | ︙ | |