| ︙ | | | ︙ | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses portlogger))
(use address-info)
(module tcp-transportmod
*
(import scheme
(prefix sqlite3 sqlite3:)
chicken
|
|
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses portlogger))
(use address-info tcp)
(module tcp-transportmod
*
(import scheme
(prefix sqlite3 sqlite3:)
chicken
|
| ︙ | | | ︙ | |
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
(debug:print-info 0 *default-log-port* "No server found. Starting one for run-id "run-id" in dbfile "dbfname)
(server-start-proc)
(tt-last-serv-start-set! ttdat (current-seconds))))
(thread-sleep! 1)
(tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))
(define (tt:ping host port server-id #!optional (tries-left 5))
(let* ((res (tt:send-receive-direct host port `(ping #f #f #f))) ;; please send me your server-id
(try-again (lambda ()
(if (> tries-left 0)
(begin
(thread-sleep! 1)
(tt:ping host port server-id (- tries-left 1)))
#f))))
;;
|
|
|
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
(debug:print-info 0 *default-log-port* "No server found. Starting one for run-id "run-id" in dbfile "dbfname)
(server-start-proc)
(tt-last-serv-start-set! ttdat (current-seconds))))
(thread-sleep! 1)
(tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))
(define (tt:ping host port server-id #!optional (tries-left 5))
(let* ((res (tt:send-receive-direct host port `(ping #f #f #f) ping-mode: #t)) ;; please send me your server-id
(try-again (lambda ()
(if (> tries-left 0)
(begin
(thread-sleep! 1)
(tt:ping host port server-id (- tries-left 1)))
#f))))
;;
|
| ︙ | | | ︙ | |
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
|
(define (tt:send-receive ttdat conn cmd run-id params)
(let* ((host-port (tt-conn-host-port conn)) ;; (conc (tt-conn-host conn)":"(tt-conn-port conn)))
(host (tt-conn-host conn))
(port (tt-conn-port conn))
(dat (list cmd run-id params #f))) ;; no meta data yet
(tt:send-receive-direct host port dat)))
(define (tt:send-receive-direct host port dat)
(assert (number? port) "FATAL: tt:send-receive-direct called with port not a number "port)
(handle-exceptions
exn
#f ;; Add condition-case or better handling here
(let-values (((inp oup)(tcp-connect host port)))
(let ((res (if (and inp oup)
(begin
(serialize dat oup)
(close-output-port oup)
(deserialize inp))
)))
(close-input-port inp)
res))))
;;======================================================================
;; server
;;======================================================================
(define (tt:sync-dbs ttdat)
|
|
|
>
|
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
|
(define (tt:send-receive ttdat conn cmd run-id params)
(let* ((host-port (tt-conn-host-port conn)) ;; (conc (tt-conn-host conn)":"(tt-conn-port conn)))
(host (tt-conn-host conn))
(port (tt-conn-port conn))
(dat (list cmd run-id params #f))) ;; no meta data yet
(tt:send-receive-direct host port dat)))
(define (tt:send-receive-direct host port dat #!key (ping-mode #f)(tries-remaining 25))
(assert (number? port) "FATAL: tt:send-receive-direct called with port not a number "port)
(let* ((retry (lambda ()
(tt:send-receive-direct host port dat tries-remaining: (- tries-remaining 1))))
(full-err-print (lambda (exn)
(pp (condition->list exn) *default-log-port*)
(pp dat *default-log-port*)
(debug:print 0 *default-log-port*
", error: " ((condition-property-accessor 'exn 'message) exn)
", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
", location: " ((condition-property-accessor 'exn 'location) exn)
))))
(condition-case
(let-values (((inp oup)(tcp-connect host port)))
(let ((res (if (and inp oup)
(begin
(serialize dat oup)
(close-output-port oup)
(deserialize inp))
)))
(close-input-port inp)
res))
(exn (io-error)
(full-err-print exn)
(debug:print 0 *default-log-port* exn "ERROR: i/o error")
#f)
(exn (i/o net)
(if ping-mode
#f
(if (>= tries-remaining 0)
(let* ((backoff-delay (* (- 26 tries-remaining) 0.5)))
(debug:print 0 *default-log-port* "WARNING: TCP overload, trying again in "backoff-delay"s.")
(thread-sleep! backoff-delay)
(retry))
(assert #f "FATAL: Too many retries in tt:send-receive-direct"))))
(exn ()
(full-err-print exn)
#f))))
;;======================================================================
;; server
;;======================================================================
(define (tt:sync-dbs ttdat)
|
| ︙ | | | ︙ | |
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
|
(setup-listener-portlogger uconn))
#f)
(connect-listener uconn port))))
(define (connect-listener uconn port)
;; (tcp-listener-socket LISTENER)(socket-name so)
;; sockaddr-address, sockaddr-port, sockaddr->string
(let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
(addr (tt:get-best-guess-address (get-host-name)))) ;; (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
(tt-port-set! uconn port)
(tt-host-set! uconn addr)
(tt-host-port-set! uconn (conc addr":"port))
(tt-socket-set! uconn tlsn)
uconn))
|
|
|
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
|
(setup-listener-portlogger uconn))
#f)
(connect-listener uconn port))))
(define (connect-listener uconn port)
;; (tcp-listener-socket LISTENER)(socket-name so)
;; sockaddr-address, sockaddr-port, sockaddr->string
(let* ((tlsn (tcp-listen port 10000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
(addr (tt:get-best-guess-address (get-host-name)))) ;; (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
(tt-port-set! uconn port)
(tt-host-set! uconn addr)
(tt-host-port-set! uconn (conc addr":"port))
(tt-socket-set! uconn tlsn)
uconn))
|
| ︙ | | | ︙ | |