Megatest

Diff
Login

Differences From Artifact [83f96f7c65]:

To Artifact [c469d03fe2]:


36
37
38
39
40
41
42

43
44
45
46
47
48
49

(define (server:start db hostn)
  (debug:print 0 "Attempting to start the server ...")
  (let* ((rpc:listener   (server:find-free-port-and-open (rpc:default-server-port)))
	 (th1            (make-thread
			  (cute (rpc:make-server rpc:listener) "rpc:server")
			  'rpc:server))

	 (hostname       (if (string=? "-" hostn)
			     (get-host-name) 
			     hostn))
	 (ipaddrstr      (if (string=? "-" hostn)
			     (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
			     #f))
	 (host:port      (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:default-server-port))))







>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

(define (server:start db hostn)
  (debug:print 0 "Attempting to start the server ...")
  (let* ((rpc:listener   (server:find-free-port-and-open (rpc:default-server-port)))
	 (th1            (make-thread
			  (cute (rpc:make-server rpc:listener) "rpc:server")
			  'rpc:server))
	 (th2            (make-thread (lambda ()(db:updater db))))
	 (hostname       (if (string=? "-" hostn)
			     (get-host-name) 
			     hostn))
	 (ipaddrstr      (if (string=? "-" hostn)
			     (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
			     #f))
	 (host:port      (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:default-server-port))))
94
95
96
97
98
99
100





101
102
103
104
105
106
107
     (lambda (run-id test-name item-path comment)
       (db:test-set-comment db run-id test-name item-path comment)))
    
    (rpc:publish-procedure!
     'rdb:test-set-log!
     (lambda (run-id test-name item-path logf)
       (db:test-set-log! db run-id test-name item-path logf)))






    (rpc:publish-procedure!
     'serve:get-toppath
     (lambda ()
       *toppath*))

    (rpc:publish-procedure!







>
>
>
>
>







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
     (lambda (run-id test-name item-path comment)
       (db:test-set-comment db run-id test-name item-path comment)))
    
    (rpc:publish-procedure!
     'rdb:test-set-log!
     (lambda (run-id test-name item-path logf)
       (db:test-set-log! db run-id test-name item-path logf)))
    
    (rpc:publish-procedure!
     'rpc:get-test-data-by-id
     (lambda (test-id)
       (db:get-test-data-by-id db test-id)))

    (rpc:publish-procedure!
     'serve:get-toppath
     (lambda ()
       *toppath*))

    (rpc:publish-procedure!
194
195
196
197
198
199
200

201
202
203
204
205
206
207
208
       (tests:register-test db run-id test-name item-path)))

    (set! *rpc:listener* rpc:listener)
    (on-exit (lambda ()
	       (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
	       (sqlite3:finalize! db)))
    (thread-start! th1)

    (thread-join! th1))) ;; rpc:server)))

(define (server:find-free-port-and-open port)
  (handle-exceptions
   exn
   (begin
     (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
     (server:find-free-port-and-open (+ port 1)))







>
|







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
       (tests:register-test db run-id test-name item-path)))

    (set! *rpc:listener* rpc:listener)
    (on-exit (lambda ()
	       (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
	       (sqlite3:finalize! db)))
    (thread-start! th1)
    (thread-start! th2)
    (thread-join!  th2))) ;; rpc:server)))

(define (server:find-free-port-and-open port)
  (handle-exceptions
   exn
   (begin
     (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
     (server:find-free-port-and-open (+ port 1)))