From 65e2d802ddc1e908e6a12d7a1acddb21fbcb5897 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 25 Jun 2019 18:14:25 +0200 Subject: [PATCH] openssl: add key and cert-chain args to ssl-make-{client,server}-context --- pkgs/racket-doc/openssl/openssl.scrbl | 39 +++++- .../racket-test/tests/openssl/peer-verif2.rkt | 120 ++++++++++++++++++ racket/collects/openssl/mzssl.rkt | 100 +++++++++------ 3 files changed, 217 insertions(+), 42 deletions(-) create mode 100644 pkgs/racket-test/tests/openssl/peer-verif2.rkt diff --git a/pkgs/racket-doc/openssl/openssl.scrbl b/pkgs/racket-doc/openssl/openssl.scrbl index e8b3c31186..f363a98a51 100644 --- a/pkgs/racket-doc/openssl/openssl.scrbl +++ b/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?]{ diff --git a/pkgs/racket-test/tests/openssl/peer-verif2.rkt b/pkgs/racket-test/tests/openssl/peer-verif2.rkt new file mode 100644 index 0000000000..b340b9cd88 --- /dev/null +++ b/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)) diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index 3781860a32..e9700a0403 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/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 - [(and (eq? protocol-symbol 'secure) - client?) - (ssl-context-ctx (ssl-secure-client-context))] - [else - (define meth (encrypt->method who protocol-symbol client?)) - (define ctx - (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error) - (let ([ctx (SSL_CTX_new meth)]) - (check-valid ctx who "context creation") - 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 meth (encrypt->method who protocol-symbol client?)) + (define ctx + (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error) + (let ([ctx (SSL_CTX_new meth)]) + (check-valid ctx who "context creation") + 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]) - (make-context 'ssl-make-client-context protocol-symbol #t)) +(define (ssl-make-client-context [protocol-symbol default-encrypt] + #: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]) - (make-context 'ssl-make-server-context protocol-symbol #f)) +(define (ssl-make-server-context [protocol-symbol default-encrypt] + #: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) - (let ([ctx (ssl-make-client-context sym)]) - ;; Load root certificates - (ssl-load-default-verify-sources! 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)) +(define (secure-client-context! ctx) + ;; Load root certificates + (ssl-load-default-verify-sources! 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) + (void)) ;; 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)))