1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp rpc s11n)
(import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo zmq)
(import (prefix sqlite3 sqlite3:))
(declare (unit server))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp rpc s11n)
(import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo zmq md5 message-digest)
(import (prefix sqlite3 sqlite3:))
(declare (unit server))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
|
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
158
159
160
161
162
163
164
|
(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:client-setup)
(if (not *toppath*)(setup-for-run))
(let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))
(zmq-socket (make-socket 'req)))
(if hostinfo
(begin
(debug:print-info 2 "Setting up to connect to " hostinfo)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to open a connection to the server at: " hostinfo)
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 " perhaps jobs killed with -9? Removing server records")
(open-run-close tasks:server-deregister tasks:open-db (car hostinfo) port: (cadr hostinfo))
;; (exit) ;; why forced exit?
#f)
(let ((connect-ok #f)
(conurl (server:make-server-url hostinfo)))
(connect-socket zmq-socket conurl)
(set! connect-ok (cdb:client-call zmq-socket 'login #t *toppath*))
(if connect-ok
(begin
(debug:print-info 2 "Logged in and connected to " conurl)
(set! *runremote* zmq-socket)
#t)
(begin
(debug:print-info 2 "Failed to login or connect to " conurl)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
(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)
(argv)))))))
;; MOVE ME TO COMMON
(define *my-client-signature* #f)
(define (server:client-login host port)
(let ((connect-ok #f)
(zmq-socket (make-socket 'req))
(mysig (if *my-client-signature* *my-client-signature* (server:mk-signature)))
(conurl (server:make-server-url (list host port))))
(set! *my-client-signature* mysig)
(connect-socket zmq-socket conurl)
(if (cdb:login zmq-socket *toppath* mysig)
zmq-socket
(if (socket? *runremote*)
(begin
(close-socket *runremote*)
#f)
zmq-socket))))
(define (server:client-logout zmq-socket)
(and (socket? zmq-socket)
(cdb:logout zmq-socket *toppath* *my-client-signature*)
(close-socket zmq-socket)))
(define (server:client-setup)
(if (not *toppath*)(setup-for-run))
(let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))
(zmq-socket (make-socket 'req)))
(if hostinfo
(begin
(debug:print-info 2 "Setting up to connect to " hostinfo)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to open a connection to the server at: " hostinfo)
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 " perhaps jobs killed with -9? Removing server records")
(open-run-close tasks:server-deregister tasks:open-db (car hostinfo) port: (cadr hostinfo))
;; (exit) ;; why forced exit?
#f)
;; REPLACE WITH server:client-login
;;
(let ((connect-ok #f)
(conurl (server:make-server-url hostinfo)))
(connect-socket zmq-socket conurl)
(set! connect-ok (cdb:login zmq-socket))
(if connect-ok
(begin
(debug:print-info 2 "Logged in and connected to " conurl)
(set! *runremote* zmq-socket)
#t)
(begin
(debug:print-info 2 "Failed to login or connect to " conurl)
|