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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
type configuration = {
email : Emile.mailbox option;
certificate_seed : string option;
certificate_key_type : X509.Key_type.t;
certificate_key_bits : int option;
hostname : [ `host ] Domain_name.t;
account_seed : string option;
account_key_type : X509.Key_type.t;
account_key_bits : int option;
}
module Client : Letsencrypt.Client.Client
with type 'a t = 'a Lwt.t
and type ctx = Http_mirage_client.t
and type error = Mimic.error
= struct
type 'a t = 'a Lwt.t
type ctx = Http_mirage_client.t
type error = Mimic.error
type meth = [ `HEAD | `GET | `POST ]
type response =
{ headers : (string * string) list
; status : int }
open Lwt.Infix
let get_or_fail msg = function
| Some ctx -> ctx
| None -> failwith msg
let request ?ctx ?(meth= `GET) ? ?body uri =
let ctx = get_or_fail "http-mirage-client context is required" ctx in
let meth = (meth :> H1.Method.t) in
Http_mirage_client.request ctx ~meth ?headers ?body uri
(fun _response buf str -> Buffer.add_string buf str; Lwt.return buf)
(Buffer.create 0x100) >>= function
| Ok (resp, buf) ->
let status = Http_mirage_client.Status.to_code resp.Http_mirage_client.status in
let = Http_mirage_client.Headers.to_list resp.Http_mirage_client.headers in
let = List.map (fun (k, v) -> String.lowercase_ascii k, v) headers in
Lwt.return_ok ({ headers; status }, Buffer.contents buf)
| Error err -> Lwt.return_error err
end
module Log = (val let src = Logs.Src.create "letsencrypt.mirage" in
Logs.src_log src : Logs.LOG)
module Make (Stack : Tcpip.Stack.V4V6) = struct
type nonrec configuration = configuration = {
email : Emile.mailbox option;
certificate_seed : string option;
certificate_key_type : X509.Key_type.t;
certificate_key_bits : int option;
hostname : [ `host ] Domain_name.t;
account_seed : string option;
account_key_type : X509.Key_type.t;
account_key_bits : int option;
}
module Acme = Letsencrypt.Client.Make (Lwt) (Client)
module Solver = Letsencrypt.Client.Solver (Lwt)
let gen_key ?seed ?bits key_type =
X509.Private_key.generate ?seed ?bits key_type
let csr key host =
let host = Domain_name.to_string host in
let cn =
X509.
[ Distinguished_name.(Relative_distinguished_name.singleton (CN host)) ]
in
X509.Signing_request.create cn key
let prefix = (".well-known", "acme-challenge")
let tokens = Hashtbl.create 1
let solver _host ~prefix:_ ~token ~content =
Hashtbl.replace tokens token content ;
Lwt.return (Ok ())
let request_handler (ipaddr, port) reqd =
let req = H1.Reqd.request reqd in
Log.debug (fun m ->
m "Let's encrypt request handler for %a:%d (%s)" Ipaddr.pp ipaddr port
req.H1.Request.target) ;
match String.split_on_char '/' req.H1.Request.target with
| [ ""; p1; p2; token ]
when String.equal p1 (fst prefix) && String.equal p2 (snd prefix) -> (
match Hashtbl.find_opt tokens token with
| Some data ->
Log.debug (fun m -> m "Be able to respond to let's encrypt!") ;
let =
H1.Headers.of_list
[
("content-type", "application/octet-stream");
("content-length", string_of_int (String.length data));
] in
let resp = H1.Response.create ~headers `OK in
H1.Reqd.respond_with_string reqd resp data
| None ->
Log.warn (fun m -> m "Token %S not found!" token) ;
let = H1.Headers.of_list [ ("connection", "close") ] in
let resp = H1.Response.create ~headers `Not_found in
H1.Reqd.respond_with_string reqd resp "")
| _ ->
let = H1.Headers.of_list [ ("connection", "close") ] in
let resp = H1.Response.create ~headers `Not_found in
H1.Reqd.respond_with_string reqd resp ""
let provision_certificate ?(tries = 10) ?(production = false) cfg ctx =
let open Lwt.Infix in
let ( >>? ) = Lwt_result.bind in
let endpoint =
if production
then Letsencrypt.letsencrypt_production_url
else Letsencrypt.letsencrypt_staging_url in
let priv =
gen_key ?seed:cfg.certificate_seed ?bits:cfg.certificate_key_bits
cfg.certificate_key_type in
match csr priv cfg.hostname with
| Error _ as err -> Lwt.return err
| Ok csr ->
let account_key =
gen_key ?seed:cfg.account_seed ?bits:cfg.account_key_bits
cfg.account_key_type in
Acme.initialise ~ctx ~endpoint
?email:(Option.map Emile.to_string cfg.email)
account_key
>>? fun le ->
Log.debug (fun m -> m "Let's encrypt state initialized.") ;
let sleep sec = Mirage_sleep.ns (Duration.of_sec sec) in
let solver : Acme.solver = Solver.http_solver solver in
let rec go tries =
Acme.sign_certificate ~ctx solver le sleep csr >>= function
| Ok certs -> Lwt.return_ok (`Single (certs, priv))
| Error (`Msg err) when tries > 0 ->
Log.warn (fun m ->
m
"Got an error when we tried to get a certificate: %s \
(tries: %d)"
err tries) ;
go (pred tries)
| Error (`Msg err) ->
Log.err (fun m ->
m "Got an error when we tried to get a certificate: %s" err) ;
Lwt.return (Error (`Msg err))
| Error (`HTTP err) ->
Lwt.return (Error (`Msg (Fmt.str "HTTP error during certificate provisioning: %a" Mimic.pp_error err))) in
go tries
let initialise ~ctx ~endpoint ?email key = Acme.initialise ~ctx ~endpoint ?email key
let sign_certificate ~ctx solver le sleep csr = Acme.sign_certificate ~ctx solver le sleep csr
end