15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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
|
+
+
+
+
+
+
-
+
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
-
+
|
(import (prefix sqlite3 sqlite3:))
(declare (unit server))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
(if (null? hostport)
#f
(conc "tcp://" hostname ":" port)))
(define (server:run hostn)
(debug:print 0 "Attempting to start the server ...")
(let ((host:port (open-run-close db:get-var #f "SERVER"))) ;; do whe already have a server running?
(let* ((hostport (open-run-close tasks:get-best-server tasks:open-db)) ;; do whe already have a server running?
(host:port (server:make-server-url hostport)))
(if host:port
(begin
(debug:print 0 "NOTE: server already running.")
(if (server:client-setup)
(begin
(debug:print-info 0 "Server is alive, not starting another")
(debug:print-info 0 "Server is alive, not starting another"))
;;(exit)
)
(debug:print-info 0 "Server is dead, removing flag and trying again")
(open-run-close db:del-var #f "SERVER")
(server:run hostn))))
(debug:print-info 0 "Server is dead, removing, deregistering it and trying again")
(open-run-close tasks:deregister tasks:open-db (car hostport) port: (cadr port))
;; (server:run hostn)
(debug:print 0 "WOULD NORMALLY START ANOTHER SERVER HERE")
)
)
)
(let* ((zmq-socket #f)
(hostname (if (string=? "-" hostn)
(get-host-name)
hostn))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
(string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f)))
(if ipstr ipstr hostname))))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket 5555))
(set! *cache-on* #t)
;; what to do when we quit
;;
(on-exit (lambda ()
(open-run-close db:del-var #f "SERVER")
(open-run-close tasks:server-deregister-self tasks:open-db)
(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)
|
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
-
+
|
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(server:find-free-port-and-open host s (+ p 1)))
(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 db:set-var #f "SERVER" zmq-url)
(open-run-close tasks:server-register tasks:open-db (current-process-id) host p 0 'live)
s))))
(define (server:client-setup)
(let* ((hostinfo (open-run-close db:get-var #f "SERVER"))
(zmq-socket (make-socket 'req)))
(if hostinfo
(begin
|
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
|
(set! *runremote* zmq-socket)
#t)
(begin
(debug:print-info 2 "Failed to login or connect to " hostinfo)
(set! *runremote* #f)
#f)))))
(begin
(debug:print-info 0 "NO SERVER RUNNING! PLEASE START ONE! E.g. \"megatest -server - &\"")
(debug:print-info 2 "No server available, attempting to start one...")
(system (conc "megatest -server - " (if (args:get-arg "-debug")
(conc "-debug " (args:get-arg "-debug"))
"")
" &"))
(sleep 5)
(server:client-setup)))))
;; (debug:print-info 2 "No server available, attempting to start one...")
;; (system (conc (car (argv)) " -server - " (if (args:get-arg "-debug")
;; (conc "-debug " (args:get-arg "-debug"))
;; "")
;; " &"))
;; (sleep 5)
;; (server:client-setup)
))))
(define (server:launch)
(let* ((toppath (setup-for-run)))
(debug:print-info 0 "Starting the standalone server")
(if *toppath*
(let* ((th2 (make-thread (lambda ()
(server:run (args:get-arg "-server")))))
|