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