diff --git a/collects/net/tcp-redirect.ss b/collects/net/tcp-redirect.ss index 6b93f3eba1..891abf69a2 100644 --- a/collects/net/tcp-redirect.ss +++ b/collects/net/tcp-redirect.ss @@ -21,104 +21,104 @@ ; primitive for bad inputs. ; : (listof nat) -> (unit/sig () -> net:tcp^) - (define (tcp-redirect redirected-ports) - (unit/sig net:tcp^ - (import) - - ; : (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))) - - ; : 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-port -> str str - (define (tcp-addresses tcp-port) - (if (tcp-port? tcp-port) - (raw:tcp-addresses tcp-port) - (values local-address local-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)))) - - ; : (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 - (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)) - - ; 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))) - - ; ---------- private ---------- - - ; : (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)) - - ; : nat -> bool - (define (redirect? port) - (hash-table-get redirect-table port (lambda () #f))))) - - (define local-address "127.0.0.1")) \ No newline at end of file + (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)) + + ; : 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)])) + + ; : 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 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)))) + + ; : (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/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)))))) + + ; : tst -> bool + (define (tcp-listener? x) + (or (pipe-listener? x) (raw:tcp-listener? x))) + + ; ---------- private ---------- + + ; : (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)) + + ; : nat -> bool + (define (redirect? port) + (hash-table-get redirect-table port (lambda () #f))))))) \ No newline at end of file