Improve the application and introduce paf-le as a standalone package

bin/oacmel.ml

@@ -81,10 +81,8 @@ let main _ priv_pem csr_pem email solver acme_dir ip key endpoint cert zone =
         Bos.OS.File.write cert (Cstruct.to_string @@ X509.Certificate.encode_pem_multiple t)
   in
   match r with
-  | Ok _ -> `Ok ()
-  | Error (`Msg e) ->
-    Logs.err (fun m -> m "Error %s" e) ;
-    `Error ()
+  | Ok _ -> Ok ()
+  | Error (`Msg e) -> Error (Fmt.str "Error %s" e)
 
 let setup_log style_renderer level =
   Fmt_tty.setup_std_outputs ?style_renderer ();
@@ -155,11 +153,9 @@ let info =
       `S "DESCRIPTION"; `P "This is software is experimental. Don't use it.";
       `S "BUGS"; `P "Email bug reports to <[email protected]>";
     ] in
-  Term.info "oacmel" ~version:"%%VERSION%%" ~doc ~man
+  Cmd.info "oacmel" ~version:"%%VERSION%%" ~doc ~man
 
 let () =
   Printexc.record_backtrace true;
   let cli = Term.(const main $ setup_log $ priv_pem $ csr_pem $ email $ solver $ acme_dir $ ip $ key $ endpoint $ cert $ zone) in
-  match Term.eval (cli, info) with
-  | `Error _ -> exit 1
-  | _        -> exit 0
+  exit (Cmd.eval_result (Cmd.v info cli))

letsencrypt-app.opam

@@ -13,7 +13,7 @@ depends: [
   "dune" {>= "1.2.0"}
   "letsencrypt" {= version}
   "letsencrypt-dns" {= version}
-  "cmdliner"
+  "cmdliner" {>= "1.1.0"}
   "cohttp-lwt-unix" {>= "1.0.0"}
   "logs"
   "fmt" {>= "0.8.7"}

letsencrypt-mirage.opam

@@ -0,0 +1,27 @@
+opam-version: "2.0"
+synopsis: "ACME implementation in OCaml for MirageOS"
+description: "An ACME client implementation of the ACME protocol (RFC 8555) for OCaml & MirageOS"
+maintainer: "Michele Mu <[email protected]>"
+authors:
+  "Michele Mu <[email protected]>, Hannes Mehnert <[email protected]>"
+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}
+  "http-mirage-client"
+  "tcpip" {>= "7.0.0"}
+  "mirage-time" {>= "3.0.0"}
+  "duration"
+  "emile" {>= "1.1"}
+  "paf" {>= "0.4.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"

mirage/dune

@@ -0,0 +1,13 @@
+(library
+ (name le)
+ (wrapped false)
+ (public_name letsencrypt-mirage)
+ (modules lE)
+ (libraries letsencrypt http-mirage-client tcpip mirage-time duration emile))
+
+(library
+ (name le_http_server)
+ (wrapped false)
+ (public_name letsencrypt-mirage.http-server)
+ (modules lE_http_server)
+ (libraries letsencrypt letsencrypt-mirage paf.mirage))

mirage/lE.ml

@@ -0,0 +1,179 @@
+(* (c) Hannes Menhert *)
+
+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 HTTP : Letsencrypt__HTTP_client.S with type ctx = Http_mirage_client.t (* FIXME *) =
+struct
+  type ctx = Http_mirage_client.t
+
+  module Headers = struct
+    type t = (string * string) list
+
+    let add lst k v = (String.lowercase_ascii k, v) :: lst
+    let init_with k v = [ String.lowercase_ascii k, v ]
+    let get lst k = List.assoc_opt (String.lowercase_ascii k) lst
+    let get_location lst = Option.map Uri.of_string (get lst "location")
+    let to_string = Fmt.to_to_string Fmt.(Dump.list (Dump.pair string string))
+  end
+
+  module Body = struct
+    type t = string
+
+    let to_string = Lwt.return
+    let of_string x = x
+  end
+
+  module Response = struct
+    type t = Http_mirage_client.response
+
+    let status { Http_mirage_client.status; _ } = Http_mirage_client.Status.to_code status
+    let headers { Http_mirage_client.headers; _ } = Http_mirage_client.Headers.to_list headers
+  end
+
+  let get_or_fail msg = function
+    | Some ctx -> ctx
+    | None -> failwith msg
+
+  open Lwt.Infix
+
+  let head ?ctx ?headers uri =
+    let ctx = get_or_fail "http-mirage-client context is required" ctx in
+    Http_mirage_client.request ctx ~meth:`HEAD ?headers (Uri.to_string uri)
+      (fun _response () _str -> Lwt.return_unit)
+      () >>= function
+    | Ok (response, ()) -> Lwt.return response
+    | Error err -> Fmt.failwith "%a" Mimic.pp_error err
+
+  let get ?ctx ?headers uri =
+    let ctx = get_or_fail "http-mirage-client context is required" ctx in
+    Http_mirage_client.request ctx ~meth:`GET ?headers (Uri.to_string uri)
+      (fun _response buf str -> Buffer.add_string buf str; Lwt.return buf)
+      (Buffer.create 0x100) >>= function
+    | Ok (response, buf) -> Lwt.return (response, Buffer.contents buf)
+    | Error err -> Fmt.failwith "%a" Mimic.pp_error err
+
+  let post ?ctx ?body ?chunked:_ ?headers uri =
+    let ctx = get_or_fail "http-mirage-client context is required" ctx in
+    Http_mirage_client.request ctx ~meth:`POST ?body ?headers (Uri.to_string uri)
+      (fun _response buf str -> Buffer.add_string buf str; Lwt.return buf)
+      (Buffer.create 0x100) >>= function
+    | Ok (response, buf) -> Lwt.return (response, Buffer.contents buf)
+    | Error err -> Fmt.failwith "%a" Mimic.pp_error err
+end
+
+module Log = (val let src = Logs.Src.create "letsencrypt.mirage" in
+              Logs.src_log src : Logs.LOG)
+
+module Make (Time : Mirage_time.S) (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 (HTTP)
+
+  let gen_key ?seed ?bits key_type =
+    let seed = Option.map Cstruct.of_string seed in
+    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 = Httpaf.Reqd.request reqd in
+    Log.debug (fun m ->
+        m "Let's encrypt request handler for %a:%d (%s)" Ipaddr.pp ipaddr port
+          req.Httpaf.Request.target) ;
+    match String.split_on_char '/' req.Httpaf.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 headers =
+              Httpaf.Headers.of_list
+                [
+                  ("content-type", "application/octet-stream");
+                  ("content-length", string_of_int (String.length data));
+                ] in
+            let resp = Httpaf.Response.create ~headers `OK in
+            Httpaf.Reqd.respond_with_string reqd resp data
+        | None ->
+            Log.warn (fun m -> m "Token %S not found!" token) ;
+            let headers = Httpaf.Headers.of_list [ ("connection", "close") ] in
+            let resp = Httpaf.Response.create ~headers `Not_found in
+            Httpaf.Reqd.respond_with_string reqd resp "")
+    | _ ->
+        let headers = Httpaf.Headers.of_list [ ("connection", "close") ] in
+        let resp = Httpaf.Response.create ~headers `Not_found in
+        Httpaf.Reqd.respond_with_string reqd resp ""
+
+  let provision_certificate ?(tries = 10) ?(production = false) cfg ctx =
+    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 open Lwt.Infix in
+        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 = Time.sleep_ns (Duration.of_sec sec) in
+        let solver = Letsencrypt.Client.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)) in
+        go tries
+
+  let initialise ~ctx = Acme.initialise ~ctx
+  let sign_certificate ~ctx = Acme.sign_certificate ~ctx
+end

mirage/lE.mli

@@ -0,0 +1,95 @@
+(** {1:Let's encrypt challenge with [paf].}
+
+    [Paf] provides a layer to be able to:
+    1) launch a simple HTTP server which will do the Let's encrypt challenge
+    2) launch a simple HTTP client to ask a new certificate
+
+    The HTTP server must be behind the domain-name for which you want a
+    certificate.
+
+    The usual way to get a certificate is to prepare a {!type:configuration}
+    value, prepare the HTTP server and launch concurrently the server and the
+    client with an ability to stop the server when the client finish the job:
+
+    {[
+      module LE = LE.Make (Time) (Stack)
+
+      let provision ctx =
+        Paf.init ~port:80 (Stack.tcp stackv4v6) >>= fun t ->
+        let service = Paf.http_service
+          ~error_handler:ignore_error
+          (fun _ -> LE.request_handler) in
+        let stop = Lwt_switch.create () in
+        let `Initialized th0 = Paf.serve ~stop service in
+        let th1 =
+          LE.provision_certificate
+            ~production:false
+            configuration
+            ctx 
+          >>= fun certificates ->
+          Lwt_switch.turn_off stop >>= fun () ->
+          Lwt.return certificates in
+        Lwt.both th0 th1 >>= function
+        | ((), Ok certificates) -> ...
+        | ((), Error _) -> ...
+    ]}
+
+    The client requires an {!type:Http_mirage_client.t} to be able to do HTTP
+    requests ([http/1.1] or [h2]) which can be made by
+    {!val:Http_mirage_client.Make.connect}. *)
+
+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 Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) : sig
+  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;
+  }
+
+  val request_handler :
+    Ipaddr.t * int -> Httpaf.Server_connection.request_handler
+
+  val provision_certificate :
+    ?tries:int ->
+    ?production:bool ->
+    configuration ->
+    Http_mirage_client.t ->
+    (Tls.Config.own_cert, [> `Msg of string ]) result Lwt.t
+
+  val initialise :
+    ctx:Http_mirage_client.t ->
+    endpoint:Uri.t ->
+    ?email:string ->
+    X509.Private_key.t ->
+    (Letsencrypt.Client.t, [> `Msg of string ]) result Lwt.t
+  (** [initialise ~ctx ~endpoint ~email priv] constructs a
+      {!type:Letsencrypt.Client.t} by looking up the directory and account of
+      [priv] at [endpoint]. If no account is registered yet, a new account is
+      created with contact information of [email]. The terms of service are
+      agreed on. *)
+
+  val sign_certificate :
+    ctx:Http_mirage_client.t ->
+    Letsencrypt.Client.solver ->
+    Letsencrypt.Client.t ->
+    (int -> unit Lwt.t) ->
+    X509.Signing_request.t ->
+    (X509.Certificate.t list, [> `Msg of string ]) result Lwt.t
+  (** [sign_certificate ~ctx solver t sleep csr] orders a certificate for the
+      names in the signing request [csr], and solves the requested challenges. *)
+end