load root certificates from windows system certificate store
Also, some recently added functions and parameters are renamed for
greater generality ("root-certificates" -> "verify sources").
This commit is contained in:
Ryan Culpepper
parent
97454b6e55
commit
7b0a13bf74
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
|
|
|
|||
93
collects/openssl/private/win32.rkt
Normal file
93
collects/openssl/private/win32.rkt
Normal file
|
|
@ -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)]))
|
||||
Loading…
Reference in New Issue
Block a user