| ︙ | | | ︙ | |
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
72
73
74
|
(include "db_records.scm")
;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)
(handle-exceptions
exn
(begin
(debug:print 1 #f "Remote failed for " proc " " params)
(apply (eval (string->symbol procstr)) params))
;; (if *runremote*
;; (apply (eval (string->symbol (conc "remote:" procstr))) params)
(apply (eval (string->symbol procstr)) params)))
;; all routes though here end in exit ...
;;
;; start_server?
;;
(define (rpc-transport:launch run-id)
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
(if (server:check-if-running run-id)
(begin
(debug:print 0 #f "INFO: Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
(begin
(thread-sleep! 2)
(loop (open-run-close tasks:server-lock-slot tasks:open-db run-id)
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
(debug:print-info 2 #f "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch")))
(begin
(rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
(exit)))))
(define (rpc-transport:run hostn run-id server-id)
(debug:print 2 #f "Attempting to start the rpc server ...")
;; (trace rpc:publish-procedure!)
(rpc:publish-procedure! 'server:login server:login)
(rpc:publish-procedure! 'testing (lambda () "Just testing"))
(let* ((db #f)
(hostname (get-host-name))
|
|
|
|
|
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
72
73
74
|
(include "db_records.scm")
;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)
(handle-exceptions
exn
(begin
(debug:print 1 *default-log-port* "Remote failed for " proc " " params)
(apply (eval (string->symbol procstr)) params))
;; (if *runremote*
;; (apply (eval (string->symbol (conc "remote:" procstr))) params)
(apply (eval (string->symbol procstr)) params)))
;; all routes though here end in exit ...
;;
;; start_server?
;;
(define (rpc-transport:launch run-id)
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
(if (server:check-if-running run-id)
(begin
(debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
(begin
(thread-sleep! 2)
(loop (open-run-close tasks:server-lock-slot tasks:open-db run-id)
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
(debug:print-info 2 #f "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch")))
(begin
(rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
(exit)))))
(define (rpc-transport:run hostn run-id server-id)
(debug:print 2 *default-log-port* "Attempting to start the rpc server ...")
;; (trace rpc:publish-procedure!)
(rpc:publish-procedure! 'server:login server:login)
(rpc:publish-procedure! 'testing (lambda () "Just testing"))
(let* ((db #f)
(hostname (get-host-name))
|
| ︙ | | | ︙ | |
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
(tdb (tasks:open-db)))
(thread-start! th1)
(set! db *inmemdb*)
(open-run-close tasks:server-set-interface-port
tasks:open-db
server-id
ipaddrstr portnum)
(debug:print 0 #f "Server started on " host:port)
;; (trace rpc:publish-procedure!)
;; (rpc:publish-procedure! 'server:login server:login)
;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))
;;======================================================================
;; ;; end of publish-procedure section
|
|
|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
(tdb (tasks:open-db)))
(thread-start! th1)
(set! db *inmemdb*)
(open-run-close tasks:server-set-interface-port
tasks:open-db
server-id
ipaddrstr portnum)
(debug:print 0 *default-log-port* "Server started on " host:port)
;; (trace rpc:publish-procedure!)
;; (rpc:publish-procedure! 'server:login server:login)
;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))
;;======================================================================
;; ;; end of publish-procedure section
|
| ︙ | | | ︙ | |
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
(begin
(print "LOGIN_FAILED")
(exit 1))))))
(define (rpc-transport:client-setup run-id #!key (remtries 10))
(if *runremote*
(begin
(debug:print 0 #f "ERROR: Attempt to connect to server but already connected")
#f)
(let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
(if host-info
(let ((iface (car host-info))
(port (cadr host-info))
(ping-res ((rpc:procedure 'server:login host port) *toppath*)))
(if ping-res
|
|
|
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
(begin
(print "LOGIN_FAILED")
(exit 1))))))
(define (rpc-transport:client-setup run-id #!key (remtries 10))
(if *runremote*
(begin
(debug:print 0 *default-log-port* "ERROR: Attempt to connect to server but already connected")
#f)
(let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
(if host-info
(let ((iface (car host-info))
(port (cadr host-info))
(ping-res ((rpc:procedure 'server:login host port) *toppath*)))
(if ping-res
|
| ︙ | | | ︙ | |
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
;; (if (and port
;; (string->number port))
;; (let ((portn (string->number port)))
;; (debug:print-info 2 #f "Setting up to connect to host " host ":" port)
;; (handle-exceptions
;; exn
;; (begin
;; (debug:print 0 #f "ERROR: Failed to open a connection to the server at host: " host " port: " port)
;; (debug:print 0 #f " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; ;; (open-run-close
;; ;; (lambda (db . param)
;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
;; ;; #f)
;; (set! *runremote* #f))
;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
;; ((rpc:procedure 'server:login host portn) *toppath*))
|
|
|
|
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
;; (if (and port
;; (string->number port))
;; (let ((portn (string->number port)))
;; (debug:print-info 2 #f "Setting up to connect to host " host ":" port)
;; (handle-exceptions
;; exn
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: Failed to open a connection to the server at host: " host " port: " port)
;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; ;; (open-run-close
;; ;; (lambda (db . param)
;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
;; ;; #f)
;; (set! *runremote* #f))
;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
;; ((rpc:procedure 'server:login host portn) *toppath*))
|
| ︙ | | | ︙ | |