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
|
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
|
+
+
+
+
+
-
+
+
-
+
-
-
-
-
+
+
-
+
|
(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 open-db "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:mak-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")
(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))))
(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)
|
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
-
+
|
(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
|