diff --git a/bin/oacmel.ml b/bin/oacmel.ml index a1b815f..db4adb5 100644 --- a/bin/oacmel.ml +++ b/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 "; ] 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)) diff --git a/letsencrypt-app.opam b/letsencrypt-app.opam index 7639204..a438433 100644 --- a/letsencrypt-app.opam +++ b/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"} diff --git a/letsencrypt-mirage.opam b/letsencrypt-mirage.opam new file mode 100644 index 0000000..c25d144 --- /dev/null +++ b/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 " +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} + "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" diff --git a/mirage/dune b/mirage/dune new file mode 100644 index 0000000..0007153 --- /dev/null +++ b/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)) diff --git a/mirage/lE.ml b/mirage/lE.ml new file mode 100644 index 0000000..724fb73 --- /dev/null +++ b/mirage/lE.ml @@ -0,0 +1,177 @@ +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 = +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 diff --git a/mirage/lE.mli b/mirage/lE.mli new file mode 100644 index 0000000..2d2969c --- /dev/null +++ b/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 diff --git a/mirage/lE_http_server.ml b/mirage/lE_http_server.ml new file mode 100644 index 0000000..655c05f --- /dev/null +++ b/mirage/lE_http_server.ml @@ -0,0 +1,142 @@ +open Lwt.Infix + +let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt + +let pp_error ppf = function + | #Httpaf.Status.t as code -> Httpaf.Status.pp_hum ppf code + | `Exn exn -> Fmt.pf ppf "exception %s" (Printexc.to_string exn) + +module Make + (Time : Mirage_time.S) + (Stack : Tcpip.Stack.V4V6) + (Random : Mirage_random.S) + (Mclock : Mirage_clock.MCLOCK) + (Pclock : Mirage_clock.PCLOCK) = +struct + module Paf = Paf_mirage.Make (Stack.TCP) + module LE = LE.Make (Time) (Stack) + + let get_certificates ~yes_my_port_80_is_reachable_and_unused:stackv4v6 + ~production config http = + Paf.init ~port:80 (Stack.tcp stackv4v6) >>= fun t -> + let `Initialized web_server, stop_web_server = + let request_handler _ = LE.request_handler in + let error_handler _dst ?request err _ = + Logs.err (fun m -> + m "error %a while processing request %a" pp_error err + Fmt.(option ~none:(any "unknown") Httpaf.Request.pp_hum) + request) in + let stop = Lwt_switch.create () in + (Paf.serve ~stop (Paf.http_service ~error_handler request_handler) t, stop) + in + Logs.info (fun m -> m "listening on 80/HTTP (let's encrypt provisioning)") ; + let provision_certificate = + (* XXX(dinosaure): we assume that [provision_certificate] terminates. + By this way, we are able to stop our web-server and resolve our + [Lwt.both]. *) + LE.provision_certificate ~production config http >>= fun v -> + Lwt_switch.turn_off stop_web_server >>= fun () -> Lwt.return v in + Lwt.both web_server provision_certificate >|= snd + + let redirect config tls_port reqd = + let request = Httpaf.Reqd.request reqd in + let host = + match Httpaf.Headers.get request.Httpaf.Request.headers "host" with + | Some host -> host + | None -> Domain_name.to_string config.LE.hostname in + let response = + let port = if tls_port = 443 then None else Some tls_port in + let uri = + Fmt.str "https://%s%a%s" host + Fmt.(option ~none:nop (fmt ":%d")) + port request.Httpaf.Request.target in + let headers = + Httpaf.Headers.of_list [ ("location", uri); ("connection", "close") ] + in + Httpaf.Response.create ~headers `Moved_permanently in + Httpaf.Reqd.respond_with_string reqd response "" + + let info = + let module R = (val Mimic.repr Paf.tls_protocol) in + let alpn_of_tls_connection (_edn, flow) = + match Paf.TLS.epoch flow with + | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol + | Error _ -> None in + let peer_of_tls_connection (edn, _flow) = edn in + (* XXX(dinosaure): [TLS]/[ocaml-tls] should let us to project the underlying + * [flow] and apply [TCP.dst] on it. + * Actually, we did it with the [TLS] module. *) + let injection (_edn, flow) = R.T flow in + { + Alpn.alpn = alpn_of_tls_connection; + Alpn.peer = peer_of_tls_connection; + Alpn.injection; + } + + let with_lets_encrypt_certificates ?(port = 443) stackv4v6 ~production config + client handler = + let certificates = ref None in + let stop_http_server = Lwt_switch.create () in + let stop_alpn_server = Lwt_switch.create () in + let mutex = Lwt_mutex.create () in + + let rec fill_certificates () = + LE.provision_certificate ~production config client >>= function + | Error _ as err -> + Lwt_switch.turn_off stop_http_server >>= fun () -> + Lwt_switch.turn_off stop_alpn_server >>= fun () -> Lwt.return err + | Ok v -> + Lwt_mutex.with_lock mutex (fun () -> + certificates := Some v ; + Lwt.return_unit) + >>= fun () -> + (* TODO(dinosaure): should we [reneg] all previous connections? *) + Time.sleep_ns (Duration.of_day 80) >>= fill_certificates in + + let handshake tcp = + Lwt_mutex.with_lock mutex (fun () -> Lwt.return !certificates) + >>= function + | None -> Lwt.return_error `No_certificates + | Some certificates -> ( + let cfg = + Tls.Config.server ~alpn_protocols:[ "h2"; "http/1.1" ] ~certificates + () in + Paf.TLS.server_of_flow cfg tcp >>= function + | Ok flow -> Lwt.return_ok (Paf.TCP.dst tcp, flow) + | Error `Closed -> Lwt.return_error (`Write `Closed) + | Error err -> + let err = msgf "%a" Paf.TLS.pp_write_error err in + Paf.TCP.close tcp >>= fun () -> Lwt.return_error err) in + let module R = (val Mimic.repr Paf.tls_protocol) in + let request flow edn reqd protocol = + match flow with + | R.T flow -> handler.Alpn.request flow edn reqd protocol + | _ -> assert false in + + let alpn_service = + Alpn.service info { handler with request } handshake Paf.accept Paf.close + in + let http_service = + let request_handler _ edn reqd = + let request = Httpaf.Reqd.request reqd in + match String.split_on_char '/' request.Httpaf.Request.target with + | [ ""; _p1; _p2; _token ] -> LE.request_handler edn reqd + | _ -> redirect config port reqd in + let error_handler _dst ?request err _ = + Logs.err (fun m -> + m "error %a while processing request %a" pp_error err + Fmt.(option ~none:(any "unknown") Httpaf.Request.pp_hum) + request) in + Paf.http_service ~error_handler request_handler in + + Paf.init ~port:80 (Stack.tcp stackv4v6) >>= fun http -> + Paf.init ~port (Stack.tcp stackv4v6) >>= fun alpn -> + let (`Initialized http_server) = + Paf.serve ~stop:stop_http_server http_service http in + let (`Initialized alpn_server) = + Paf.serve ~stop:stop_alpn_server alpn_service alpn in + Lwt.both (fill_certificates ()) (Lwt.join [ http_server; alpn_server ]) + >>= function + | (Error _ as err), () -> Lwt.return err + | _ -> Lwt.return_ok () +end diff --git a/mirage/lE_http_server.mli b/mirage/lE_http_server.mli new file mode 100644 index 0000000..e38307c --- /dev/null +++ b/mirage/lE_http_server.mli @@ -0,0 +1,50 @@ +(** A simple ALPN server which already resolve Let's encrypt certificates. + + This module is to help the user to launch an ALPN server (and be able to + handle [http/1.1] and [h2] requests) through a TLS certificate provided by + Let's encrypt. The challenge is done {i via} HTTP (unlike the ALPN challenge + offered by Let's encrypt). The [.well-known/*] path is therefore used and + the user should not define such a route. *) + +module Make + (Time : Mirage_time.S) + (Stack : Tcpip.Stack.V4V6) + (Random : Mirage_random.S) + (Mclock : Mirage_clock.MCLOCK) + (Pclock : Mirage_clock.PCLOCK) : sig + val get_certificates : + yes_my_port_80_is_reachable_and_unused:Stack.t -> + production:bool -> + LE.configuration -> + Http_mirage_client.t -> + (Tls.Config.own_cert, [> `Msg of string ]) result Lwt.t + (** [get_certificates ~yes_my_port_80_is_reachable_and_unused ~production cfg + http] tries to resolve the Let's encrypt challenge by initiating an HTTP + server on port 80 and handling requests from it with [ocaml-letsencrypt]. + + This resolution requires that your domain name (requested in the given + [cfg.hostname]) redirects Let's encrypt to this HTTP server. You probably + need to check your DNS configuration. + + The [http] value can be made by {!val:Http_mirage_client.Make.connect} to + be able to launch HTTP requests to Let's encrypt. *) + + module Paf : module type of Paf_mirage.Make (Stack.TCP) + + val with_lets_encrypt_certificates : + ?port:int -> + Stack.t -> + production:bool -> + LE.configuration -> + Http_mirage_client.t -> + (Paf.TLS.flow, Ipaddr.t * int) Alpn.server_handler -> + (unit, [> `Msg of string ]) result Lwt.t + (** [with_lets_encrypt_certificates ?port stackv4v6 ~production cfg http + handler] launches 2 servers: + 1) An HTTP server which handles let's encrypt challenges and redirections + 2) An ALPN server (HTTP/1.1 and H2) servers to the user's request handler + + Every 80 days, the fiber re-askes a new certificate from let's encrypt and + re-update the ALPN server with this new certificate. The HTTP server does + the redirection to the hostname defined into the given [cfg]. *) +end diff --git a/src/letsencrypt.mli b/src/letsencrypt.mli index 0de20c4..419f187 100644 --- a/src/letsencrypt.mli +++ b/src/letsencrypt.mli @@ -11,6 +11,9 @@ val letsencrypt_staging_url : Uri.t val sha256_and_base64 : string -> string +(** The required HTTP client to do the Let's encrypt challenge. *) +module HTTP_client = HTTP_client + (** ACME Client. This module provides client commands.