From ccfc0bc29cbced1159e683ebfde6c539f638dc39 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Thu, 8 Jul 2021 14:12:21 +0200 Subject: [PATCH 1/2] Replace CoHTTP by a abstract interface --- bin/oacmel.ml | 14 ++++++- letsencrypt.opam | 1 - src/acme_client.ml | 97 ++++++++++++++++++++++---------------------- src/dune | 2 +- src/hTTP_client.ml | 99 +++++++++++++++++++++++++++++++++++++++++++++ src/letsencrypt.ml | 1 + src/letsencrypt.mli | 2 +- 7 files changed, 163 insertions(+), 53 deletions(-) create mode 100644 src/hTTP_client.ml diff --git a/bin/oacmel.ml b/bin/oacmel.ml index 2ca7df8..9e3bc7f 100644 --- a/bin/oacmel.ml +++ b/bin/oacmel.ml @@ -1,6 +1,18 @@ open Lwt.Infix -module Acme_cli = Letsencrypt.Client.Make(Cohttp_lwt_unix.Client) +module HTTP_client = struct + module Headers = Cohttp.Header + module Body = Cohttp_lwt.Body + + module Response = struct + include Cohttp.Response + let status resp = Cohttp.Code.code_of_status (Cohttp.Response.status resp) + end + + include Cohttp_lwt_unix.Client +end + +module Acme_cli = Letsencrypt.Client.Make(HTTP_client) let dns_out ip cs = let out = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in diff --git a/letsencrypt.opam b/letsencrypt.opam index 166691f..586d942 100644 --- a/letsencrypt.opam +++ b/letsencrypt.opam @@ -16,7 +16,6 @@ depends: [ "base64" {>= "3.1.0"} "cmdliner" "cohttp" - "cohttp-lwt" {>= "2.5.1"} "cohttp-lwt-unix" {>= "1.0.0"} "zarith" "logs" diff --git a/src/acme_client.ml b/src/acme_client.ml index d0cb6df..8adc022 100644 --- a/src/acme_client.ml +++ b/src/acme_client.ml @@ -7,13 +7,6 @@ module Log = (val Logs.src_log src : Logs.LOG) let guard p err = if p then Ok () else err -let location headers = - match Cohttp.Header.get_location headers with - | Some url -> Ok url - | None -> - Rresult.R.error_msgf "expected a location header, but couldn't fine any in %a" - Cohttp.Header.pp_hum headers - let key_authorization key token = let pk = Primitives.pub_of_priv key in let thumbprint = Jwk.thumbprint (`Rsa pk) in @@ -34,13 +27,8 @@ type solver = { let error_in endpoint status body = Rresult.R.error_msgf - "Error at %s: status %s - body: %S" - endpoint (Cohttp.Code.string_of_status status) body - -let extract_nonce headers = - match Cohttp.Header.get headers "Replay-Nonce" with - | Some nonce -> Ok nonce - | None -> Error (`Msg "Error: I could not fetch a new nonce.") + "Error at %s: status %3d - body: %S" + endpoint status body let http_solver writef = let solve_challenge ~token ~key_authorization domain = @@ -162,39 +150,50 @@ let print_alpn = in alpn_solver solve -module Make (Http : Cohttp_lwt.S.Client) = struct +module Make (Http : HTTP_client.S) = struct + +let location headers = + match Http.Headers.get_location headers with + | Some url -> Ok url + | None -> + Rresult.R.error_msgf "expected a location header, but couldn't find it" + +let extract_nonce headers = + match Http.Headers.get headers "Replay-Nonce" with + | Some nonce -> Ok nonce + | None -> Error (`Msg "Error: I could not fetch a new nonce.") let headers = - Cohttp.Header.init_with "user-agent" ("ocaml-letsencrypt/" ^ Version.t) + Http.Headers.init_with "user-agent" ("ocaml-letsencrypt/" ^ Version.t) let http_get ?ctx url = Http.get ?ctx ~headers url >>= fun (resp, body) -> - let status = Cohttp.Response.status resp in - let headers = Cohttp.Response.headers resp in - body |> Cohttp_lwt.Body.to_string >>= fun body -> + let status = Http.Response.status resp in + let headers = Http.Response.headers resp in + body |> Http.Body.to_string >>= fun body -> Log.debug (fun m -> m "HTTP get: %a" Uri.pp_hum url); - Log.debug (fun m -> m "Got status: %s" (Cohttp.Code.string_of_status status)); - Log.debug (fun m -> m "headers %S" (Cohttp.Header.to_string headers)); + Log.debug (fun m -> m "Got status: %3d" status); + Log.debug (fun m -> m "headers %S" (Http.Headers.to_string headers)); Log.debug (fun m -> m "body %S" body); Lwt.return (status, headers, body) let http_head ?ctx url = Http.head ?ctx ~headers url >>= fun resp -> - let status = Cohttp.Response.status resp in - let headers = Cohttp.Response.headers resp in + let status = Http.Response.status resp in + let headers = Http.Response.headers resp in Log.debug (fun m -> m "HTTP HEAD: %a" Uri.pp_hum url); - Log.debug (fun m -> m "Got status: %s" (Cohttp.Code.string_of_status status)); - Log.debug (fun m -> m "headers %S" (Cohttp.Header.to_string headers)); + Log.debug (fun m -> m "Got status: %3d" status); + Log.debug (fun m -> m "headers %S" (Http.Headers.to_string headers)); Lwt.return (status, headers) let discover ?ctx directory = http_get ?ctx directory >|= function - | (`OK, _headers, body) -> Directory.decode body + | (200, _headers, body) -> Directory.decode body | (status, _, body) -> error_in "discover" status body let get_nonce ?ctx url = http_head ?ctx url >|= function - | `OK, headers -> extract_nonce headers + | 200, headers -> extract_nonce headers | s, _ -> error_in "get_nonce" s "" let rec http_post_jws ?ctx ?(no_key_url = false) cli data url = @@ -202,25 +201,25 @@ let rec http_post_jws ?ctx ?(no_key_url = false) cli data url = let kid_url = if no_key_url then None else Some cli.account_url in let body = Jws.encode_acme ?kid_url ~data:(json_to_string data) ~nonce url key in let body_len = string_of_int (String.length body) in - let headers = Cohttp.Header.add headers "Content-Length" body_len in - let headers = Cohttp.Header.add headers "Content-Type" "application/jose+json" in + let headers = Http.Headers.add headers "Content-Length" body_len in + let headers = Http.Headers.add headers "Content-Type" "application/jose+json" in (headers, body) in let headers, body = prepare_post cli.account_key cli.next_nonce in Log.debug (fun m -> m "HTTP post %a (data %s body %S)" Uri.pp_hum url (json_to_string data) body); - let body = Cohttp_lwt.Body.of_string body in + let body = Http.Body.of_string body in Http.post ?ctx ~body ~headers url >>= fun (resp, body) -> - let status = Cohttp.Response.status resp in - let headers = Cohttp.Response.headers resp in - Cohttp_lwt.Body.to_string body >>= fun body -> - Log.debug (fun m -> m "Got code: %s" (Cohttp.Code.string_of_status status)); - Log.debug (fun m -> m "headers %S" (Cohttp.Header.to_string headers)); + let status = Http.Response.status resp in + let headers = Http.Response.headers resp in + Http.Body.to_string body >>= fun body -> + Log.debug (fun m -> m "Got code: %3d" status); + Log.debug (fun m -> m "headers %S" (Http.Headers.to_string headers)); Log.debug (fun m -> m "body %S" body); (match extract_nonce headers with | Error `Msg e -> Log.err (fun m -> m "couldn't extract nonce: %s" e) | Ok next_nonce -> cli.next_nonce <- next_nonce); - if status = `Bad_request then begin + if status = 400 then begin let open Lwt_result.Infix in Lwt_result.lift (Error.decode body) >>= fun err -> if err.err_typ = `Bad_nonce then begin @@ -243,7 +242,7 @@ let create_account ?ctx ?email cli = let body = `Assoc (("termsOfServiceAgreed", `Bool true) :: contact) in http_post_jws ?ctx ~no_key_url:true cli body url >|= function | Error e -> Error e - | Ok (`Created, headers, body) -> + | Ok (201, headers, body) -> let open Rresult.R.Infix in Account.decode body >>= fun account -> guard (account.account_status = `Valid) @@ -257,7 +256,7 @@ let get_account ?ctx cli url = let body = `Null in http_post_jws ?ctx cli body url >|= function | Error e -> Error e - | Ok (`OK, _headers, body) -> + | Ok (200, _headers, body) -> let open Rresult.R.Infix in (* at least staging doesn't include orders *) Account.decode body >>| fun acc -> @@ -277,7 +276,7 @@ let find_account_url ?ctx ?email ~nonce key directory = } in http_post_jws ?ctx ~no_key_url:true cli body url >>= function | Error e -> Lwt.return (Error e) - | Ok (`OK, headers, body) -> + | Ok (200, headers, body) -> let open Rresult.R.Infix in Lwt.return begin (* unclear why this is not an account object, as required in 7.3.0/7.3.1 *) @@ -288,7 +287,7 @@ let find_account_url ?ctx ?email ~nonce key directory = location headers >>| fun account_url -> { cli with account_url } end - | Ok (`Bad_request, _headers, body) -> + | Ok (400, _headers, body) -> let open Lwt_result.Infix in Lwt_result.lift (Error.decode body) >>= fun err -> if err.err_typ = `Account_does_not_exist then begin @@ -296,7 +295,7 @@ let find_account_url ?ctx ?email ~nonce key directory = create_account ?ctx ?email cli end else begin Log.err (fun m -> m "error %a in find account url" Error.pp err); - Lwt.return (error_in "newAccount" `Bad_request body) + Lwt.return (error_in "newAccount" 400 body) end (* according to RFC 8555 7.3.3 there can be a forbidden if ToS were updated, and the client should re-approve them *) @@ -307,10 +306,10 @@ let challenge_solved ?ctx cli url = let body = `Assoc [] in (* not entirely clear why this now is {} and not "" *) http_post_jws ?ctx cli body url >|= function | Error e -> Error e - | Ok (`OK, _headers, body) -> + | Ok (200, _headers, body) -> Log.info (fun m -> m "challenge solved POSTed (OK), body %s" body); Ok () - | Ok (`Created, _headers, body) -> + | Ok (201, _headers, body) -> Log.info (fun m -> m "challenge solved POSTed (CREATE), body %s" body); Ok () | Ok (status, _headers, body) -> @@ -371,7 +370,7 @@ let process_authorization ?ctx solver cli sleep url = let body = `Null in http_post_jws ?ctx cli body url >>= function | Error e -> Lwt.return (Error e) - | Ok (`OK, _headers, body) -> + | Ok (200, _headers, body) -> begin let open Lwt_result.Infix in Lwt_result.lift (Authorization.decode body) >>= fun auth -> @@ -416,7 +415,7 @@ let finalize ?ctx cli csr url = in http_post_jws ?ctx cli body url >|= function | Error e -> Error e - | Ok (`OK, headers, body) -> + | Ok (200, headers, body) -> let open Rresult.R.Infix in Order.decode body >>| fun order -> headers, order @@ -426,7 +425,7 @@ let dl_certificate ?ctx cli url = let body = `Null in http_post_jws ?ctx cli body url >|= function | Error e -> Error e - | Ok (`OK, _headers, body) -> + | Ok (200, _headers, body) -> (* body is a certificate chain (no comments), with end-entity certificate being the first *) (* TODO: check order? figure out chain? *) X509.Certificate.decode_pem_multiple (Cstruct.of_string body) @@ -436,7 +435,7 @@ let get_order ?ctx cli url = let body = `Null in http_post_jws ?ctx cli body url >|= function | Error e -> Error e - | Ok (`OK, headers, body) -> + | Ok (200, headers, body) -> let open Rresult.R.Infix in Order.decode body >>| fun order -> headers, order @@ -445,7 +444,7 @@ let get_order ?ctx cli url = (* HTTP defines this header as "either seconds" or "absolute HTTP date" *) let retry_after h = - match Cohttp.Header.get h "Retry-after" with + match Http.Headers.get h "Retry-after" with | None -> 1 | Some x -> try int_of_string x with Failure _ -> @@ -543,7 +542,7 @@ let new_order ?ctx solver cli sleep csr = in http_post_jws ?ctx cli body cli.d.new_order >>= function | Error e -> Lwt.return (Error e) - | Ok (`Created, headers, body) -> + | Ok (201, headers, body) -> let open Lwt_result.Infix in Lwt_result.lift (Order.decode body) >>= fun order -> (* identifiers (should-be-verified to be the same set as the hostnames above?) *) diff --git a/src/dune b/src/dune index 49b5462..509e276 100644 --- a/src/dune +++ b/src/dune @@ -3,4 +3,4 @@ (library (name letsencrypt) (public_name letsencrypt) - (libraries logs yojson lwt base64 mirage-crypto mirage-crypto-pk asn1-combinators x509 uri dns dns-tsig rresult astring cohttp-lwt)) + (libraries logs yojson lwt base64 mirage-crypto mirage-crypto-pk asn1-combinators x509 uri dns dns-tsig rresult astring)) diff --git a/src/hTTP_client.ml b/src/hTTP_client.ml new file mode 100644 index 0000000..76fedee --- /dev/null +++ b/src/hTTP_client.ml @@ -0,0 +1,99 @@ +module type S = sig + type ctx + (** Type of the user-defined {i context}. + + The context is an user-defined value which can be passed to your HTTP + client implementation to be able to tweak some internal details about the + underlying request/connection used to get an HTTP response. + + For instance, an HTTP implementation can optionally require some value + such as the internal buffer size or a time-out value, etc. The interface + wants to {b allow} the implementer to pass such information via the [ctx] + type. + + In others words, anything optionnaly needed to initiate/do the HTTP + request and that is not described over this interface (by arguments, + types, etc.) can be passed via the user-defined [ctx] type. + + For instance, MirageOS uses this [ctx] as a ressource allocator to + initiate a TCP/IP connection or a TLS connection - and, by this way, + it fully abstracts the HTTP client implementation over the TCP/IP and + the TLS stack (for more details, see [mimic]). + + Of course, [ctx = unit] if you don't need to pass extra-information when + you want to do an HTTP request/connection. *) + + module Headers : sig + type t + (** The type of HTTP headers. *) + + val add : t -> string -> string -> t + (** [add hdrs key value] adds a [key] and a [value] to an existing + [hdrs] headers. *) + + val get : t -> string -> string option + (** [get hdrs key] retrieves a [key] from the given [hdrs] headers. If the + header is one of the set of headers defined to have list values, then + all of the values are concatenated into a single string separated by + commas and returned. If it is a singleton header, then the first value + is returned and no concatenation is performed. *) + + val get_location : t -> Uri.t option + (** [get_location hdrs] is [get hdrs "location"]. *) + + val init_with : string -> string -> t + (** [init_with key value] constructs a fresh map of HTTP headers with a + single key and value entry. *) + + (** / *) + + val to_string : t -> string + end + + module Body : sig + type t + (** The type of HTTP body. *) + + val of_string : string -> t + (** [of_string str] makes a body from the given [string] [str]. *) + + val to_string : t -> string Lwt.t + (** [to_string body] returns the full given [body] as a [string]. *) + end + + module Response : sig + type t + (** The type of HTTP response. *) + + val status : t -> int + (** [status resp] is the HTTP status code of the response [resp]. *) + + val headers : t -> Headers.t + (** [headers resp] is headers of the response [resp]. *) + end + + val head : + ?ctx:ctx -> ?headers:Headers.t -> Uri.t -> Response.t Lwt.t + (** [head ?ctx ?headers uri] sends an {i HEAD} HTTP request to the given + [uri] and returns its response. The returned response does not have + a {i body} according to the HTTP standard. *) + + val get : + ?ctx:ctx -> + ?headers:Headers.t -> + Uri.t -> + (Response.t * Body.t) Lwt.t + (** [get ?ctx ?headers uri] sends an {i GET} HTTP request to the given + [uri] and returns its response with its body. *) + + val post : + ?ctx:ctx -> + ?body:Body.t -> + ?chunked:bool -> + ?headers:Headers.t -> + Uri.t -> + (Response.t * Body.t) Lwt.t + (** [post ?ctx ?body ?chunked ?headers uri] sends an {i POST} HTTP request + with the optional given [body] using chunked encoding if [chunked] is + [true] (default to [false]). It returns a response and a body. *) +end diff --git a/src/letsencrypt.ml b/src/letsencrypt.ml index 9d87a1c..d8655cd 100644 --- a/src/letsencrypt.ml +++ b/src/letsencrypt.ml @@ -1,3 +1,4 @@ include Acme_common +module HTTP_client = HTTP_client module Client = Acme_client diff --git a/src/letsencrypt.mli b/src/letsencrypt.mli index df031f5..0ca0a83 100644 --- a/src/letsencrypt.mli +++ b/src/letsencrypt.mli @@ -74,7 +74,7 @@ module Client: sig before continuing with ACME. *) val print_alpn : solver - module Make (Http : Cohttp_lwt.S.Client) : sig + module Make (Http : HTTP_client.S) : sig (** [initialise ~ctx ~endpoint ~email priv] constructs a [t] by looking up the directory and account of [priv] at [endpoint]. If no From 04c7b5f48b8c787e246ff76a3a907badc09b8b23 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 19 Jul 2021 16:15:04 +0200 Subject: [PATCH 2/2] split let's encrypt into three packages (reduce dependencies) - letsencrypt: core, few dependencies - letsencrypt-app: the client application - letsencrypt-dns: the DNS solver --- bin/dune | 4 +-- bin/oacmel.ml | 4 +-- dns/dune | 4 +++ dns/letsencrypt_dns.ml | 62 +++++++++++++++++++++++++++++++++++++++++ dns/letsencrypt_dns.mli | 25 +++++++++++++++++ letsencrypt-app.opam | 32 +++++++++++++++++++++ letsencrypt-dns.opam | 28 +++++++++++++++++++ letsencrypt.opam | 10 ------- src/acme_client.ml | 58 -------------------------------------- src/acme_common.ml | 3 ++ src/acme_common.mli | 2 ++ src/letsencrypt.mli | 34 +++++----------------- 12 files changed, 167 insertions(+), 99 deletions(-) create mode 100644 dns/dune create mode 100644 dns/letsencrypt_dns.ml create mode 100644 dns/letsencrypt_dns.mli create mode 100644 letsencrypt-app.opam create mode 100644 letsencrypt-dns.opam diff --git a/bin/dune b/bin/dune index 7a9bdfb..dbf842e 100644 --- a/bin/dune +++ b/bin/dune @@ -1,6 +1,6 @@ (executable (name oacmel) (public_name oacmel) - (package letsencrypt) + (package letsencrypt-app) (modules oacmel) - (libraries letsencrypt ptime.clock.os ipaddr.unix cohttp-lwt-unix fpath bos randomconv cmdliner mirage-crypto-rng.unix fmt.cli fmt.tty logs.fmt logs.cli)) + (libraries letsencrypt letsencrypt-dns ptime.clock.os ipaddr.unix cohttp-lwt-unix fpath bos randomconv cmdliner mirage-crypto-rng.unix fmt.cli fmt.tty logs.fmt logs.cli)) diff --git a/bin/oacmel.ml b/bin/oacmel.ml index 9e3bc7f..9079a0e 100644 --- a/bin/oacmel.ml +++ b/bin/oacmel.ml @@ -61,10 +61,10 @@ let main _ rsa_pem csr_pem email solver acme_dir ip key endpoint cert zone = | Some x -> Domain_name.(host_exn (of_string_exn x)) in let random_id = Randomconv.int16 Mirage_crypto_rng.generate in - Letsencrypt.Client.nsupdate random_id Ptime_clock.now (dns_out ip') ~keyname key ~zone + Letsencrypt_dns.nsupdate random_id Ptime_clock.now (dns_out ip') ~keyname key ~zone | Some `Dns, None, None, None -> Logs.app (fun m -> m "using dns solver"); - Letsencrypt.Client.print_dns + Letsencrypt_dns.print_dns | Some `Http, None, None, None -> Logs.app (fun m -> m "using http solver"); Letsencrypt.Client.print_http diff --git a/dns/dune b/dns/dune new file mode 100644 index 0000000..c269f01 --- /dev/null +++ b/dns/dune @@ -0,0 +1,4 @@ +(library + (name letsencrypt_dns) + (public_name letsencrypt-dns) + (libraries letsencrypt logs lwt dns dns-tsig)) diff --git a/dns/letsencrypt_dns.ml b/dns/letsencrypt_dns.ml new file mode 100644 index 0000000..485dbd5 --- /dev/null +++ b/dns/letsencrypt_dns.ml @@ -0,0 +1,62 @@ +let src = Logs.Src.create "letsencrypt.dns" ~doc:"let's encrypt library" +module Log = (val Logs.src_log src : Logs.LOG) + +open Lwt.Infix + +let dns_solver writef = + let solve_challenge ~token:_ ~key_authorization domain = + let solution = Letsencrypt.sha256_and_base64 key_authorization in + let domain_name = Domain_name.prepend_label_exn domain "_acme-challenge" in + writef domain_name solution + in + { Letsencrypt.Client.typ = `Dns ; solve_challenge } + +let print_dns = + let solve domain solution = + Log.warn (fun f -> f "Setup a TXT record for %a to return %s and press enter to continue" + Domain_name.pp domain solution); + ignore (read_line ()); + Lwt.return_ok () + in + dns_solver solve + +let nsupdate ?proto id now out ?recv ~zone ~keyname key = + let open Dns in + let nsupdate name record = + Log.info (fun m -> m "solving dns by update to! %a (name %a)" + Domain_name.pp zone Domain_name.pp name); + let zone = Packet.Question.create zone Rr_map.Soa + and update = + let up = + Domain_name.Map.singleton name + [ + Packet.Update.Remove (Rr_map.K Txt) ; + Packet.Update.Add Rr_map.(B (Txt, (3600l, Txt_set.singleton record))) + ] + in + (Domain_name.Map.empty, up) + and header = (id, Packet.Flags.empty) + in + let packet = Packet.create header zone (`Update update) in + match Dns_tsig.encode_and_sign ?proto packet (now ()) key keyname with + | Error s -> Lwt.return_error (`Msg (Fmt.to_to_string Dns_tsig.pp_s s)) + | Ok (data, mac) -> + out data >>= function + | Error err -> Lwt.return_error err + | Ok () -> + match recv with + | None -> Lwt.return_ok () + | Some recv -> recv () >|= function + | Error e -> Error e + | Ok data -> + match Dns_tsig.decode_and_verify (now ()) key keyname ~mac data with + | Error e -> Error (`Msg (Fmt.strf "decode and verify error %a" Dns_tsig.pp_e e)) + | Ok (res, _, _) -> + match Packet.reply_matches_request ~request:packet res with + | Ok _ -> Ok () + | Error mismatch -> + Error (`Msg (Fmt.strf "error %a expected reply to %a, got %a" + Packet.pp_mismatch mismatch + Packet.pp packet Packet.pp res)) + in + dns_solver nsupdate diff --git a/dns/letsencrypt_dns.mli b/dns/letsencrypt_dns.mli new file mode 100644 index 0000000..5b899fc --- /dev/null +++ b/dns/letsencrypt_dns.mli @@ -0,0 +1,25 @@ +(** [dns_solver (fun domain content)] is a solver for dns-01 challenges. + The provided function should return [Ok ()] once the authoritative + name servers serve a TXT record at [domain] with the content. The + [domain] already has the [_acme-challenge.] prepended. *) +val dns_solver : + ([`raw] Domain_name.t -> string -> + (unit, [ `Msg of string ]) result Lwt.t) -> Letsencrypt.Client.solver + +(** [print_dns] outputs the DNS challenge solution, and waits for user input + before continuing with ACME. *) +val print_dns : Letsencrypt.Client.solver + +(** [nsupdate ~proto id now send ~recv ~keyname key ~zone] + constructs a dns solver that sends a DNS update packet (using [send]) + and optionally waits for a signed reply (using [recv] if present) to solve + challenges. The update is signed with a hmac transaction signature + (DNS TSIG) using [now ()] as timestamp, and the [keyname] and [key] for + the cryptographic material. The [zone] is the one to be used in the + query section of the update packet. If signing, sending, or receiving + fails, the error is reported. *) +val nsupdate : ?proto:Dns.proto -> int -> (unit -> Ptime.t) -> + (Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) -> + ?recv:(unit -> (Cstruct.t, [ `Msg of string ]) result Lwt.t) -> + zone:[ `host ] Domain_name.t -> + keyname:'a Domain_name.t -> Dns.Dnskey.t -> Letsencrypt.Client.solver diff --git a/letsencrypt-app.opam b/letsencrypt-app.opam new file mode 100644 index 0000000..985c972 --- /dev/null +++ b/letsencrypt-app.opam @@ -0,0 +1,32 @@ +opam-version: "2.0" +synopsis: "ACME implementation in OCaml" +description: "An ACME client implementation of the ACME protocol (RFC 8555) for OCaml" +maintainer: "Michele Mu " +authors: + "Michele Mu , Hannes Mehnert " +license: "BSD-2-clause" +homepage: "https://github.com/mmaker/ocaml-letsencrypt" +bug-reports: "https://github.com/mmaker/ocaml-letsencrypt/issues" +doc: "https://mmaker.github.io/ocaml-letsencrypt" +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "1.2.0"} + "letsencrypt" #{= version} + "letsencrypt-dns" #{= version} + "cmdliner" + "cohttp-lwt-unix" {>= "1.0.0"} + "logs" + "fmt" + "lwt" {>= "2.6.0"} + "mirage-crypto-rng" + "ptime" + "bos" + "fpath" + "randomconv" +] +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mmaker/ocaml-letsencrypt.git" diff --git a/letsencrypt-dns.opam b/letsencrypt-dns.opam new file mode 100644 index 0000000..f2e9b5d --- /dev/null +++ b/letsencrypt-dns.opam @@ -0,0 +1,28 @@ +opam-version: "2.0" +synopsis: "DNS solver for ACME implementation in OCaml" +description: "A DNS solver for the ACME implementation in OCaml." +maintainer: "Michele Mu " +authors: + "Michele Mu , Hannes Mehnert " +license: "BSD-2-clause" +homepage: "https://github.com/mmaker/ocaml-letsencrypt" +bug-reports: "https://github.com/mmaker/ocaml-letsencrypt/issues" +doc: "https://mmaker.github.io/ocaml-letsencrypt" +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "1.2.0"} + "letsencrypt" #{= version} + "mirage-crypto" + "logs" + "fmt" + "lwt" {>= "2.6.0"} + "dns" + "dns-tsig" + "domain-name" {>= "0.2.0"} +] +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mmaker/ocaml-letsencrypt.git" diff --git a/letsencrypt.opam b/letsencrypt.opam index 586d942..bdf4852 100644 --- a/letsencrypt.opam +++ b/letsencrypt.opam @@ -14,26 +14,16 @@ depends: [ "astring" "rresult" "base64" {>= "3.1.0"} - "cmdliner" - "cohttp" - "cohttp-lwt-unix" {>= "1.0.0"} - "zarith" "logs" "fmt" "lwt" {>= "2.6.0"} "mirage-crypto" "mirage-crypto-pk" "mirage-crypto-pk" {with-test & >= "0.8.9"} - "mirage-crypto-rng" "x509" {>= "0.13.0"} "yojson" {>= "1.6.0"} "ounit" {with-test} - "dns" - "dns-tsig" "ptime" - "bos" - "fpath" - "randomconv" "domain-name" {>= "0.2.0"} ] build: [ diff --git a/src/acme_client.ml b/src/acme_client.ml index 8adc022..a719fb3 100644 --- a/src/acme_client.ml +++ b/src/acme_client.ml @@ -46,64 +46,6 @@ let print_http = in http_solver solve -let dns_solver writef = - let solve_challenge ~token:_ ~key_authorization domain = - let solution = Primitives.sha256 key_authorization |> B64u.urlencode in - let domain_name = Domain_name.prepend_label_exn domain "_acme-challenge" in - writef domain_name solution - in - { typ = `Dns ; solve_challenge } - -let print_dns = - let solve domain solution = - Log.warn (fun f -> f "Setup a TXT record for %a to return %s and press enter to continue" - Domain_name.pp domain solution); - ignore (read_line ()); - Lwt.return_ok () - in - dns_solver solve - -let nsupdate ?proto id now out ?recv ~zone ~keyname key = - let open Dns in - let nsupdate name record = - Log.info (fun m -> m "solving dns by update to! %a (name %a)" - Domain_name.pp zone Domain_name.pp name); - let zone = Packet.Question.create zone Rr_map.Soa - and update = - let up = - Domain_name.Map.singleton name - [ - Packet.Update.Remove (Rr_map.K Txt) ; - Packet.Update.Add Rr_map.(B (Txt, (3600l, Txt_set.singleton record))) - ] - in - (Domain_name.Map.empty, up) - and header = (id, Packet.Flags.empty) - in - let packet = Packet.create header zone (`Update update) in - match Dns_tsig.encode_and_sign ?proto packet (now ()) key keyname with - | Error s -> Lwt.return_error (`Msg (Fmt.to_to_string Dns_tsig.pp_s s)) - | Ok (data, mac) -> - out data >>= function - | Error err -> Lwt.return_error err - | Ok () -> - match recv with - | None -> Lwt.return_ok () - | Some recv -> recv () >|= function - | Error e -> Error e - | Ok data -> - match Dns_tsig.decode_and_verify (now ()) key keyname ~mac data with - | Error e -> Error (`Msg (Fmt.strf "decode and verify error %a" Dns_tsig.pp_e e)) - | Ok (res, _, _) -> - match Packet.reply_matches_request ~request:packet res with - | Ok _ -> Ok () - | Error mismatch -> - Error (`Msg (Fmt.strf "error %a expected reply to %a, got %a" - Packet.pp_mismatch mismatch - Packet.pp packet Packet.pp res)) - in - dns_solver nsupdate - let alpn_solver writef = (* on the ID-PE arc (from RFC 5280), 31 *) let id_pe_acme = Asn.OID.(base 1 3 <| 6 <| 1 <| 5 <| 5 <| 7 <| 1 <| 31) diff --git a/src/acme_common.ml b/src/acme_common.ml index 2f377fc..17b23a3 100644 --- a/src/acme_common.ml +++ b/src/acme_common.ml @@ -7,6 +7,9 @@ let letsencrypt_production_url = let letsencrypt_staging_url = Uri.of_string "https://acme-staging-v02.api.letsencrypt.org/directory" +let sha256_and_base64 a = + Primitives.sha256 a |> B64u.urlencode + module J = Yojson.Basic type json = J.t diff --git a/src/acme_common.mli b/src/acme_common.mli index 84d5038..5034d8a 100644 --- a/src/acme_common.mli +++ b/src/acme_common.mli @@ -2,6 +2,8 @@ val letsencrypt_production_url : Uri.t val letsencrypt_staging_url : Uri.t +val sha256_and_base64 : string -> string + type json = Yojson.Basic.t val json_to_string : ?comma:string -> ?colon:string -> json -> string diff --git a/src/letsencrypt.mli b/src/letsencrypt.mli index 0ca0a83..5364089 100644 --- a/src/letsencrypt.mli +++ b/src/letsencrypt.mli @@ -9,6 +9,8 @@ val letsencrypt_production_url : Uri.t val letsencrypt_staging_url : Uri.t +val sha256_and_base64 : string -> string + (** ACME Client. This module provides client commands. @@ -20,7 +22,11 @@ val letsencrypt_staging_url : Uri.t module Client: sig type t - type solver + type solver = { + typ : [ `Dns | `Http | `Alpn ]; + solve_challenge : token:string -> key_authorization:string -> + [`host] Domain_name.t -> (unit, [ `Msg of string]) result Lwt.t; + } (** [http_solver (fun domain ~prefix ~token ~content)] is a solver for http-01 challenges. The provided function should return [Ok ()] once the @@ -36,32 +42,6 @@ module Client: sig before continuing with ACME. *) val print_http : solver - (** [dns_solver (fun domain content)] is a solver for dns-01 challenges. - The provided function should return [Ok ()] once the authoritative - name servers serve a TXT record at [domain] with the content. The - [domain] already has the [_acme-challenge.] prepended. *) - val dns_solver : - ([`raw] Domain_name.t -> string -> - (unit, [ `Msg of string ]) result Lwt.t) -> solver - - (** [print_dns] outputs the DNS challenge solution, and waits for user input - before continuing with ACME. *) - val print_dns : solver - - (** [nsupdate ~proto id now send ~recv ~keyname key ~zone] - constructs a dns solver that sends a DNS update packet (using [send]) - and optionally waits for a signed reply (using [recv] if present) to solve - challenges. The update is signed with a hmac transaction signature - (DNS TSIG) using [now ()] as timestamp, and the [keyname] and [key] for - the cryptographic material. The [zone] is the one to be used in the - query section of the update packet. If signing, sending, or receiving - fails, the error is reported. *) - val nsupdate : ?proto:Dns.proto -> int -> (unit -> Ptime.t) -> - (Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) -> - ?recv:(unit -> (Cstruct.t, [ `Msg of string ]) result Lwt.t) -> - zone:[ `host ] Domain_name.t -> - keyname:'a Domain_name.t -> Dns.Dnskey.t -> solver - (** [alpn_solver (fun domain ~alpn private_key certificate)] is a solver for tls-alpn-01 challenes. The provided function should return [Ok ()] once the TLS server at [domain] serves the self-signed [certificate] (with