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

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