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

.

Browse Source 
original commit: d078ca7828baa6f57f816366ddd3e6d88b88930d
This commit is contained in:
Paul Graunke 2002-09-13 20:09:37 +00:00
parent d84fccb4f0
commit 866e43cf4c
4 changed files with 179 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/net/sendurl.ss
View File

@ -11,7 +11,8 @@
; : any -> bool
(define (browser-preference? x)
(or (not x) (memq x unix-browser-list) (custom-browser? x)))
(or (not x) (memq x unix-browser-list) (custom-browser? x)
(procedure? x)))
(define external-browser
(make-parameter
@ -30,6 +31,8 @@
[current-error-port null-output]
[current-output-port null-output])
(cond
[(procedure? (external-browser))
((external-browser) url-str)]
[(eq? (system-type) 'macos)
(if (regexp-match "Blue Box" (system-type #t))
;; Classic inside OS X:

129
collects/net/tcp-redirect.ss Normal file
View File

@ -0,0 +1,129 @@
(module tcp-redirect mzscheme
(provide tcp-redirect)
(require (lib "unitsig.ss")
(lib "channel.ss" "web-server")
(lib "etc.ss")
"tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port)
(define raw:tcp-accept tcp-accept)
(define raw:tcp-accept-ready? tcp-accept-ready?)
(define raw:tcp-addresses tcp-addresses)
(define raw:tcp-close tcp-close)
(define raw:tcp-connect tcp-connect)
(define raw:tcp-connect/enable-break tcp-connect/enable-break)
(define raw:tcp-listen tcp-listen)
(define raw:tcp-listener? tcp-listener?)
; I cannot follow the data definiton well because I don't have
; predicates tcp-port? or pipe-port?. I could print them out and
; look at the string, but that's ugly, too. Instead I use with-handlers.
; For tcp-listeners, I do have suitable predicates, but I still use
; an else branch in the conds since I want the same error message as
; the raw 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)
(with-handlers ([exn:application:type? void])
(raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport
(define (tcp-accept tcp-listener)
(cond
[(pipe-listener? tcp-listener)
(let ([in-out (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)
(with-handlers ([exn:application:type?
(lambda (exn) (values local-address local-address))])
(raw:tcp-addresses tcp-port)))
; : port -> void
(define (tcp-close tcp-listener)
(with-handlers ([exn:application:type?
(lambda (exn)
(hash-table-remove!
port-table
(pipe-listener-port tcp-listener)))])
(raw:tcp-close 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)])
(channel-put
(pipe-listener-channel
(hash-table-get
port-table
port
(lambda ()
(raise (make-exn:i/o:tcp
(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 (create-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"))

14
collects/net/tcp-sig.ss Normal file
View File

@ -0,0 +1,14 @@
(module tcp-sig mzscheme
(provide net:tcp^)
(require (lib "unitsig.ss"))
(define-signature net:tcp^
(tcp-abandon-port
tcp-accept
tcp-accept-ready?
tcp-addresses
tcp-close
tcp-connect
tcp-connect/enable-break
tcp-listen
tcp-listener?)))

32
collects/net/tcp-unit.ss Normal file
View File

@ -0,0 +1,32 @@
(module tcp-unit mzscheme
(provide tcp@)
(require (lib "unitsig.ss")
"tcp-sig.ss")
; Okay, this file looks retarded. Something is clearly wrong.
(define raw:tcp-abandon-port tcp-abandon-port)
(define raw:tcp-accept tcp-accept)
(define raw:tcp-accept-ready? tcp-accept-ready?)
(define raw:tcp-addresses tcp-addresses)
(define raw:tcp-close tcp-close)
(define raw:tcp-connect tcp-connect)
(define raw:tcp-connect/enable-break tcp-connect/enable-break)
(define raw:tcp-listen tcp-listen)
(define raw:tcp-listener? tcp-listener?)
(define tcp@
(unit/sig net:tcp^
(import)
(define tcp-abandon-port raw:tcp-abandon-port)
(define tcp-accept raw:tcp-accept)
(define tcp-accept-ready? raw:tcp-accept-ready?)
(define tcp-addresses raw:tcp-addresses)
(define tcp-close raw:tcp-close)
(define tcp-connect raw:tcp-connect)
(define tcp-connect/enable-break raw:tcp-connect/enable-break)
(define tcp-listen raw:tcp-listen)
(define tcp-listener? raw:tcp-listener?)
)))