upstream: github.com/mirage/ca-certs
Merge pull request #7 from hannesm/more
assorted fixes towards a release
authored by
Hannes Mehnert
and committed by
GitHub
a4167eae
add0cb2d
+130
-47
+13
-1
ca-certs.opam
+13
-1
ca-certs.opam
···
13
13
doc: "https://mirage.github.io/ca-certs/doc"
14
14
bug-reports: "https://github.com/mirage/ca-certs/issues"
15
15
depends: [
16
-
"dune" {>= "1.11"}
16
+
"dune" {>= "2.0"}
17
+
"bos"
18
+
"fpath"
19
+
"rresult"
20
+
"ptime"
21
+
"mirage-crypto"
22
+
"x509" {>= "0.11.0"}
23
+
"ocaml" {>= "4.07.0"}
24
+
"lwt" {with-test}
25
+
"tls" {with-test}
17
26
]
18
27
build: [
19
28
["dune" "subst"] {pinned}
···
31
40
]
32
41
dev-repo: "git+https://github.com/mirage/ca-certs.git"
33
42
tags: ["org:mirage"]
43
+
depexts: [
44
+
["ca_root_nss"] {os = "freebsd"}
45
+
]
+3
ca-certs.opam.template
+3
ca-certs.opam.template
+7
-2
dune-project
+7
-2
dune-project
···
1
-
(lang dune 1.11)
1
+
(lang dune 2.0)
2
2
(name ca-certs)
3
3
4
4
(generate_opam_files true)
···
10
10
11
11
(package
12
12
(name ca-certs)
13
-
(depends)
13
+
(depends
14
+
bos fpath rresult ptime mirage-crypto
15
+
(x509 (>= 0.11.0))
16
+
(ocaml (>= 4.07.0))
17
+
(lwt :with-test)
18
+
(tls :with-test))
14
19
(synopsis "Detect root CA certificates from the operating system")
15
20
(description
16
21
"\> TLS requires a set of root anchors (Certificate Authorities) to
+74
-9
lib/ca_certs.ml
+74
-9
lib/ca_certs.ml
···
1
-
let rec detect_list =
2
-
let open Lwt in
3
-
function
4
-
| [] -> return_none
5
-
| path :: paths ->
6
-
Lwt_unix.file_exists path >>= fun exists ->
7
-
if exists then return_some (`Ca_file path) else detect_list paths
1
+
let issue =
2
+
{|Please report an issue at https://github.com/mirage/ca-certs, including:
3
+
- the output of uname -s
4
+
- the distribution you use
5
+
- the location of default trust anchors (if known)
6
+
|}
8
7
9
-
let locations =
8
+
let detect_one path =
9
+
let path' = Fpath.v path in
10
+
match Bos.OS.Path.exists path' with
11
+
| Ok true -> Ok path'
12
+
| _ ->
13
+
Error
14
+
(`Msg
15
+
( "ca-certs: no trust anchor file found, looked into " ^ path ^ ".\n"
16
+
^ issue ))
17
+
18
+
let detect_list paths =
19
+
let rec one = function
20
+
| [] ->
21
+
Error
22
+
(`Msg
23
+
( "ca-certs: no trust anchor file found, looked into "
24
+
^ String.concat ", " paths ^ ".\n" ^ issue ))
25
+
| path :: paths -> (
26
+
match detect_one path with Ok path -> Ok path | Error _ -> one paths )
27
+
in
28
+
one paths
29
+
30
+
(* from https://golang.org/src/crypto/x509/root_linux.go *)
31
+
let linux_locations =
10
32
[
33
+
(* Debian/Ubuntu/Gentoo etc. *)
11
34
"/etc/ssl/certs/ca-certificates.crt";
35
+
(* CentOS/RHEL 7 *)
12
36
"/etc/pki/ca-trust/extracted/pem/tls-ca-bundle.pem";
37
+
(* OpenSUSE *)
38
+
"/etc/ssl/ca-bundle.pem";
13
39
]
14
40
15
-
let detect () = detect_list locations
41
+
(* from https://golang.org/src/crypto/x509/root_bsd.go *)
42
+
let openbsd_location = "/etc/ssl/cert.pem"
43
+
44
+
let freebsd_location = "/usr/local/share/certs/ca-root-nss.crt"
45
+
46
+
let macos_keychain_location =
47
+
"/System/Library/Keychains/SystemRootCertificates.keychain"
48
+
49
+
let ta_file_raw () =
50
+
let open Rresult.R.Infix in
51
+
if Sys.win32 then
52
+
Error (`Msg "ca-certs: windows is not supported at the moment")
53
+
else
54
+
let cmd = Bos.Cmd.(v "uname" % "-s") in
55
+
Bos.OS.Cmd.(run_out cmd |> out_string |> success) >>= function
56
+
| "FreeBSD" -> detect_one freebsd_location
57
+
| "OpenBSD" -> detect_one openbsd_location
58
+
| "Linux" -> detect_list linux_locations
59
+
| "Darwin" ->
60
+
let cmd =
61
+
Bos.Cmd.(
62
+
v "security" % "find-certificate" % "-a" % "-p"
63
+
% macos_keychain_location)
64
+
in
65
+
let tmpfile = Fpath.v (Filename.temp_file "cacert" "pem") in
66
+
Bos.OS.Cmd.(run_out cmd |> out_file tmpfile |> success) >>| fun () ->
67
+
tmpfile
68
+
| s -> Error (`Msg ("ca-certs: unknown system " ^ s ^ ".\n" ^ issue))
69
+
70
+
let trust_anchor_filename () =
71
+
let open Rresult.R.Infix in
72
+
ta_file_raw () >>| Fpath.to_string
73
+
74
+
let trust_anchor ?crls ?hash_whitelist () =
75
+
let open Rresult.R.Infix in
76
+
ta_file_raw () >>= fun file ->
77
+
Bos.OS.File.read file >>= fun data ->
78
+
X509.Certificate.decode_pem_multiple (Cstruct.of_string data) >>| fun cas ->
79
+
let time () = Some (Ptime_clock.now ()) in
80
+
X509.Authenticator.chain_of_trust ?crls ?hash_whitelist ~time cas
+10
-4
lib/ca_certs.mli
+10
-4
lib/ca_certs.mli
···
1
-
val detect : unit -> [> `Ca_file of Lwt_io.file_name ] option Lwt.t
2
-
(** Detect root CAs in the operating system's trust store.
3
-
Returns [None] if detection did not succeed. The variants correspond to the
4
-
ones used in [X509_lwt] in [ocaml-tls]. *)
1
+
val trust_anchor_filename : unit -> (string, [> `Msg of string ]) result
2
+
(** Attempts to discover the trust anchor file on this host system. *)
3
+
4
+
val trust_anchor :
5
+
?crls:X509.CRL.t list ->
6
+
?hash_whitelist:Mirage_crypto.Hash.hash list ->
7
+
unit ->
8
+
(X509.Authenticator.t, [> `Msg of string ]) result
9
+
(** Detects root CAs in the operating system's trust store.
10
+
Returns [Error `Msg msg] if detection did not succeed. *)
+1
-1
lib/dune
+1
-1
lib/dune
+3
-6
test/e2e/dune
+3
-6
test/e2e/dune
+2
-3
test/e2e/test_e2e.expected
+2
-3
test/e2e/test_e2e.expected
···
1
1
google.com -> Accepted
2
-
self-signed.badssl.com -> Authentication failure: invalid certificate chain
2
+
self-signed.badssl.com -> Authentication failure (invalid certificate chain)
3
3
expired.badssl.com -> Authentication failure (leaf: expired)
4
-
untrusted-root.badssl.com -> Authentication failure: invalid certificate chain
5
-
revoked.badssl.com -> Authentication failure (leaf: expired)
4
+
untrusted-root.badssl.com -> Authentication failure (invalid certificate chain)
6
5
extended-validation.badssl.com -> Accepted
+16
-21
test/e2e/test_e2e.ml
+16
-21
test/e2e/test_e2e.ml
···
4
4
| Authentication_failure of X509.Validation.validation_error
5
5
6
6
let pp_leaf_validation_error ppf = function
7
-
| `LeafCertificateExpired _ -> Format.fprintf ppf "expired"
8
-
| `LeafInvalidName _ -> Format.fprintf ppf "invalid name"
9
-
| `LeafInvalidVersion _ -> Format.fprintf ppf "invalid version"
10
-
| `LeafInvalidExtensions _ -> Format.fprintf ppf "invalid extensions"
7
+
| `LeafCertificateExpired _ -> Format.fprintf ppf "leaf: expired"
8
+
| `LeafInvalidName _ -> Format.fprintf ppf "leaf: invalid name"
9
+
| `LeafInvalidVersion _ -> Format.fprintf ppf "leaf: invalid version"
10
+
| `LeafInvalidExtensions _ -> Format.fprintf ppf "leaf: invalid extensions"
11
+
| e -> X509.Validation.pp_validation_error ppf e
11
12
12
13
let pp_result ppf = function
13
14
| Accepted -> Format.pp_print_string ppf "Accepted"
14
15
| Unknown_exception e ->
15
16
Format.fprintf ppf "Unknown_exception: %s" (Printexc.to_string e)
16
-
| Authentication_failure (`Leaf e) ->
17
-
Format.fprintf ppf "Authentication failure (leaf: %a)"
18
-
pp_leaf_validation_error e
19
17
| Authentication_failure e ->
20
-
Format.fprintf ppf "Authentication failure: %a"
21
-
X509.Validation.pp_validation_error e
22
-
23
-
let to_authenticator_param = function
24
-
| Some x -> x
25
-
| None ->
26
-
print_endline "defaulting to null auth";
27
-
`No_authentication_I'M_STUPID
18
+
Format.fprintf ppf "Authentication failure (%a)" pp_leaf_validation_error
19
+
e
28
20
29
21
let make_client () =
30
-
let open Lwt in
31
-
Ca_certs.detect () >>= fun r ->
32
-
to_authenticator_param r |> X509_lwt.authenticator >|= fun authenticator ->
22
+
let authenticator =
23
+
match Ca_certs.trust_anchor () with
24
+
| Ok ta -> ta
25
+
| Error (`Msg m) ->
26
+
print_endline ("no ca certificates found: " ^ m);
27
+
fun ~host:_ _ -> Error `InvalidChain
28
+
in
33
29
Tls.Config.client ~authenticator ()
34
30
35
31
let connect client host =
···
49
45
Format.printf "%s -> %a\n" host pp_result result
50
46
51
47
let main () =
52
-
let open Lwt in
53
-
make_client () >>= fun client ->
48
+
let client = make_client () in
54
49
Lwt_list.iter_s (test client)
55
50
[
56
51
"google.com";
57
52
"self-signed.badssl.com";
58
53
"expired.badssl.com";
59
54
"untrusted-root.badssl.com";
60
-
"revoked.badssl.com";
55
+
(* "revoked.badssl.com"; *)
61
56
"extended-validation.badssl.com";
62
57
]
63
58