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

Hack: make the `net/url' implementation handle both "http" and "https" urls, dispatching to the plain tcp functions or the ssl one.

Browse Source 
(See "HACK" comment for a description on how this is done.)

original commit: e74f70393fcc27775b80a2bf18535082563ae779
This commit is contained in:
Eli Barzilay 2011-06-20 06:30:09 -04:00
parent 760adf6428
commit a14fe66f94
1 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/net/url-unit.rkt
View File

@ -12,10 +12,10 @@
;; "pure" = the MIME headers have been read ;; "pure" = the MIME headers have been read
(require racket/port racket/string (require racket/port racket/string
"url-structs.rkt" "url-structs.rkt" "uri-codec.rkt" "url-sig.rkt" "tcp-sig.rkt")
"uri-codec.rkt"
"url-sig.rkt" ;; See "HACK" below.
"tcp-sig.rkt") (require (prefix-in r: racket/tcp))
(import tcp^) (import tcp^)
(export url^) (export url^)
@ -92,13 +92,37 @@
[(string=? scheme "https") 443] [(string=? scheme "https") 443]
[else (url-error "Scheme ~a not supported" (url-scheme url))]))) [else (url-error "Scheme ~a not supported" (url-scheme url))])))
;; HACK: if `tcp-connect' is void, then instead of using the input unit
;; we dispatch (based on the url scheme) directly to the built in tcp
;; functionality or to the ssl functions. This makes it possible to
;; have net/url provide an implementation that handles both http and
;; https, while code that uses this unit directly (like old code that
;; slaps together an ssl version) continues to work.
(define dispatch-on-scheme? (void? tcp-connect))
(define get-ssl
(let ([connect #f] [abandon #f])
;; require the ssl code only when needed
(lambda (name)
(unless connect
(define-values/invoke-unit
((dynamic-require 'net/ssl-tcp-unit 'make-ssl-tcp@)
#f #f #f #f #f #f #f)
(import) (export tcp^))
(set! connect tcp-connect)
(set! abandon tcp-abandon-port))
(case name [(connect) connect] [(abandon) abandon]))))
;; make-ports : url -> in-port x out-port ;; make-ports : url -> in-port x out-port
(define (make-ports url proxy) (define (make-ports url proxy)
(let ([port-number (if proxy (let ([port-number (if proxy
(caddr proxy) (caddr proxy)
(or (url-port url) (url->default-port url)))] (or (url-port url) (url->default-port url)))]
[host (if proxy (cadr proxy) (url-host url))]) [host (if proxy (cadr proxy) (url-host url))])
(tcp-connect host port-number))) ((cond
[(not dispatch-on-scheme?) tcp-connect]
[(string=? (url-scheme url) "https") (get-ssl 'connect)]
[else r:tcp-connect])
host port-number)))
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
(define (http://getpost-impure-port get? url post-data strings) (define (http://getpost-impure-port get? url post-data strings)
@ -127,7 +151,10 @@
(println) (println)
(when post-data (display post-data client->server)) (when post-data (display post-data client->server))
(flush-output client->server) (flush-output client->server)
(tcp-abandon-port client->server) ((cond [(not dispatch-on-scheme?) tcp-abandon-port]
[(string=? (url-scheme url) "https") (get-ssl 'abandon)]
[else r:tcp-abandon-port])
client->server)
server->client) server->client)
(define (file://->path url [kind (system-path-convention-type)]) (define (file://->path url [kind (system-path-convention-type)])