43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
-
+
|
(if ipstr ipstr hostname))))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket 5555 0))
(set! *cache-on* #t)
;; what to do when we quit
;;
(on-exit (lambda ()
(open-run-close tasks:server-deregister-self tasks:open-db)
(open-run-close tasks:server-deregister-self tasks:open-db #f)
(let loop ()
(let ((queue-len 0))
(thread-sleep! (random 5))
(mutex-lock! *incoming-mutex*)
(set! queue-len (length *incoming-data*))
(mutex-unlock! *incoming-mutex*)
(if (> queue-len 0)
|
68
69
70
71
72
73
74
75
76
77
78
79
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
108
109
110
111
112
113
|
68
69
70
71
72
73
74
75
76
77
78
79
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
108
109
110
111
112
113
|
+
-
-
+
-
-
+
+
-
-
+
+
-
-
+
+
-
+
|
(debug:print-info 12 "server=> received params=" params)
(set! res (cdb:cached-access params))
(debug:print-info 12 "server=> processed res=" res)
(send-message zmq-socket (db:obj->string res))
(if (not *time-to-exit*)
(loop)
(begin
(open-run-close tasks:server-deregister-self tasks:open-db #f)
(db:write-cached-data)
(open-run-close tasks:server-deregister-self tasks:open-db)
(thread-sleep! 1) ;; no need to do this very often
(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)
(> (+ *last-db-access* 60)(current-seconds)))
(if (or (> numrunning 0) ;; stay alive for two days after last access
(> (+ *last-db-access* (* 48 60 60))(current-seconds)))
(begin
(debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop 0)))
(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! 5)
(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))))))
(exit)))))))
(define (server:find-free-port-and-open host s port #!key (trynum 50))
(let ((s (if s s (make-socket 'rep)))
(p (if (number? port) port 5555)))
(handle-exceptions
exn
(begin
|
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
-
-
+
+
+
|
(debug:print-info 2 "Failed to login or connect to " conurl)
(set! *runremote* #f)
#f))))))
(if (> numtries 0)
(let ((exe (car (argv))))
(debug:print-info 1 "No server available, attempting to start one...")
(process-run exe (list "-server" "-" "-debug" (conc *verbosity*)))
(sleep 5)
(server:client-setup numtries: (- numtries 1) do-ping: do-ping))
(sleep 2)
;; not doing ping, assume the server started and registered itself
(server:client-setup numtries: (- numtries 1) do-ping: #f))
(debug:print-info 1 "Too many retries, giving up")))))
(define (server:launch)
(let* ((toppath (setup-for-run)))
(debug:print-info 0 "Starting the standalone server")
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(if hostinfo
|