Source file x509_lwt.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
open Lwt
type priv = X509.Certificate.t list * Mirage_crypto_pk.Rsa.priv
type authenticator = X509.Authenticator.t
let failure msg = fail @@ Failure msg
let catch_invalid_arg th h =
Lwt.catch (fun () -> th)
(function
| Invalid_argument msg -> h msg
| exn -> fail exn)
let (</>) a b = a ^ "/" ^ b
let o f g x = f (g x)
let read_file path =
let open Lwt_io in
open_file ~mode:Input path >>= fun file ->
read file >|= Cstruct.of_string >>= fun cs ->
close file >|= fun () ->
cs
let read_dir path =
let open Lwt_unix in
let rec collect acc d =
readdir_n d 10 >>= function
| [||] -> return acc
| xs -> collect (Array.to_list xs @ acc) d in
opendir path >>= fun dir ->
collect [] dir >>= fun entries ->
closedir dir >|= fun () ->
entries
let extension str =
let n = String.length str in
let rec scan = function
| i when i = 0 -> None
| i when str.[i - 1] = '.' ->
Some (String.sub str i (n - i))
| i -> scan (pred i) in
scan n
let private_of_pems ~cert ~priv_key =
catch_invalid_arg
(read_file cert >|= fun pem ->
match X509.Certificate.decode_pem_multiple pem with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m))
(o failure @@ Printf.sprintf "Private certificates (%s): %s" cert) >>= fun certs ->
catch_invalid_arg
(read_file priv_key >|= fun pem ->
match X509.Private_key.decode_pem pem with
| Ok (`RSA key) -> key
| Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m))
(o failure @@ Printf.sprintf "Private key (%s): %s" priv_key) >>= fun pk ->
return (certs, pk)
let certs_of_pem path =
catch_invalid_arg
(read_file path >|= fun pem ->
match X509.Certificate.decode_pem_multiple pem with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m))
(o failure @@ Printf.sprintf "Certificates in %s: %s" path)
let certs_of_pem_dir path =
read_dir path
>|= List.filter (fun file -> extension file = Some "crt")
>>= Lwt_list.map_p (fun file -> certs_of_pem (path </> file))
>|= List.concat
let crl_of_pem path =
catch_invalid_arg
(read_file path >|= fun data ->
match X509.CRL.decode_der data with
| Ok cs -> cs
| Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m))
(o failure @@ Printf.sprintf "CRL in %s: %s" path)
let crls_of_pem_dir = function
| None -> Lwt.return None
| Some path ->
read_dir path >>= fun files ->
Lwt_list.map_p (fun file -> crl_of_pem (path </> file)) files >|= fun crls ->
Some crls
let authenticator ?hash_whitelist ?crls param =
let time () = Some (Ptime_clock.now ()) in
let of_cas cas =
crls_of_pem_dir crls >|= fun crls ->
X509.Authenticator.chain_of_trust ?hash_whitelist ?crls ~time cas
and dotted_hex_to_cs hex =
Cstruct.of_hex (String.map (function ':' -> ' ' | x -> x) hex)
and fingerp hash fingerprints =
X509.Authenticator.server_key_fingerprint ~time ~hash ~fingerprints
and cert_fingerp hash fingerprints =
X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprints
in
match param with
| `Ca_file path -> certs_of_pem path >>= of_cas
| `Ca_dir path -> certs_of_pem_dir path >>= of_cas
| `Key_fingerprints (hash, fps) -> return (fingerp hash fps)
| `Hex_key_fingerprints (hash, fps) ->
let fps = List.map (fun (n, v) -> (n, dotted_hex_to_cs v)) fps in
return (fingerp hash fps)
| `Cert_fingerprints (hash, fps) -> return (cert_fingerp hash fps)
| `Hex_cert_fingerprints (hash, fps) ->
let fps = List.map (fun (n, v) -> (n, dotted_hex_to_cs v)) fps in
return (cert_fingerp hash fps)