hash-lang-uwu
/
CS3700-project2
2
0
Fork 0
Code Issues Releases Activity

fixed unix sockets

This commit is contained in:
Milo 2020-01-30 18:56:17 -05:00
parent 83f2a89b25
commit 7505e181ea
3 changed files with 52 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
private/unix-socket-ffi.rkt
View File

@ -14,9 +14,12 @@
(case (system-type 'os) (case (system-type 'os)
[(macosx) 'bsd] [(macosx) 'bsd]
[(unix) [(unix)
(define sys (path->string (system-library-subpath #f))) (define machine
(cond [(regexp-match? #rx"-linux$" sys) 'linux] ;; security guard may prevent executing uname
[(regexp-match? #rx"bsd$" sys) 'bsd] (with-handlers ([exn:fail? (lambda (e) "unknown")])
(system-type 'machine)))
(cond [(regexp-match? #rx"^Linux" machine) 'linux]
[(regexp-match? #rx"^[a-zA-Z]*BSD" machine) 'bsd]
[else #f])] [else #f])]
[else #f])) [else #f]))
@ -154,8 +157,8 @@
;; Racket constants and functions ;; Racket constants and functions
;; indirection to support testing; see below ;; indirection to support testing; see below
(define (fd->evt fd mode) (define (socket->semaphore fd mode)
(unsafe-fd->evt fd mode #t)) (unsafe-socket->semaphore fd mode))
;; ============================================================ ;; ============================================================
;; Testing ;; Testing
@ -172,7 +175,7 @@
(when #f (when #f
;; -- mock for connect returning EINPROGRESS ;; -- mock for connect returning EINPROGRESS
(let ([real-connect connect] (let ([real-connect connect]
[real-fd->evt fd->evt]) [real-socket->semaphore socket->semaphore])
;; connecting-fds : hash[nat => #t] ;; connecting-fds : hash[nat => #t]
(define connecting-fds (make-hash)) (define connecting-fds (make-hash))
(set! connect (set! connect
@ -184,7 +187,7 @@
(eprintf "** mock connect: setting EINPROGRESS\n") (eprintf "** mock connect: setting EINPROGRESS\n")
-1] -1]
[else r]))) [else r])))
(set! fd->evt (set! socket->semaphore
(lambda (fd kind) (lambda (fd kind)
(cond [(and (eq? kind 'write) (cond [(and (eq? kind 'write)
(hash-ref connecting-fds fd #f)) (hash-ref connecting-fds fd #f))
@ -197,14 +200,14 @@
(hash-remove! connecting-fds fd) (hash-remove! connecting-fds fd)
sema] sema]
[else [else
(real-fd->evt fd kind)]))))) (real-socket->semaphore fd kind)])))))
;; mock for accept returning EWOULDBLOCK/EAGAIN no longer works, ;; mock for accept returning EWOULDBLOCK/EAGAIN no longer works,
;; probably because doesn't intercept unsafe-poll-ctx-fd-wakeup ;; probably because doesn't intercept unsafe-poll-ctx-fd-wakeup
(when #f (when #f
;; - mock for accept returning EWOULDBLOCK/EAGAIN ;; - mock for accept returning EWOULDBLOCK/EAGAIN
(let ([real-accept accept] (let ([real-accept accept]
[real-fd->evt fd->evt]) [real-socket->semaphore socket->semaphore])
;; accepting-fds : hash[nat => #t] ;; accepting-fds : hash[nat => #t]
(define accepting-fds (make-hash)) (define accepting-fds (make-hash))
(set! accept (set! accept
@ -217,7 +220,7 @@
(hash-set! accepting-fds s #t) (hash-set! accepting-fds s #t)
(saved-errno EWOULDBLOCK) (saved-errno EWOULDBLOCK)
-1]))) -1])))
(set! fd->evt (set! socket->semaphore
(lambda (fd kind) (lambda (fd kind)
(cond [(and (eq? kind 'read) (cond [(and (eq? kind 'read)
(hash-ref accepting-fds fd #f)) (hash-ref accepting-fds fd #f))
@ -229,4 +232,4 @@
(semaphore-post sema))) (semaphore-post sema)))
sema] sema]
[else [else
(real-fd->evt fd kind)]))))) (real-socket->semaphore fd kind)])))))

41
router
View File

@ -28,6 +28,7 @@
(define buf (make-bytes 65536)) (define buf (make-bytes 65536))
(let loop () (let loop ()
(define len (read-bytes-avail! buf sock-in)) (define len (read-bytes-avail! buf sock-in))
(printf "got ~a bytes from ~a...\n" len peer)
(define jsexpr (bytes->jsexpr (subbytes buf 0 len))) (define jsexpr (bytes->jsexpr (subbytes buf 0 len)))
(channel-put mail (list peer jsexpr)) (channel-put mail (list peer jsexpr))
(loop)))))) (loop))))))
@ -37,35 +38,37 @@
(printf "from ~a:\n~s\n" peer data) (printf "from ~a:\n~s\n" peer data)
(loop)) (loop))
(define loop-thread (printf "waiting for messages...\n")
(thread loop)) (loop))
(λ ()
(for-each break-thread
(cons loop-thread
peer-threads))))
;; Str [Listof Peer] -> ;; Str [Listof Peer] ->
;; Router main ;; Router main
(define (run-router asn peers) (define (run-router asn peers)
(displayln asn) (displayln asn)
(map displayln peers) (map displayln peers)
(run-router/conns (displayln "------------")
(for/list ([peer (in-list peers)]) (with-handlers ([exn:break:terminate? (λ (e)
(define-values [sock-in sock-out] (printf "time to die.\n"))])
(unix-socket-connect (ip->string (peer-ip peer)) (run-router/conns
'SOCK_SEQPACKET)) asn
(peer-conn peer (for/list ([peer (in-list peers)])
sock-in (define-values [sock-in sock-out]
sock-out)))) (unix-socket-connect (ip->string (peer-ip peer))
'SOCK-SEQPACKET))
(peer-conn peer
sock-in
sock-out)))))
(module+ main (module+ main
(command-line (command-line
#:program "router" #:program "router"
#:args #:args
(asn . peers) (asn . peers)
;; Run the router (with-output-to-file "log.txt"
(run-router asn (map string->peer peers)))) #:exists 'replace
(λ ()
;; Run the router
(run-router asn (map string->peer peers))))))
(module+ test (module+ test
@ -74,9 +77,9 @@
(define p1 (peer-conn (string->peer "1.2.3.4-cust") in1 out1)) (define p1 (peer-conn (string->peer "1.2.3.4-cust") in1 out1))
(define p2 (peer-conn (string->peer "1.2.3.5-peer") in2 out2)) (define p2 (peer-conn (string->peer "1.2.3.5-peer") in2 out2))
(define abort-router ; (define abort-router
(run-router/conns "123" (run-router/conns "123"
(list p1 p2))) (list p1 p2))
(void (void
(write-string "{\"a\": 1, \"b\": [1,2,3]}" out1))) (write-string "{\"a\": 1, \"b\": [1,2,3]}" out1)))

33
unix-socket.rkt
View File

@ -80,7 +80,7 @@
;; close/unregister : Nat Cust-Reg/#f -> Void ;; close/unregister : Nat Cust-Reg/#f -> Void
(define (close/unregister fd [reg #f]) (define (close/unregister fd [reg #f])
(close fd) (close fd)
(fd->evt fd 'remove) (socket->semaphore fd 'remove)
(when reg (unregister-custodian-shutdown fd reg))) (when reg (unregister-custodian-shutdown fd reg)))
;; make-socket-ports : Symbol FD Cust-Reg/#f -> (values Input-Port Output-Port) ;; make-socket-ports : Symbol FD Cust-Reg/#f -> (values Input-Port Output-Port)
@ -154,7 +154,6 @@
;; unix-socket-connect : Path/String [Symbol] -> (values Input-Port Output-Port) ;; unix-socket-connect : Path/String [Symbol] -> (values Input-Port Output-Port)
(define (unix-socket-connect path [mode 'SOCK-STREAM]) (define (unix-socket-connect path [mode 'SOCK-STREAM])
(check-available 'unix-socket-connect) (check-available 'unix-socket-connect)
(define cust (current-custodian))
(define-values (sockaddr addrlen) (do-make-sockaddr 'unix-socket-connect path)) (define-values (sockaddr addrlen) (do-make-sockaddr 'unix-socket-connect path))
(define connect-k (define connect-k
;; Non-blocking connect may succeed immediately or require waiting to see. ;; Non-blocking connect may succeed immediately or require waiting to see.
@ -164,25 +163,24 @@
;; whatever needs doing. ;; whatever needs doing.
(call-as-atomic (call-as-atomic
(lambda () (lambda ()
(when (custodian-shut-down? cust) (when (custodian-shut-down? (current-custodian))
(error 'unix-socket-connect "the custodian has been shut down")) (error 'unix-socket-connect "the custodian has been shut down"))
(define-values (socket-fd reg) (do-make-socket 'unix-socket-connect (define-values (socket-fd reg) (do-make-socket 'unix-socket-connect
(match mode (match mode
['SOCK-STREAM SOCK-STREAM] ['SOCK-STREAM SOCK-STREAM]
['SOCK-SEQPACKET SOCK-SEQPACKET]))) ['SOCK-SEQPACKET SOCK-SEQPACKET])))
(define r (connect socket-fd sockaddr addrlen)) (define r (connect socket-fd sockaddr addrlen))
(define errno (saved-errno)) (define errno (saved-errno))
(cond [(= r 0) ;; connected (cond [(= r 0) ;; connected
(define-values (in out) (make-socket-ports 'unix-socket-connect socket-fd reg)) (define-values (in out) (make-socket-ports 'unix-socket-connect socket-fd reg))
(lambda () (values in out))] (lambda () (values in out))]
[(= errno EINPROGRESS) ;; wait and see [(= errno EINPROGRESS) ;; wait and see
(define ready-evt (fd->evt socket-fd 'write)) (define sema (socket->semaphore socket-fd 'write))
(lambda () ;; called in non-atomic mode! (lambda () ;; called in non-atomic mode!
(sync ready-evt) (sync sema)
;; FIXME: check custodian hasn't been shut down?
(call-as-atomic (call-as-atomic
(lambda () (lambda ()
(when (custodian-shut-down? cust) ;; => socket-fd already closed by shutdown
(error 'unix-socket-connect "the custodian has been shut down"))
(define errno (getsockopt socket-fd SOL_SOCKET SO_ERROR)) (define errno (getsockopt socket-fd SOL_SOCKET SO_ERROR))
(cond [(= errno 0) (cond [(= errno 0)
(make-socket-ports 'unix-socket-connect socket-fd reg)] (make-socket-ports 'unix-socket-connect socket-fd reg)]
@ -214,10 +212,10 @@
(lambda () (lambda ()
(wrap-evt (wrap-evt
;; ready when fd is readable OR listener is closed ;; ready when fd is readable OR listener is closed
;; If closed after evt creation, then fd-evt becomes ready ;; If closed after evt creation, then fd-sema becomes ready
;; when fd closed and fd-evt is unregistered. ;; when fd closed and fd-sema unregistered.
(cond [(unix-socket-listener-fd self) (cond [(unix-socket-listener-fd self)
=> (lambda (fd) (fd->evt fd 'read))] => (lambda (fd) (socket->semaphore fd 'read))]
[else always-evt]) [else always-evt])
(lambda (r) self)))))) (lambda (r) self))))))
@ -229,8 +227,8 @@
(lambda () (lambda ()
(define-values (socket-fd reg) (do-make-socket 'unix-socket-listen (define-values (socket-fd reg) (do-make-socket 'unix-socket-listen
(match mode (match mode
['SOCK-STREAM SOCK-STREAM] ['SOCK-STREAM SOCK-STREAM]
['SOCK-SEQPACKET SOCK-SEQPACKET]))) ['SOCK-SEQPACKET SOCK-SEQPACKET])))
(unless (zero? (bind socket-fd sockaddr addrlen)) (unless (zero? (bind socket-fd sockaddr addrlen))
(close/unregister socket-fd reg) (close/unregister socket-fd reg)
(error 'unix-socket-listen "failed to bind socket\n path: ~e~a" (error 'unix-socket-listen "failed to bind socket\n path: ~e~a"
@ -282,15 +280,14 @@
(values (list (lambda () (error who "unix socket listener is closed"))) (values (list (lambda () (error who "unix socket listener is closed")))
#f)] #f)]
[(custodian-shut-down? (accept-evt-cust accept-evt)) [(custodian-shut-down? (accept-evt-cust accept-evt))
(values (list (lambda () (error '|unix-socket-accept-evt poll| "the custodian has been shut down"))) (error '|unix-socket-accept-evt poll| "the custodian has been shut down")]
#f)]
[lfd [lfd
(cond [maybe-wakeups (accept-poll/sleep who accept-evt maybe-wakeups lfd)] (cond [maybe-wakeups (accept-poll/sleep who accept-evt maybe-wakeups lfd)]
[else (accept-poll/check who accept-evt lfd)])])) [else (accept-poll/check who accept-evt lfd)])]))
(define (accept-poll/sleep who accept-evt wakeups lfd) (define (accept-poll/sleep who accept-evt wakeups lfd)
;; No need to register wakeup for custodian; custodian shutdown means a Racket thread ;; No need to register wakeup for custodian; if custodian is shut down, then
;; did work, so accept-evt will get re-polled. ;; lfd semaphore becomes ready when it is unregistered
(unsafe-poll-ctx-fd-wakeup wakeups lfd 'read) (unsafe-poll-ctx-fd-wakeup wakeups lfd 'read)
(values #f accept-evt)) (values #f accept-evt))