From e74f70393fcc27775b80a2bf18535082563ae779 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Mon, 20 Jun 2011 06:30:09 -0400
Subject: [PATCH] Hack: make the `net/url' implementation handle both "http"
 and "https" urls, dispatching to the plain tcp functions or the ssl one.

(See "HACK" comment for a description on how this is done.)
---
 collects/net/url-unit.rkt | 39 +++++++++++++++++++++++++++++++++------
 collects/net/url.rkt      | 17 ++++++++++-------
 2 files changed, 43 insertions(+), 13 deletions(-)

diff --git a/collects/net/url-unit.rkt b/collects/net/url-unit.rkt
index c5479ca5c6..245a7716f9 100644
--- a/collects/net/url-unit.rkt
+++ b/collects/net/url-unit.rkt
@@ -12,10 +12,10 @@
 ;;   "pure" = the MIME headers have been read
 
 (require racket/port racket/string
-         "url-structs.rkt"
-         "uri-codec.rkt"
-         "url-sig.rkt"
-         "tcp-sig.rkt")
+         "url-structs.rkt" "uri-codec.rkt" "url-sig.rkt" "tcp-sig.rkt")
+
+;; See "HACK" below.
+(require (prefix-in r: racket/tcp))
 
 (import tcp^)
 (export url^)
@@ -92,13 +92,37 @@
           [(string=? scheme "https") 443]
           [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
 (define (make-ports url proxy)
   (let ([port-number (if proxy
                        (caddr proxy)
                        (or (url-port url) (url->default-port 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
 (define (http://getpost-impure-port get? url post-data strings)
@@ -127,7 +151,10 @@
   (println)
   (when post-data (display post-data 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)
 
 (define (file://->path url [kind (system-path-convention-type)])
diff --git a/collects/net/url.rkt b/collects/net/url.rkt
index f7268c84fd..2cf7fead33 100644
--- a/collects/net/url.rkt
+++ b/collects/net/url.rkt
@@ -1,11 +1,14 @@
 #lang racket/base
-(require racket/unit
-         racket/contract
-         "url-structs.rkt"
-         "url-sig.rkt"
-         "url-unit.rkt"
-         "tcp-sig.rkt"
-         "tcp-unit.rkt")
+(require racket/unit racket/contract
+         "url-structs.rkt" "url-sig.rkt" "url-unit.rkt"
+         "tcp-sig.rkt")
+
+;; Define `tcp@' as a unit that uses void for `tcp-connect', which will
+;; make the url-unit code dispatch to either the built in tcp functions
+;; or the ssl functions.  (See the "HACK" comment there.)
+(require (except-in racket/tcp tcp-connect))
+(define tcp-connect (void))
+(define-unit-from-context tcp@ tcp^)
 
 (define-compound-unit/infer url+tcp@
   (import) (export url^)