Merge pull request #14 from emillon/windows

Windows support

lib/ca_certs.ml

@@ -50,10 +50,36 @@ let freebsd_location = "/usr/local/share/certs/ca-root-nss.crt"
 let macos_keychain_location =
   "/System/Library/Keychains/SystemRootCertificates.keychain"
 
+external iter_on_anchors : (string -> unit) -> unit = "ca_certs_iter_on_anchors"
+
+let get_anchors () =
+  let der_list = ref [] in
+  match
+    iter_on_anchors (fun der_cert ->
+        der_list := Cstruct.of_string der_cert :: !der_list)
+  with
+  | () -> Ok !der_list
+  | exception Failure msg -> Rresult.R.error_msg msg
+
+let rec map_m f l =
+  match l with
+  | [] -> Ok []
+  | x :: xs ->
+      let open Rresult.R in
+      f x >>= fun y ->
+      map_m f xs >>| fun ys -> y :: ys
+
+(** Load certificates from Windows' ["ROOT"] system certificate store.
+    The C API returns a list of DER-encoded certificates. These are decoded and
+    reencoded as a single PEM certificate. *)
+let windows_trust_anchors () =
+  let open Rresult.R in
+  get_anchors () >>= map_m X509.Certificate.decode_der >>| fun cert_list ->
+  X509.Certificate.encode_pem_multiple cert_list |> Cstruct.to_string
+
 let trust_anchors () =
   let open Rresult.R.Infix in
-  if Sys.win32 then
-    Error (`Msg "ca-certs: windows is not supported at the moment")
+  if Sys.win32 then windows_trust_anchors ()
   else
     let cmd = Bos.Cmd.(v "uname" % "-s") in
     Bos.OS.Cmd.(run_out cmd |> out_string |> success) >>= function

lib/ca_certs_stubs.c

@@ -0,0 +1,49 @@
+#include "caml/alloc.h"
+#include "caml/callback.h"
+#include "caml/fail.h"
+#include "caml/memory.h"
+
+#ifdef _WIN32
+
+#include <windows.h>
+
+value ca_certs_iter_on_anchors(value v_f)
+{
+    CAMLparam1(v_f);
+    CAMLlocal1(v_encoded_cert);
+
+    HCERTSTORE hCertStore = CertOpenSystemStore(0, "ROOT");
+    if (!hCertStore)
+    {
+        caml_failwith("ca_certs_iter_on_anchors: CertOpenSystemStore returned NULL");
+    }
+
+    PCCERT_CONTEXT pCertContext = NULL;
+    while ((pCertContext = CertEnumCertificatesInStore(hCertStore, pCertContext)) != NULL)
+    {
+        if (!(pCertContext->dwCertEncodingType & X509_ASN_ENCODING))
+        {
+            caml_failwith("ca_certs_iter_on_anchors: certificate does not have expected encoding");
+        }
+        v_encoded_cert = caml_alloc_initialized_string(
+            pCertContext->cbCertEncoded,
+            pCertContext->pbCertEncoded);
+        caml_callback(v_f, v_encoded_cert);
+    }
+
+    if (!CertCloseStore(hCertStore, 0))
+    {
+        caml_failwith("ca_certs_iter_on_anchors: CertCloseStore returned an error");
+    }
+
+    CAMLreturn(Val_unit);
+}
+
+#else
+
+value ca_certs_iter_on_anchors(value v_unit)
+{
+    caml_failwith("ca_certs_iter_on_anchors: only implemented on Windows");
+}
+
+#endif

lib/dune

@@ -1,4 +1,27 @@
 (library
  (name ca_certs)
  (public_name ca-certs)
- (libraries mirage-crypto x509 astring bos rresult fpath logs ptime.clock.os))
+ (libraries mirage-crypto x509 astring bos rresult fpath logs ptime.clock.os)
+ (foreign_stubs
+  (language c)
+  (names ca_certs_stubs))
+ (c_library_flags
+  (:include flags.sexp)))
+
+(rule
+ (target flags.sexp)
+ (enabled_if
+  (= %{os_type} Win32))
+ (action
+  (with-stdout-to
+   %{target}
+   (echo "(:standard -lcrypt32)"))))
+
+(rule
+ (target flags.sexp)
+ (enabled_if
+  (<> %{os_type} Win32))
+ (action
+  (with-stdout-to
+   %{target}
+   (echo :standard))))