suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: b751948c1d6b391cdfee4f8d48c5ef697930787d
This commit is contained in:
Robby Findler 2004-08-19 01:55:44 +00:00
parent 0a0ab9fcd8
commit 800aed2f82
1 changed files with 101 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
collects/net/tcp-redirect.ss
View File

@ -21,104 +21,104 @@
; primitive for bad inputs.
; : (listof nat) -> (unit/sig () -> net:tcp^)
(define (tcp-redirect redirected-ports)
(unit/sig net:tcp^
(import)
(define tcp-redirect
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
(unit/sig net:tcp^
(import)
; : (make-pipe-listener nat (channel (cons iport oport)))
(define-struct pipe-listener (port channel))
; : (make-pipe-listener nat (channel (cons iport oport)))
(define-struct pipe-listener (port channel))
; : port -> void
(define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port)))
; : port -> void
(define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport
(define (tcp-accept tcp-listener)
(cond
[(pipe-listener? tcp-listener)
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(values (car in-out) (cdr in-out)))]
[else (raw:tcp-accept tcp-listener)]))
; : listener -> iport oport
(define (tcp-accept tcp-listener)
(cond
[(pipe-listener? tcp-listener)
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(values (car in-out) (cdr in-out)))]
[else (raw:tcp-accept tcp-listener)]))
; : tcp-listener -> iport oport
; FIX - check channel queue size
(define (tcp-accept-ready? tcp-listener)
(cond
[(pipe-listener? tcp-listener) #t]
[else (raw:tcp-accept-ready? tcp-listener)]))
; : tcp-listener -> iport oport
; FIX - check channel queue size
(define (tcp-accept-ready? tcp-listener)
(cond
[(pipe-listener? tcp-listener) #t]
[else (raw:tcp-accept-ready? tcp-listener)]))
; : tcp-port -> str str
(define (tcp-addresses tcp-port)
(if (tcp-port? tcp-port)
(raw:tcp-addresses tcp-port)
(values local-address local-address)))
; : tcp-port -> str str
(define (tcp-addresses tcp-port)
(if (tcp-port? tcp-port)
(raw:tcp-addresses tcp-port)
(values redirected-address redirected-address)))
; : port -> void
(define (tcp-close tcp-listener)
(if (tcp-listener? tcp-listener)
(raw:tcp-close tcp-listener)
(hash-table-remove!
port-table
(pipe-listener-port tcp-listener))))
; : port -> void
(define (tcp-close tcp-listener)
(if (tcp-listener? tcp-listener)
(raw:tcp-close tcp-listener)
(hash-table-remove!
port-table
(pipe-listener-port tcp-listener))))
; : (str nat -> iport oport) -> str nat -> iport oport
(define (gen-tcp-connect raw)
(lambda (hostname-string port)
(if (and (string=? local-address hostname-string)
(redirect? port))
(let-values ([(to-in from-out) (make-pipe)]
[(from-in to-out) (make-pipe)])
(async-channel-put
(pipe-listener-channel
(hash-table-get
port-table
port
(lambda ()
(raise (make-exn:fail:network
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
hostname-string port)
(current-continuation-marks))))))
(cons to-in to-out))
(values from-in from-out))
(raw hostname-string port))))
; : (str nat -> iport oport) -> str nat -> iport oport
(define (gen-tcp-connect raw)
(lambda (hostname-string port)
(if (and (string=? redirected-address hostname-string)
(redirect? port))
(let-values ([(to-in from-out) (make-pipe)]
[(from-in to-out) (make-pipe)])
(async-channel-put
(pipe-listener-channel
(hash-table-get
port-table
port
(lambda ()
(raise (make-exn:fail:network
(string->immutable-string
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
hostname-string port))
(current-continuation-marks))))))
(cons to-in to-out))
(values from-in from-out))
(raw hostname-string port))))
; : str nat -> iport oport
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
; FIX - support the reuse? flag.
(define tcp-listen
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
(hash-table-get
port-table
port
(lambda ()
(if (redirect? port)
(let ([listener (make-pipe-listener port (make-async-channel))])
(hash-table-put! port-table port listener)
listener)
(raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
; FIX - support the reuse? flag.
(define tcp-listen
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
(hash-table-get
port-table
port
(lambda ()
(if (redirect? port)
(let ([listener (make-pipe-listener port (make-async-channel))])
(hash-table-put! port-table port listener)
listener)
(raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
; : tst -> bool
(define (tcp-listener? x)
(or (pipe-listener? x) (raw:tcp-listener? x)))
; : tst -> bool
(define (tcp-listener? x)
(or (pipe-listener? x) (raw:tcp-listener? x)))
; ---------- private ----------
; ---------- private ----------
; : (hash-table nat[port] -> tcp-listener)
(define port-table (make-hash-table))
; : (hash-table nat[port] -> tcp-listener)
(define port-table (make-hash-table))
(define redirect-table
(let ([table (make-hash-table)])
(for-each (lambda (x) (hash-table-put! table x #t))
redirected-ports)
table))
(define redirect-table
(let ([table (make-hash-table)])
(for-each (lambda (x) (hash-table-put! table x #t))
redirected-ports)
table))
; : nat -> bool
(define (redirect? port)
(hash-table-get redirect-table port (lambda () #f)))))
(define local-address "127.0.0.1"))
; : nat -> bool
(define (redirect? port)
(hash-table-get redirect-table port (lambda () #f)))))))