openssl: add key and cert-chain args to ssl-make-{client,server}-context

pkgs/racket-doc/openssl/openssl.scrbl

@@ -161,13 +161,24 @@ essentially equivalent to the following:
 The context is cached, so different calls to
 @racket[ssl-secure-client-context] return the same context unless
 @racket[(ssl-default-verify-sources)] has changed.
+
+Note that @racket[(ssl-secure-client-context)] returns a sealed
+context, so it is not possible to add a private key and certificate
+chain to it. If client credentials are required, use
+@racket[ssl-make-client-context] instead.
 }
 
 
 @defproc[(ssl-make-client-context
           [protocol (or/c 'secure 'auto
                           'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)
-                    'auto])
+                    'auto]
+          [#:private-key private-key
+                         (or/c (list/c 'pem path-string?)
+                               (list/c 'der path-string?)
+                               #f)
+                         #f]
+          [#:certificate-chain certificate-chain (or/c path-string? #f) #f])
          ssl-client-context?]{
 
 Creates a context to be supplied to @racket[ssl-connect]. The context
@@ -208,11 +219,19 @@ details. See also
 @racket[supported-client-protocols] and
 @racket[supported-server-protocols].
 
+If @racket[private-key] and @racket[certificate-chain] are provided,
+they are loaded into the context using @racket[ssl-load-private-key!]
+and @racket[ssl-load-certificate-chain!], respectively. Client
+credentials are rarely used with HTTPS, but they are occasionally used
+in other kind of servers.
+
 @history[
 #:changed "6.1" @elem{Added @racket['tls11] and @racket['tls12].}
 #:changed "6.1.1.3" @elem{Default to new @racket['auto] and disabled SSL
                           2.0 and 3.0 by default.}
 #:changed "6.3.0.12" @elem{Added @racket['secure].}
+#:changed "7.3.0.10" @elem{Added @racket[#:private-key] and @racket[#:certificate-chain]
+arguments.}
 ]}
 
 
@@ -325,14 +344,28 @@ Returns @racket[#t] of @racket[v] is an SSL port produced by
 @defproc[(ssl-make-server-context
           [protocol (or/c 'secure 'auto
                           'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)
-                    'auto])
+                    'auto]
+          [#:private-key private-key
+                         (or/c (list/c 'pem path-string?)
+                               (list/c 'der path-string?)
+                               #f)
+                         #f]
+          [#:certificate-chain certificate-chain (or/c path-string? #f) #f])
          ssl-server-context?]{
 
 Like @racket[ssl-make-client-context], but creates a server context.
 For a server context, the @racket['secure] protocol is the same as
 @racket['auto].
 
-@history[#:changed "6.3.0.12" @elem{Added @racket['secure].}]}
+If @racket[private-key] and @racket[certificate-chain] are provided,
+they are loaded into the context using @racket[ssl-load-private-key!]
+and @racket[ssl-load-certificate-chain!], respectively.
+
+@history[
+#:changed "6.3.0.12" @elem{Added @racket['secure].}
+#:changed "7.3.0.10" @elem{Added @racket[#:private-key] and @racket[#:certificate-chain]
+arguments.}
+]}
 
 
 @defproc[(ssl-server-context? [v any/c]) boolean?]{

pkgs/racket-test/tests/openssl/peer-verif2.rkt

@@ -0,0 +1,120 @@
+#lang racket/base
+(require openssl
+         ffi/unsafe
+         racket/tcp
+         racket/runtime-path)
+
+(define (check fmt got expect)
+  (unless (equal? got expect)
+    (error 'check fmt got)))
+
+(define (check-fail thunk)
+  (define s
+    (with-handlers ([exn? (lambda (exn) (exn-message exn))])
+      (thunk)
+      "success"))
+  (unless (regexp-match?  #rx"connect failed" s)
+    (error 'test "failed: ~s" s)))
+
+(define-runtime-path server-key "server_key.pem")
+(define-runtime-path server-crt "server_crt.pem")
+(define-runtime-path client-key "client_key.pem")
+(define-runtime-path client-crt "client_crt.pem")
+(define-runtime-path cacert     "cacert.pem")
+
+(define server-hostname "server.example.com")
+(define client-id
+  #"/C=US/ST=Racketa/O=Testing Examples/OU=Testing/CN=client.example.com/emailAddress=client@example.com")
+
+(define (call/custodian proc)
+  (define cust (make-custodian))
+  (parameterize ((current-custodian cust))
+    (dynamic-wind void proc (lambda () (custodian-shutdown-all cust)))))
+
+;; test-conn : ServerCtx ClientCtx -> (U #f Bytes)
+(define (test-conn server-ctx client-ctx)
+  (call/custodian
+   (lambda ()
+     (define chan (make-channel))
+     (define listener (ssl-listen 55000 4 #t "localhost" server-ctx))
+     (thread (lambda ()
+               (ssl-try-verify! listener #t)
+               (define-values (in out) (ssl-accept listener))
+               (channel-put chan (and (ssl-peer-verified? in) (ssl-peer-subject-name in)))))
+     ;; Use ports->ssl-ports instead of ssl-connect so we can supply a fake hostname.
+     ;; (ssl-connect "localhost" 55000 client-ctx)
+     (define-values (in out) (tcp-connect "localhost" 55000))
+     (if (symbol? client-ctx)
+         (ports->ssl-ports in out #:mode 'connect #:encrypt client-ctx #:hostname server-hostname)
+         (ports->ssl-ports in out #:mode 'connect #:context client-ctx #:hostname server-hostname))
+     (channel-get chan))))
+
+(define server-ctx1
+  (ssl-make-server-context 'auto #:private-key `(pem ,server-key) #:certificate-chain server-crt))
+(define server-ctx2
+  (let ([ctx (ssl-make-server-context)])
+    (ssl-load-certificate-chain! ctx server-crt)
+    (ssl-load-private-key! ctx server-key #f #f)
+    ctx))
+;; Set 
+(parameterize ((ssl-default-verify-sources (list cacert)))
+  (ssl-load-default-verify-sources! server-ctx1)
+  (ssl-load-default-verify-sources! server-ctx2))
+
+(define client-ctx/standard-trust
+  (ssl-secure-client-context))
+(define client-ctx/no-trust
+  (parameterize ((ssl-default-verify-sources null))
+    (ssl-secure-client-context)))
+
+(define client-ctx/trust-ca1
+  (parameterize ((ssl-default-verify-sources (list cacert)))
+    (ssl-secure-client-context)))
+
+(define client-ctx/trust-ca2
+  (parameterize ((ssl-default-verify-sources (list cacert)))
+    (ssl-make-client-context 'secure)))
+
+(define client-ctx/auto/cred
+  (let ([ctx (ssl-make-client-context 'auto)])
+    (ssl-load-private-key! ctx client-key #f #f)
+    (ssl-load-certificate-chain! ctx client-crt)
+    ctx))
+
+(define client-ctx/trust-ca/cred
+  (parameterize ((ssl-default-verify-sources (list cacert)))
+    (ssl-make-client-context 'secure
+                             #:private-key `(pem ,client-key)
+                             #:certificate-chain client-crt)))
+
+(for ([server-ctx (list server-ctx1 server-ctx2)])
+
+  ;; Test that the client fails to verify the server (server's CA not trusted).
+  (for ([client-ctx (list client-ctx/standard-trust
+                          client-ctx/no-trust)])
+    (check-fail (lambda () (test-conn server-ctx client-ctx))))
+
+  ;; Test that the client verifies the server, and the server does not
+  ;; get a client identity (no key/cert loaded).
+  (for ([client-ctx (list client-ctx/trust-ca1
+                          client-ctx/trust-ca2)])
+    (check "connection w/o client creds; got ~e"
+           (test-conn server-ctx client-ctx)
+           #f))
+
+  ;; Test that the client verifies the server, and the server verify
+  ;; the client and gets the right client identity.
+  (for ([client-ctx (list client-ctx/auto/cred
+                          client-ctx/trust-ca/cred)])
+    (check "connection with client creds; got ~e"
+           (test-conn server-ctx client-ctx)
+           client-id))
+
+  ;; Test that an implicit 'secure client context does verification.
+  (parameterize ((ssl-default-verify-sources null))
+    (check-fail (lambda () (test-conn server-ctx 'secure))))
+  (parameterize ((ssl-default-verify-sources null))
+    (check-fail (lambda () (test-conn server-ctx 'secure))))
+  (parameterize ((ssl-default-verify-sources (list cacert)))
+    (check "implicit, got ~e" (test-conn server-ctx 'secure) #f))
+  (void))

racket/collects/openssl/mzssl.rkt

@@ -89,11 +89,19 @@ TO DO:
   [ssl-available? boolean?]
   [ssl-load-fail-reason (or/c #f string?)]
   [ssl-make-client-context
-   (->* () (protocol-symbol/c) ssl-client-context?)]
+   (->* ()
+        (protocol-symbol/c
+         #:private-key (or/c (list/c 'pem path-string?) (list/c 'der path-string?) #f)
+         #:certificate-chain (or/c path-string? #f))
+        ssl-client-context?)]
   [ssl-secure-client-context
    (c-> ssl-client-context?)]
   [ssl-make-server-context
-   (->* () (protocol-symbol/c) ssl-server-context?)]
+   (->* ()
+        (protocol-symbol/c
+         #:private-key (or/c (list/c 'pem path-string?) (list/c 'der path-string?) #f)
+         #:certificate-chain (or/c path-string? #f))
+        ssl-server-context?)]
   [ssl-server-context-enable-dhe!
    (->* (ssl-server-context?) (path-string?) void?)]
   [ssl-server-context-enable-ecdhe!
@@ -650,43 +658,56 @@ TO DO:
   (let ([protocols (supported-server-protocols)])
     (and (pair? protocols) (last protocols))))
 
-(define (make-context who protocol-symbol client?)
+(define (make-context who protocol-symbol client? priv-key cert-chain)
   (define ctx (make-raw-context who protocol-symbol client?))
-  ((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f))
+  (define mzctx ((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f))
+  (when cert-chain (ssl-load-certificate-chain! mzctx cert-chain))
+  (cond [(and (pair? priv-key) (eq? (car priv-key) 'pem))
+         (ssl-load-private-key! mzctx (cadr priv-key) #f #f)]
+        [(and (pair? priv-key) (eq? (car priv-key) 'der))
+         (ssl-load-private-key! mzctx (cadr priv-key) #f #t)]
+        [else (void)])
+  mzctx)
 
 (define (make-raw-context who protocol-symbol client?)
-  (cond
+  (define meth (encrypt->method who protocol-symbol client?))
-   [(and (eq? protocol-symbol 'secure)
+  (define ctx
-         client?)
+    (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error)
-    (ssl-context-ctx (ssl-secure-client-context))]
+     (let ([ctx (SSL_CTX_new meth)])
-   [else
+       (check-valid ctx who "context creation")
-    (define meth (encrypt->method who protocol-symbol client?))
+       ctx)))
-    (define ctx
+  (unless (memq protocol-symbol '(sslv2 sslv3))
-      (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error)
+    (SSL_CTX_set_options ctx (bitwise-ior SSL_OP_NO_SSLv2 SSL_OP_NO_SSLv3)))
-       (let ([ctx (SSL_CTX_new meth)])
+  (SSL_CTX_set_mode ctx (bitwise-ior SSL_MODE_ENABLE_PARTIAL_WRITE
-         (check-valid ctx who "context creation")
+                                     SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER))
-         ctx)))
+  ctx)
-    (unless (memq protocol-symbol '(sslv2 sslv3))
-      (SSL_CTX_set_options ctx (bitwise-ior SSL_OP_NO_SSLv2 SSL_OP_NO_SSLv3)))
-    (SSL_CTX_set_mode ctx (bitwise-ior SSL_MODE_ENABLE_PARTIAL_WRITE
-                                       SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER))
-    ctx]))
 
 (define (need-ctx-free? context-or-encrypt-method)
   (and (symbol? context-or-encrypt-method)
        (not (eq? context-or-encrypt-method 'secure))))
 
-(define (ssl-make-client-context [protocol-symbol default-encrypt])
+(define (ssl-make-client-context [protocol-symbol default-encrypt]
-  (make-context 'ssl-make-client-context protocol-symbol #t))
+                                 #:private-key [priv-key #f]
+                                 #:certificate-chain [cert-chain #f])
+  (cond [(and (eq? protocol-symbol 'secure) (not priv-key) (not cert-chain))
+         (ssl-secure-client-context)]
+        [else
+         (define ctx (make-context 'ssl-make-client-context protocol-symbol #t priv-key cert-chain))
+         (when (eq? protocol-symbol 'secure) (secure-client-context! ctx))
+         ctx]))
 
-(define (ssl-make-server-context [protocol-symbol default-encrypt])
+(define (ssl-make-server-context [protocol-symbol default-encrypt]
-  (make-context 'ssl-make-server-context protocol-symbol #f))
+                                 #:private-key [priv-key #f]
+                                 #:certificate-chain [cert-chain #f])
+  (make-context 'ssl-make-server-context protocol-symbol #f priv-key cert-chain))
 
 (define (get-context who context-or-encrypt-method client?
                      #:need-unsealed? [need-unsealed? #f])
   (if (ssl-context? context-or-encrypt-method)
       (extract-ctx who need-unsealed? context-or-encrypt-method)
-      (make-raw-context who context-or-encrypt-method client?)))
+      (if (and client? (eq? context-or-encrypt-method 'secure))
+          (ssl-context-ctx (ssl-secure-client-context))
+          (make-raw-context who context-or-encrypt-method client?))))
 
 (define (get-context/listener who ssl-context-or-listener [fail? #t]
                               #:need-unsealed? [need-unsealed? #f])
@@ -943,27 +964,28 @@ TO DO:
 
 ;; ----
 
-(define (ssl-make-secure-client-context sym)
+(define (secure-client-context! ctx)
-  (let ([ctx (ssl-make-client-context sym)])
+  ;; Load root certificates
-    ;; Load root certificates
+  (ssl-load-default-verify-sources! ctx)
-    (ssl-load-default-verify-sources! ctx)
+  ;; Require verification
-    ;; Require verification
+  (ssl-set-verify! ctx #t)
-    (ssl-set-verify! ctx #t)
+  (ssl-set-verify-hostname! ctx #t)
-    (ssl-set-verify-hostname! ctx #t)
+  ;; No weak cipher suites; see discussion, patch at http://bugs.python.org/issue13636
-    ;; No weak cipher suites; see discussion, patch at http://bugs.python.org/issue13636
+  (ssl-set-ciphers! ctx "DEFAULT:!aNULL:!eNULL:!LOW:!EXPORT:!SSLv2")
-    (ssl-set-ciphers! ctx "DEFAULT:!aNULL:!eNULL:!LOW:!EXPORT:!SSLv2")
+  ;; Seal context so further changes cannot weaken it
-    ;; Seal context so further changes cannot weaken it
+  (ssl-seal-context! ctx)
-    (ssl-seal-context! ctx)
+  (void))
-    ctx))
 
 ;; context-cache: (list (weak-box ssl-client-context) (listof path-string) nat) or #f
+;; Cache for (ssl-secure-client-context) and (ssl-make-client-context 'secure) (w/o key, cert).
 (define context-cache #f)
 
 (define (ssl-secure-client-context)
   (let ([locs (ssl-default-verify-sources)])
     (define (reset)
       (let* ([now (current-seconds)]
-             [ctx (ssl-make-secure-client-context default-encrypt)])
+             [ctx (ssl-make-client-context 'auto)])
+        (secure-client-context! ctx)
         (set! context-cache (list (make-weak-box ctx) locs now))
         ctx))
     (let* ([cached context-cache]
@@ -1654,7 +1676,7 @@ TO DO:
                     [protocol-symbol-or-context default-encrypt])
   (let* ([ctx (if (ssl-server-context? protocol-symbol-or-context)
                protocol-symbol-or-context
-               (make-context 'ssl-listen protocol-symbol-or-context #f))]
+               (make-context 'ssl-listen protocol-symbol-or-context #f #f #f))]
         [l (tcp-listen port-k queue-k reuse? hostname-or-#f)]
         [ssl-l (make-ssl-listener l ctx)])
     (register ssl-l ssl-l 'listener)))