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

@@ -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-default-verify-sources
-           ssl-load-default-verify-root-certificates!
+           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)
+  (define (x509-root-sources)
-    (case (system-type)
+    (define (dir-sep)
-      ((windows)
+      (case (system-type)
-       ;; On Windows, SSLeay produces paths like "/usr/local/ssl/certs", which
+        [(windows) ";"]
-       ;; aren't useful. So just skip them.
+        [else ":"]))
-       #f)
+    (define (get-paths get-env get-path dir? split?)
-      (else
+      (cond [libcrypto
-       (and libcrypto
+             (let* ([result (or (getenv (get-env)) (get-path))]
-            (let ([result (or (getenv (get-env)) (get-path))])
+                    [results (if split?
-              (with-handlers ([exn:fail? (lambda (e) #f)])
+                                 (string-split result (dir-sep))
-                (string->path result)))))))
+                                 (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
+     (case (system-type)
-             ;; FIXME: openssl treats dir as dir-list w/ platform-specific separator
+       [(windows)
-             ;;  (see /crypto/x509/by_dir.c)
+        ;; On Windows, x509-root-sources produces paths like "/usr/local/ssl/certs", which
-             (list (get-x509-default X509_get_default_cert_dir_env X509_get_default_cert_dir)
+        ;; aren't useful. So just skip them.
-                   (get-x509-default X509_get_default_cert_file_env X509_get_default_cert_file)))
+        '((win32-store "ROOT"))]
-     (lambda (v)
+       [(macosx)
-       (define (bad)
+        ;; FIXME: load from keyring
-         (raise-argument-error 'ssl-default-root-certificate-locations
+        (x509-root-sources)]
-                               "(listof path-string?)"
+       [else
-                               v))
+        (x509-root-sources)])))
-       (unless (list? v) (bad))
-       (for ([entry (in-list v)]) (unless (or (eq? v #f) (path-string? v)) (bad)))
-       v)))
 
   (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)
+  (define (ssl-load-... who load-it ssl-context-or-listener pathname
-    (let ([ctx (get-context/listener 'ssl-load-certificate-chain!
+                        #:try? [try? #f])
-				     ssl-context-or-listener
+    (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)])

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
+certificates using the root certificates from
-@racket[(ssl-default-root-certificate-locations)], verifies hostnames,
+@racket[(ssl-default-verify-sources)], verifies hostnames, and
-and avoids using weak ciphers. The context is sealed to prevent
+avoids using weak ciphers. The context is sealed to prevent further
-further modification, and the context is cached, so different calls to
+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!
+@defproc[(ssl-load-verify-source!
-	  (context-or-listener (or/c ssl-client-context? ssl-server-context?
+	    [context (or/c ssl-client-context? ssl-server-context?)]
-				      ssl-listener?))
+            [src (or/c path-string?
-	  (pathname 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
+Loads verification sources from @racket[src] into
-to verify the certificates of a connection peer. Call this procedure
+@racket[context]. Currently, only root certificates are loaded; the
-multiple times to load multiple sets of trusted certificates.
+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
+The following kinds of verification sources are supported:
-loaded. If @racket[pathname] is a directory, it should contain hashed
+
-certificates names (see the @tt{openssl c_rehash} utility); the
+@itemlist[
-directory is searched only when a certificate needs verification.
+
+@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
+@defparam[ssl-default-verify-sources srcs
-          (listof path-string?)]{
+          (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
+Holds a list of verification sources, used by
-by @racket[ssl-load-default-verify-root-certificates!]. The list of
+@racket[ssl-load-default-verify-sources!]. The default sources depend
-paths may refer to both files and directories, and nonexistent paths
+on the platform:
-are allowed.
 
-The initial values are determined by the @tt{SSL_CERT_FILE} and
+@itemlist[
-@tt{SSL_CERT_DIR} environment variables, if the variables are set, or
+
-the system-wide default locations otherwise.
+@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
+Loads the default verification sources, as determined by
-@racket[ssl-default-root-certificate-locations] parameter, into
+@racket[(ssl-default-verify-sources)], into @racket[context]. Load
-@racket[context]. Nonexistent paths are skipped.
+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!

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)]))