Replace CoHTTP by a abstract interface

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))

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
@@ -49,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

dns/dune

@@ -0,0 +1,4 @@
+(library
+ (name letsencrypt_dns)
+ (public_name letsencrypt-dns)
+ (libraries letsencrypt logs lwt dns dns-tsig))

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

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

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 <maker@tumbolandia.net>"
+authors:
+  "Michele Mu <maker@tumbolandia.net>, Hannes Mehnert <hannes@mehnert.org>"
+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"

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 <maker@tumbolandia.net>"
+authors:
+  "Michele Mu <maker@tumbolandia.net>, Hannes Mehnert <hannes@mehnert.org>"
+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"

letsencrypt.opam

@@ -14,27 +14,16 @@ depends: [
   "astring"
   "rresult"
   "base64" {>= "3.1.0"}
-  "cmdliner"
-  "cohttp"
-  "cohttp-lwt" {>= "2.5.1"}
-  "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: [