From 7b0a13bf743c5dff3c2eba5e0839d03c46de9ded Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 23 Nov 2012 01:25:14 -0500 Subject: [PATCH] load root certificates from windows system certificate store Also, some recently added functions and parameters are renamed for greater generality ("root-certificates" -> "verify sources"). --- collects/openssl/mzssl.rkt | 130 +++++++++++++++++------------ collects/openssl/openssl.scrbl | 101 +++++++++++++++------- collects/openssl/private/win32.rkt | 93 +++++++++++++++++++++ 3 files changed, 243 insertions(+), 81 deletions(-) create mode 100644 collects/openssl/private/win32.rkt diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt index a3d59eee8a..c9044c6b77 100644 --- a/collects/openssl/mzssl.rkt +++ b/collects/openssl/mzssl.rkt @@ -23,8 +23,11 @@ racket/port racket/tcp racket/string + unstable/lazy-require "libcrypto.rkt" "libssl.rkt") + (lazy-require + ["private/win32.rkt" (load-win32-root-certificates)]) (provide ssl-available? ssl-load-fail-reason @@ -39,12 +42,13 @@ ssl-load-certificate-chain! ssl-load-private-key! ssl-load-verify-root-certificates! + ssl-load-verify-source! ssl-load-suggested-certificate-authorities! ssl-set-ciphers! ssl-seal-context! - ssl-default-root-certificate-locations - ssl-load-default-verify-root-certificates! + ssl-default-verify-sources + ssl-load-default-verify-sources! ssl-set-verify! ssl-try-verify! @@ -189,33 +193,36 @@ (define-crypto X509_get_default_cert_dir_env (_fun -> _string)) (define-crypto X509_get_default_cert_file_env (_fun -> _string)) - (define (get-x509-default get-env get-path) - (case (system-type) - ((windows) - ;; On Windows, SSLeay produces paths like "/usr/local/ssl/certs", which - ;; aren't useful. So just skip them. - #f) - (else - (and libcrypto - (let ([result (or (getenv (get-env)) (get-path))]) - (with-handlers ([exn:fail? (lambda (e) #f)]) - (string->path result))))))) + (define (x509-root-sources) + (define (dir-sep) + (case (system-type) + [(windows) ";"] + [else ":"])) + (define (get-paths get-env get-path dir? split?) + (cond [libcrypto + (let* ([result (or (getenv (get-env)) (get-path))] + [results (if split? + (string-split result (dir-sep)) + (list result))]) + (if dir? + (map (lambda (p) (list 'directory p)) results) + results))] + [else null])) + (append (get-paths X509_get_default_cert_file_env X509_get_default_cert_file #f #f) + (get-paths X509_get_default_cert_dir_env X509_get_default_cert_dir #t #t))) - (define ssl-default-root-certificate-locations + (define ssl-default-verify-sources (make-parameter - (filter values - ;; FIXME: openssl treats dir as dir-list w/ platform-specific separator - ;; (see /crypto/x509/by_dir.c) - (list (get-x509-default X509_get_default_cert_dir_env X509_get_default_cert_dir) - (get-x509-default X509_get_default_cert_file_env X509_get_default_cert_file))) - (lambda (v) - (define (bad) - (raise-argument-error 'ssl-default-root-certificate-locations - "(listof path-string?)" - v)) - (unless (list? v) (bad)) - (for ([entry (in-list v)]) (unless (or (eq? v #f) (path-string? v)) (bad))) - v))) + (case (system-type) + [(windows) + ;; On Windows, x509-root-sources produces paths like "/usr/local/ssl/certs", which + ;; aren't useful. So just skip them. + '((win32-store "ROOT"))] + [(macosx) + ;; FIXME: load from keyring + (x509-root-sources)] + [else + (x509-root-sources)]))) (define X509_V_OK 0) @@ -438,9 +445,9 @@ mzctx)) (set-ssl-context-sealed?! mzctx #t)) - (define (ssl-load-... who load-it ssl-context-or-listener pathname) - (let ([ctx (get-context/listener 'ssl-load-certificate-chain! - ssl-context-or-listener + (define (ssl-load-... who load-it ssl-context-or-listener pathname + #:try? [try? #f]) + (let ([ctx (get-context/listener who ssl-context-or-listener #:need-unsealed? #t)]) (unless (path-string? pathname) (raise-argument-error 'ssl-load-certificate-chain! @@ -453,7 +460,7 @@ (let ([path (path->bytes path)]) (atomically ;; for to connect ERR_get_error to `load-it' (let ([n (load-it ctx path)]) - (unless (= n 1) + (unless (or (= n 1) try?) (error who "load failed from: ~e ~a" pathname (get-error-message (ERR_get_error)))))))))) @@ -463,25 +470,6 @@ SSL_CTX_use_certificate_chain_file ssl-context-or-listener pathname)) - (define (ssl-load-verify-root-certificates! ssl-context-or-listener pathname) - (ssl-load-... 'ssl-load-verify-root-certificates! - (lambda (a b) - (cond [(directory-exists? pathname) - (SSL_CTX_load_verify_locations a #f b)] - [(file-exists? pathname) - (SSL_CTX_load_verify_locations a b #f)] - [else - (error 'ssl-load-verify-root-certificates! - "file or directory does not exist")])) - ssl-context-or-listener pathname)) - - (define (ssl-load-default-verify-root-certificates! ctx) - (let ([cert-locs (ssl-default-root-certificate-locations)]) - (for ([cert-loc (in-list cert-locs)]) - (cond [(or (file-exists? cert-loc) (directory-exists? cert-loc)) - (ssl-load-verify-root-certificates! ctx cert-loc)] - [else (void)])))) - (define (ssl-load-suggested-certificate-authorities! ssl-listener pathname) (ssl-load-... 'ssl-load-suggested-certificate-authorities! (lambda (ctx path) @@ -503,6 +491,44 @@ (if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM))) ssl-context-or-listener pathname)) + (define (ssl-load-verify-root-certificates! scl src) + (ssl-load-... 'ssl-load-verify-root-certificates! + (lambda (a b) (SSL_CTX_load_verify_locations a b #f)) + scl src)) + + (define (ssl-load-verify-source! context src #:try? [try? #f]) + (define (bad-source) + (error 'ssl-load-verify-root-certificates! + "bad source: ~e" src)) + (unless (ssl-context? context) + (raise-argument-error 'ssl-load-verify-source! + "(or/c ssl-client-context? ssl-server-context?)" + context)) + (cond [(path-string? src) + (ssl-load-... 'ssl-load-verify-root-certificates! + (lambda (a b) (SSL_CTX_load_verify_locations a b #f)) + context src #:try? try?)] + [(and (list? src) (= (length src) 2)) + (let ([tag (car src)] + [val (cadr src)]) + (case tag + [(directory) + (ssl-load-... 'ssl-load-verify-root-certificates! + (lambda (a b) (SSL_CTX_load_verify_locations a #f b)) + context val #:try? try?)] + [(win32-store) + (let ([ctx (get-context/listener 'ssl-load-verify-root-certificates! context + #:need-unsealed? #t)]) + (unless (path-string? val) (bad-source)) + (load-win32-root-certificates 'ssl-load-verify-root-certificates! + ctx val try?))] + [else (bad-source)]))] + [else (bad-source)])) + + (define (ssl-load-default-verify-sources! ctx) + (for ([src (in-list (ssl-default-verify-sources))]) + (ssl-load-verify-source! ctx src #:try? #t))) + (define (ssl-set-ciphers! context cipher-spec) (unless (ssl-context? context) (raise-argument-error 'ssl-set-ciphers! @@ -604,7 +630,7 @@ (define (ssl-make-secure-client-context sym) (let ([ctx (ssl-make-client-context sym)]) ;; Load root certificates - (ssl-load-default-verify-root-certificates! ctx) + (ssl-load-default-verify-sources! ctx) ;; Require verification (ssl-set-verify! ctx #t) (ssl-set-verify-hostname! ctx #t) @@ -618,7 +644,7 @@ (define context-cache #f) (define (ssl-secure-client-context) - (let ([locs (ssl-default-root-certificate-locations)]) + (let ([locs (ssl-default-verify-sources)]) (define (reset) (let* ([now (current-seconds)] [ctx (ssl-make-secure-client-context 'tls)]) diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl index c2515c6fbb..656fc6d2af 100644 --- a/collects/openssl/openssl.scrbl +++ b/collects/openssl/openssl.scrbl @@ -161,12 +161,12 @@ to enable such verification.} 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 +certificates using the root certificates from +@racket[(ssl-default-verify-sources)], 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. +@racket[(ssl-default-verify-sources)] has changed. } @defproc[(ssl-client-context? (v any/c)) boolean?]{ @@ -372,46 +372,89 @@ You can use the file @filepath{test.pem} of the @filepath{openssl} collection for testing purposes. Since @filepath{test.pem} is public, such a test configuration obviously provides no security.} -@defproc[(ssl-load-verify-root-certificates! - (context-or-listener (or/c ssl-client-context? ssl-server-context? - ssl-listener?)) - (pathname path-string?)) +@defproc[(ssl-load-verify-source! + [context (or/c ssl-client-context? ssl-server-context?)] + [src (or/c path-string? + (list/c 'directory path-string?) + (list/c 'win32-store string?))] + [#:try? try? any/c #f]) void?]{ -Loads a PEM-format file containing trusted certificates that are used -to verify the certificates of a connection peer. Call this procedure -multiple times to load multiple sets of trusted certificates. +Loads verification sources from @racket[src] into +@racket[context]. Currently, only root certificates are loaded; the +certificates are used to verify the certificates of a connection +peer. Call this procedure multiple times to load multiple sets of +trusted certificates. -If @racket[pathname] is a file, its contents are immediately -loaded. If @racket[pathname] is a directory, it should contain hashed -certificates names (see the @tt{openssl c_rehash} utility); the -directory is searched only when a certificate needs verification. +The following kinds of verification sources are supported: + +@itemlist[ + +@item{If @racket[src] is a path or string, it is treated as a PEM file +containing root certificates. The file is loaded immediately.} + +@item{If @racket[src] is @racket[(list 'directory _dir)], then +@racket[_dir] should contain PEM files with hashed symbolic links (see +the @tt{openssl c_rehash} utility). The directory contents are not +loaded immediately; rather, they are searched only when a certificate +needs verification.} + +@item{If @racket[src] is @racket[(list 'win32-store _store)], then the +certificates from the store named @racket[_store] are loaded +immediately. Only supported on Windows.} + +] + +If @racket[try?] is @racket[#f] and loading @racket[src] fails (for +example, because the file or directory does not exist), then an +exception is raised. If @racket[try?] is a true value, then a load +failure is ignored. You can use the file @filepath{test.pem} of the @filepath{openssl} collection for testing purposes. Since @filepath{test.pem} is public, such a test configuration obviously provides no security. } -@defparam[ssl-default-root-certificate-locations paths - (listof path-string?)]{ +@defparam[ssl-default-verify-sources srcs + (let ([source/c (or/c path-string? + (list/c 'directory path-string?) + (list/c 'win32-store string?))]) + (listof source/c))]{ -Holds a list of paths of root certificate authority certificates, used -by @racket[ssl-load-default-verify-root-certificates!]. The list of -paths may refer to both files and directories, and nonexistent paths -are allowed. +Holds a list of verification sources, used by +@racket[ssl-load-default-verify-sources!]. The default sources depend +on the platform: -The initial values are determined by the @tt{SSL_CERT_FILE} and -@tt{SSL_CERT_DIR} environment variables, if the variables are set, or -the system-wide default locations otherwise. +@itemlist[ + +@item{On Mac OS X and Linux, the default sources are determined by the +@tt{SSL_CERT_FILE} and @tt{SSL_CERT_DIR} environment variables, if the +variables are set, or the system-wide default locations otherwise.} + +@item{On Windows, the default source is @racket['(win32-store +"ROOT")], the system certificate store for root certificates.} + +] } -@defproc[(ssl-load-default-verify-root-certificates! +@defproc[(ssl-load-default-verify-sources! [context (or/c ssl-client-context? ssl-server-context?)]) void?]{ -Loads the default root certificates, as determined by the -@racket[ssl-default-root-certificate-locations] parameter, into -@racket[context]. Nonexistent paths are skipped. +Loads the default verification sources, as determined by +@racket[(ssl-default-verify-sources)], into @racket[context]. Load +failures are ignored, since some default sources may refer to +nonexistent paths. +} + +@defproc[(ssl-load-verify-root-certificates! + [context-or-listener (or/c ssl-client-conntext? ssl-server-context? + ssl-listener?)] + [pathname path-string?]) + void?]{ + +Deprecated; like @racket[ssl-load-verify-source!], but only supports +loading certificate files in PEM format. } @defproc[(ssl-load-suggested-certificate-authorities! diff --git a/collects/openssl/private/win32.rkt b/collects/openssl/private/win32.rkt new file mode 100644 index 0000000000..c08e6d4351 --- /dev/null +++ b/collects/openssl/private/win32.rkt @@ -0,0 +1,93 @@ +;; Support for loading root cerficates from Windows certificate store. + +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + "../libssl.rkt" + "../libcrypto.rkt") +(provide load-win32-root-certificates) + +;; -- libcrypto +(define-ffi-definer define-crypto libcrypto) +(define-cpointer-type _X509*) +(define-cpointer-type _X509_STORE*) + +;; FIXME: refcounting? +(define-crypto d2i_X509 + (_fun (buf) :: + (_pointer = #f) + ((_ptr i _pointer) = buf) + (_int32 = (bytes-length buf)) + -> _X509*)) + +(define-crypto X509_STORE_add_cert + (_fun _X509_STORE* _X509* -> _int)) + +;; -- libssl + +(define-ffi-definer define-ssl libssl) +(define _SSL_CTX* _pointer) + +(define-ssl SSL_CTX_get_cert_store + (_fun _SSL_CTX* -> _X509_STORE*)) + +;; -- Windows CryptoAPI + +(define crypt-lib (ffi-lib "crypt32.dll")) +(define-ffi-definer define-crypt crypt-lib + #:default-make-fail make-not-available) + +(define _DWORD _int32) +(define-cpointer-type _CERTSTORE) +(define-cstruct _sCERT_CONTEXT + ([certEncodingType _int32] + [certEncoded _pointer] + [certEncodedLen _int32] + [certInfo _pointer] + [certStore _pointer])) +(define-cpointer-type _CERT_CONTEXT _sCERT_CONTEXT-pointer) + +(define-syntax-rule (_wfun . parts) (_fun #:abi 'stdcall . parts)) + +(define-crypt CertCloseStore + (_wfun _CERTSTORE (_DWORD = 0) -> _int) + #:wrap (deallocator)) +(define-crypt CertOpenSystemStoreW + (_wfun (_pointer = #f) _string/utf-16 -> _CERTSTORE/null) + #:wrap (allocator CertCloseStore)) +(define-crypt CertEnumCertificatesInStore + (_wfun _CERTSTORE _CERT_CONTEXT/null + -> _CERT_CONTEXT/null)) + +(define (CERT_CONTEXT->X509 c) + (let* ([len (sCERT_CONTEXT-certEncodedLen c)] + [data (sCERT_CONTEXT-certEncoded c)] + [buf (make-bytes len)]) + (memcpy buf data len) + (d2i_X509 buf))) + +;; FIXME: also load CRLs? + +(define (load-win32-root-certificates who ssl-ctx storename try?) + (define cstore (CertOpenSystemStoreW storename)) + (cond [cstore + (define xstore (SSL_CTX_get_cert_store ssl-ctx)) + (let loop ([curr-c #f]) + (define c (CertEnumCertificatesInStore cstore curr-c)) + (when c + (let ([x509 (CERT_CONTEXT->X509 c)]) + (cond [x509 + ;; FIXME: check result for errors + (X509_STORE_add_cert xstore x509)] + [try? (void)] + [else + (CertCloseStore cstore) + (error who "retrieved invalid certificate from store: ~e" storename)]) + (loop c)))) + (CertCloseStore cstore) + (void)] + [try? (void)] + [else + ;; FIXME: get error using GetLastError (atomically) + (error who "failed to open certificate store: ~e" storename)]))