From ba62b1dd5748d194e6f1b783b8d6d26994070c6f Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 20 Nov 2012 12:42:23 -0500
Subject: [PATCH] added ssl-secure-client-connection

---
 collects/openssl/mzssl.rkt     | 41 +++++++++++++++++++++++++++++++++-
 collects/openssl/openssl.scrbl | 12 ++++++++++
 2 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt
index 03647419d5..4ccb941705 100644
--- a/collects/openssl/mzssl.rkt
+++ b/collects/openssl/mzssl.rkt
@@ -29,6 +29,7 @@
 	   ssl-load-fail-reason
 
 	   ssl-make-client-context
+           ssl-secure-client-context
 	   ssl-make-server-context
 	   ssl-client-context?
 	   ssl-server-context?
@@ -634,7 +635,45 @@
                              SSL_ST_ACCEPT)
       (check-err (lambda () (SSL_do_handshake (mzssl-ssl mzssl))))))
 
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; ----
+
+  (define (ssl-make-secure-client-context sym)
+    (let ([ctx (ssl-make-client-context sym)])
+      ;; Load root certificates
+      (ssl-load-default-verify-root-certificates! ctx)
+      ;; Require verification
+      (ssl-set-verify! ctx #t)
+      (ssl-set-verify-hostname! ctx #t)
+      ;; No weak cipher suites; see discussion, patch at http://bugs.python.org/issue13636
+      (ssl-set-ciphers! ctx "DEFAULT:!aNULL:!eNULL:!LOW:!EXPORT:!SSLv2")
+      ;; Seal context so further changes cannot weaken it
+      (ssl-seal-context! ctx)
+      ctx))
+
+  ;; context-cache: (list (weak-box ssl-client-context) (listof path-string) nat) or #f
+  (define context-cache #f)
+
+  (define (ssl-secure-client-context)
+    (let ([locs (ssl-default-root-certificate-locations)])
+      (define (reset)
+        (let* ([now (current-seconds)]
+               [ctx (ssl-make-secure-client-context 'tls)])
+          (set! context-cache (list (make-weak-box ctx) locs now))
+          ctx))
+      (let* ([cached context-cache]
+             [c-wb (and cached (car cached))]
+             [c-ctx (and c-wb (weak-box-value c-wb))]
+             [c-locs (and cached (cadr cached))]
+             [c-time (and cached (caddr cached))])
+        (cond [c-ctx
+               ;; May reuse only if locations haven't changed
+               ;; FIXME: ideally, should also check that no file in locs has changed since
+               ;;   c-time, but don't want to hit the filesystem so often
+               (cond [(equal? locs c-locs) c-ctx]
+                     [else (reset)])]
+              [else (reset)]))))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; SSL ports
 
   (define (mzssl-release mzssl)
diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl
index 70756ded5c..c2515c6fbb 100644
--- a/collects/openssl/openssl.scrbl
+++ b/collects/openssl/openssl.scrbl
@@ -157,6 +157,18 @@ request verification of a server's certificate. Use @racket[ssl-set-verify!]
 to enable such verification.}
 
 
+@defproc[(ssl-secure-client-context)
+         ssl-client-context?]{
+
+Returns a client context (using @racket['tls]) that verifies
+certificates using the root certificates located in
+@racket[(ssl-default-root-certificate-locations)], verifies hostnames,
+and avoids using weak ciphers. The context is sealed to prevent
+further modification, and the context is cached, so different calls to
+@racket[ssl-secure-client-context] return the same context unless
+@racket[(ssl-default-root-certificate-locations)] has changed.
+}
+
 @defproc[(ssl-client-context? (v any/c)) boolean?]{
 
 Returns @racket[#t] if @racket[v] is a value produced by