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
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
;; (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 "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 "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 area-dat)
(debug:print 2 "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* ((configdat (megatest:area-configdat area-dat))
(db #f)
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (open-run-close tasks:server-get-next-port tasks:open-db))
(link-tree-path (configf:lookup configdat "setup" "linktree"))
(rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
(th1 (make-thread
(lambda ()
((rpc:make-server rpc:listener) #t))
"rpc:server"))
;; (cute (rpc:make-server rpc:listener) "rpc:server")
;; 'rpc:server))
(hostname (if (string=? "-" hostn)
(get-host-name)
hostn))
(ipaddrstr (if (string=? "-" hostn)
(server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f))
(portnum (rpc:default-server-port))
(host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
(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 "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
;;======================================================================
;;
(on-exit (lambda ()
(open-run-close tasks:server-set-state! tasks:open-db server-id "stopped")))
(set! *rpc:listener* rpc:listener)
(tasks:server-set-state! tdb server-id "running")
(set! *inmemdb* (db:setup run-id))
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 5) ;; no need to do this very often
(let ((numrunning -1)) ;; (db:get-count-tests-running db)))
(if (or (> numrunning 0)
(> (+ *last-db-access* 60)(current-seconds)))
(begin
(debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop (+ 1 count)))
(begin
(debug:print-info 0 "Starting to shutdown the server side")
(open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
(thread-sleep! 10)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
))))))
(define (rpc-transport:find-free-port-and-open port)
(handle-exceptions
|
|
|
|
|
|
|
|
|
|
|
|
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
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
;; (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 area-dat)
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
(if (server:check-if-running run-id area-dat)
(begin
(debug:print 0 "INFO: Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (open-run-close tasks:server-lock-slot (lambda ()(tasks:open-db area-dat))run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
(begin
(thread-sleep! 2)
(loop (open-run-close tasks:server-lock-slot (lambda ()(tasks:open-db area-dat)) 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 "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 (lambda ()(tasks:open-db area-dat)) " 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 area-dat)
(debug:print 2 "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* ((configdat (megatest:area-configdat area-dat))
(db #f)
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (open-run-close tasks:server-get-next-port (lambda ()(tasks:open-db area-dat))))
(link-tree-path (configf:lookup configdat "setup" "linktree"))
(rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
(th1 (make-thread
(lambda ()
((rpc:make-server rpc:listener) #t))
"rpc:server"))
;; (cute (rpc:make-server rpc:listener) "rpc:server")
;; 'rpc:server))
(hostname (if (string=? "-" hostn)
(get-host-name)
hostn))
(ipaddrstr (if (string=? "-" hostn)
(server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f))
(portnum (rpc:default-server-port))
(host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
(tdb (tasks:open-db area-dat)))
(thread-start! th1)
(set! db *inmemdb*)
(open-run-close tasks:server-set-interface-port
(lambda ()(tasks:open-db area-dat))
server-id
ipaddrstr portnum)
(debug:print 0 "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
;;======================================================================
;;
(on-exit (lambda ()
(open-run-close tasks:server-set-state! (lambda ()(tasks:open-db area-dat)) server-id "stopped")))
(set! *rpc:listener* rpc:listener)
(tasks:server-set-state! tdb server-id "running")
(set! *inmemdb* (db:setup run-id))
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 5) ;; no need to do this very often
(let ((numrunning -1)) ;; (db:get-count-tests-running db)))
(if (or (> numrunning 0)
(> (+ *last-db-access* 60)(current-seconds)))
(begin
(debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop (+ 1 count)))
(begin
(debug:print-info 0 "Starting to shutdown the server side")
(open-run-close tasks:server-delete-record (lambda ()(tasks:open-db area-dat)) server-id " rpc-transport:try-start-server stop")
(thread-sleep! 10)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
))))))
(define (rpc-transport:find-free-port-and-open port)
(handle-exceptions
|
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
(let ((server-dat (list iface port #f #f #f)))
(common:set-remote! remote run-id server-dat)
server-dat)
(begin
(server:try-running run-id)
(thread-sleep! 2)
(rpc-transport:client-setup run-id area-dat remtries: (- remtries 1)))))
(let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
(debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if server-db-info
(let* ((iface (tasks:hostinfo-get-interface server-db-info))
(port (tasks:hostinfo-get-port server-db-info))
(server-dat (list iface port #f #f #f))
(ping-res ((rpc:procedure 'server:login host port) toppath)))
(if start-res
|
|
|
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
(let ((server-dat (list iface port #f #f #f)))
(common:set-remote! remote run-id server-dat)
server-dat)
(begin
(server:try-running run-id)
(thread-sleep! 2)
(rpc-transport:client-setup run-id area-dat remtries: (- remtries 1)))))
(let* ((server-db-info (open-run-close tasks:get-server (lambda ()(tasks:open-db area-dat)) run-id)))
(debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if server-db-info
(let* ((iface (tasks:hostinfo-get-interface server-db-info))
(port (tasks:hostinfo-get-port server-db-info))
(server-dat (list iface port #f #f #f))
(ping-res ((rpc:procedure 'server:login host port) toppath)))
(if start-res
|