Merge pull request #219 from hannesm/certify

revise dns_certify with new ACME / let's encrypt in mind

CHANGES.md

@@ -1,3 +1,19 @@
+### v4.4.0 (2020-03-13)
+
+* dns-stub, a new opam package, is a stub resolver #209 @hannesm, review by
+  @cfcs
+* embed IP address of recursive resolver only once #214 @hannesm, fixes #210,
+  review by @cfcs
+* Dns_trie.lookup returns NotAuthoritative if no SOA is present #217 @hannesm,
+  review by @cfcs
+* Secondary server is looked up in trie properly (may be in another zone, which
+  primary is not authoritative for the other zone) #217 @hannesm, review by
+  @cfcs
+* new function Dns.Dnskey.pp_name_key #218 @hannesm, review by @cfcs
+* dns-certify uses new ACME protocol (where the intermediate certificate is
+  part of the issuance process) #219 @hannesm, review by @cfcs
+* dns-certify/dns-tsig/dns-cli: use mirage-crypto #219 @hannesm, review by @cfcs
+
 ### v4.3.1 (2020-01-21)
 
 * server (#207, @hannesm, review by @cfcs)

app/dune

@@ -10,21 +10,21 @@
   (public_name ocertify)
   (package dns-cli)
   (modules ocertify)
-  (libraries dns dns-certify dns-cli bos fpath x509 ptime ptime.clock.os nocrypto nocrypto.unix))
+  (libraries dns dns-certify dns-cli bos fpath x509 ptime ptime.clock.os mirage-crypto-pk mirage-crypto-rng mirage-crypto-rng.unix))
 
 (executable
   (name oupdate)
   (public_name oupdate)
   (package dns-cli)
   (modules oupdate)
-  (libraries dns dns-tsig dns-cli ptime ptime.clock.os nocrypto nocrypto.unix))
+  (libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto mirage-crypto-rng.unix))
 
 (executable
   (name onotify)
   (public_name onotify)
   (package dns-cli)
   (modules onotify)
-  (libraries dns dns-tsig dns-cli ptime ptime.clock.os nocrypto nocrypto.unix))
+  (libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto mirage-crypto-rng.unix))
 
 (executable
   (name ozone)

app/ocertify.ml

@@ -13,24 +13,24 @@ let find_or_generate_key key_filename bits seed =
         | None -> None
         | Some seed ->
           let seed = Cstruct.of_string seed in
-          Some Nocrypto.Rng.(create ~seed (module Generators.Fortuna))
+          Some Mirage_crypto_rng.(create ~seed (module Fortuna))
       in
-      `RSA (Nocrypto.Rsa.generate ?g bits)
+      `RSA (Mirage_crypto_pk.Rsa.generate ?g ~bits ())
     in
     let pem = X509.Private_key.encode_pem key in
     Bos.OS.File.write ~mode:0o600 key_filename (Cstruct.to_string pem) >>= fun () ->
     Ok key
 
 let query_certificate sock public_key fqdn =
-  match Dns_certify.query Nocrypto.Rng.generate public_key fqdn with
+  match Dns_certify.query Mirage_crypto_rng.generate public_key fqdn with
   | Error e -> Error e
   | Ok (out, cb) ->
     Dns_cli.send_tcp sock out;
     let data = Dns_cli.recv_tcp sock in
     cb data
 
 let nsupdate_csr sock host keyname zone dnskey csr =
-  match Dns_certify.nsupdate Nocrypto.Rng.generate Ptime_clock.now ~host ~keyname ~zone dnskey csr with
+  match Dns_certify.nsupdate Mirage_crypto_rng.generate Ptime_clock.now ~host ~keyname ~zone dnskey csr with
   | Error s -> Error s
   | Ok (out, cb) ->
     Dns_cli.send_tcp sock out;
@@ -40,7 +40,7 @@ let nsupdate_csr sock host keyname zone dnskey csr =
     | Error e -> Error (`Msg (Fmt.strf "nsupdate reply error %a" Dns_certify.pp_u_err e))
 
 let jump _ server_ip port hostname more_hostnames dns_key_opt csr key seed bits cert force =
-  Nocrypto_entropy_unix.initialize ();
+  Mirage_crypto_rng_unix.initialize ();
   let fn suffix = function
     | None -> Fpath.(v (Domain_name.to_string hostname) + suffix)
     | Some x -> Fpath.v x
@@ -79,18 +79,18 @@ let jump _ server_ip port hostname more_hostnames dns_key_opt csr key seed bits
       | _ -> Ok ()) >>= fun () ->
   (* strategy: unless force is provided, we can request DNS, and if a
      certificate is present, compare its public key with csr public key *)
-  let write_certificate cert =
-    let cert = X509.Certificate.encode_pem cert in
+  let write_certificate certs =
+    let data = X509.Certificate.encode_pem_multiple certs in
     Bos.OS.File.delete cert_filename >>= fun () ->
-    Bos.OS.File.write cert_filename (Cstruct.to_string cert)
+    Bos.OS.File.write cert_filename (Cstruct.to_string data)
   in
   let sock = Dns_cli.connect_tcp server_ip port in
   (if force then
      Ok true
    else match query_certificate sock public_key hostname with
-     | Ok x ->
+     | Ok (server, chain) ->
        Logs.app (fun m -> m "found cached certificate in DNS");
-       write_certificate x >>| fun () ->
+       write_certificate (server :: chain) >>| fun () ->
        false
      | Error `No_tlsa ->
        Logs.debug (fun m -> m "no TLSA found, sending update");
@@ -119,7 +119,7 @@ let jump _ server_ip port hostname more_hostnames dns_key_opt csr key seed bits
           Logs.err (fun m -> m "error %a while handling TLSA reply (retrying)"
                        Dns_certify.pp_q_err e);
           request (pred retries)
-        | Ok x -> write_certificate x
+        | Ok (server, chain) -> write_certificate (server :: chain)
       in
       request 10) >>| fun () ->
   Logs.app (fun m -> m "success! your certificate is stored in %a (private key %a, csr %a)"

certify/dns_certify.ml

@@ -1,5 +1,44 @@
 open Dns
 
+let tlsa_is usage sel typ t =
+  t.Tlsa.cert_usage = usage &&
+  t.Tlsa.selector = sel &&
+  t.Tlsa.matching_type = typ
+
+let is_csr t =
+  tlsa_is Tlsa.Domain_issued_certificate Tlsa.Private Tlsa.No_hash t
+
+let csr req =
+  let data = X509.Signing_request.encode_der req in
+  {
+    Tlsa.matching_type = Tlsa.No_hash ;
+    cert_usage = Tlsa.Domain_issued_certificate ;
+    selector = Tlsa.Private ;
+    data
+  }
+
+let is_certificate t =
+  tlsa_is Tlsa.Domain_issued_certificate Tlsa.Full_certificate Tlsa.No_hash t
+
+let certificate cert =
+  let data = X509.Certificate.encode_der cert in
+  {
+    Tlsa.matching_type = Tlsa.No_hash ;
+    cert_usage = Tlsa.Domain_issued_certificate ;
+    selector = Tlsa.Full_certificate ;
+    data
+  }
+
+let is_ca_certificate t =
+  tlsa_is Tlsa.CA_constraint Tlsa.Full_certificate Tlsa.No_hash t
+
+let ca_certificate data = {
+  Tlsa.matching_type = Tlsa.No_hash ;
+  cert_usage = Tlsa.CA_constraint ;
+  selector = Tlsa.Full_certificate ;
+  data
+}
+
 let signing_request hostname ?(more_hostnames = []) key =
   let host = Domain_name.to_string hostname in
   let extensions =
@@ -21,9 +60,19 @@ let dns_header rng =
   let id = Randomconv.int16 rng in
   (id, Packet.Flags.empty)
 
+let le_label = "_letsencrypt"
+and p_label = "_tcp"
+
+let is_name name =
+  if Domain_name.count_labels name < 2 then
+    false
+  else
+    Domain_name.(equal_label le_label (get_label_exn name 0) &&
+                 equal_label p_label (get_label_exn name 1))
+
 let letsencrypt_name name =
-  match Domain_name.(prepend_label (raw name) "_tcp") with
-  | Ok name' -> Domain_name.prepend_label name' "_letsencrypt"
+  match Domain_name.(prepend_label (raw name) p_label) with
+  | Ok name' -> Domain_name.prepend_label name' le_label
   | Error e -> Error e
 
 type u_err = [ `Tsig of Dns_tsig.e | `Bad_reply of Packet.mismatch * Packet.t | `Unexpected_reply of Packet.reply ]
@@ -33,17 +82,11 @@ let pp_u_err ppf = function
   | `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res
   | `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r
 
-let nsupdate rng now ~host ~keyname ~zone dnskey csr =
+let nsupdate rng now ~host ~keyname ~zone dnskey request =
   match letsencrypt_name host with
   | Error e -> Error e
   | Ok host ->
-    let tlsa =
-      { Tlsa.cert_usage = Domain_issued_certificate ;
-        selector = Private ;
-        matching_type = No_hash ;
-        data = X509.Signing_request.encode_der csr ;
-      }
-    in
+    let tlsa = csr request in
     let zone = Packet.Question.create zone Soa
     and update =
       let up =
@@ -83,26 +126,39 @@ let pp_q_err ppf = function
   | `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r
   | `No_tlsa -> Fmt.pf ppf "No TLSA record found"
 
+let tlsas_to_certchain host public_key tlsas =
+  let certificates, ca_certificates =
+    Rr_map.Tlsa_set.fold (fun tlsa (certs, cacerts as acc) ->
+        if is_certificate tlsa || is_ca_certificate tlsa then
+          match X509.Certificate.decode_der tlsa.Tlsa.data with
+          | Error (`Msg msg) ->
+            Logs.warn (fun m -> m "couldn't decode tlsa record %a: %s (%a)"
+                          Domain_name.pp host msg
+                          Cstruct.hexdump_pp tlsa.Tlsa.data);
+            acc
+          | Ok cert ->
+            match is_certificate tlsa, is_ca_certificate tlsa with
+            | true, _ -> (cert :: certs, cacerts)
+            | _, true -> (certs, cert :: cacerts)
+            | _ -> acc
+        else acc)
+      tlsas ([], [])
+  in
+  let matches_public_key cert =
+    let key = X509.Certificate.public_key cert in
+    Cstruct.equal (X509.Public_key.id key) (X509.Public_key.id public_key)
+  in
+  match List.find_opt matches_public_key certificates with
+  | None -> Error `No_tlsa
+  | Some server_cert ->
+    match List.rev (X509.Validation.build_paths server_cert ca_certificates) with
+    | (_server :: chain) :: _ -> Ok (server_cert, chain)
+    | _ -> Ok (server_cert, []) (* build_paths always returns the server_cert *)
+
 let query rng public_key host =
   match letsencrypt_name host with
   | Error e -> Error e
   | Ok host ->
-    let good_tlsa tlsa =
-      tlsa.Tlsa.cert_usage = Domain_issued_certificate
-      && tlsa.selector = Full_certificate
-      && tlsa.matching_type = No_hash
-    in
-    let parse tlsa =
-      match X509.Certificate.decode_der tlsa.Tlsa.data with
-      | Ok cert ->
-        let keys_equal a b =
-          Cstruct.equal (X509.Public_key.id a) (X509.Public_key.id b) in
-        if keys_equal (X509.Certificate.public_key cert) public_key then
-          Some cert
-        else
-          None
-      | _ -> None
-    in
     let header = dns_header rng
     and question = Packet.Question.create host Tlsa
     in
@@ -116,11 +172,7 @@ let query rng public_key host =
         | Ok (`Answer (answer, _)) ->
           begin match Name_rr_map.find host Tlsa answer with
             | None -> Error `No_tlsa
-            | Some (_, tlsas) ->
-              Rr_map.Tlsa_set.(fold (fun tlsa r ->
-                  match parse tlsa, r with Some c, _ -> Ok c | None, x -> x)
-                  (filter good_tlsa tlsas)
-                  (Error `No_tlsa))
+            | Some (_, tlsas) -> tlsas_to_certchain host public_key tlsas
           end
         | Ok (`Rcode_error (Rcode.NXDomain, Opcode.Query, _)) -> Error `No_tlsa
         | Ok reply -> Error (`Unexpected_reply reply)

certify/dns_certify.mli

@@ -13,6 +13,34 @@ val letsencrypt_name : 'a Domain_name.t ->
 (** [letsencrypt_name host] is the service name at which we store let's encrypt
     certificates for the [host]. *)
 
+val is_csr : Dns.Tlsa.t -> bool
+(** [is_csr tlsa] is true if [tlsa] is a certificate signing request (cert_usage
+    is Domain_issued_certificate, selector is Private, and matching_type is
+    No_hash). *)
+
+val csr : X509.Signing_request.t -> Dns.Tlsa.t
+(** [csr req] is the signing request [req] encoded as TLSA record. *)
+
+val is_certificate : Dns.Tlsa.t -> bool
+(** [is_certificate tlsa] is true if [tlsa] is a certificate (cert_usage is
+    Domain_issued_certificate, selector is Full_certificate, and matching_type
+    is No_hash). *)
+
+val certificate : X509.Certificate.t -> Dns.Tlsa.t
+(** [certificate crt] is the certificate [crt] encoded as TLSA record. *)
+
+val is_ca_certificate : Dns.Tlsa.t -> bool
+(** [is_ca_certificate tlsa] is true if [tlsa] is a CA certificate (cert_usage
+    is CA_constraint, selector is Full_certificate, and matching_type is
+    No_hash). *)
+
+val ca_certificate : Cstruct.t -> Dns.Tlsa.t
+(** [ca_certificate data] is the CA certificate [data] encoded as TLSA record. *)
+
+val is_name : 'a Domain_name.t -> bool
+(** [is_name domain_name] is true if it contains the prefix used in this
+    library ("_letsencrypt._tcp"). *)
+
 type u_err = [
   | `Tsig of Dns_tsig.e
   | `Bad_reply of Packet.mismatch * Packet.t
@@ -33,8 +61,8 @@ val nsupdate : (int -> Cstruct.t) -> (unit -> Ptime.t) ->
    TLSA record containing the certificate signing request. It also returns a
    function which decodes a given answer, checks it to be a valid reply, and
    returns either unit or an error. The outgoing packet is signed with the
-    provided [dnskey], the answer is checked to be signed by the same key. If
-    the sign operation fails, [nsupdate] returns an error. *)
+   provided [dnskey], the answer is checked to be signed by the same key. If
+   the sign operation fails, [nsupdate] returns an error. *)
 
 type q_err = [
   | `Decode of Packet.err
@@ -49,8 +77,9 @@ val pp_q_err : q_err Fmt.t
 
 val query : (int -> Cstruct.t) -> X509.Public_key.t ->
   [ `host ] Domain_name.t ->
-  (Cstruct.t * (Cstruct.t -> (X509.Certificate.t, [> q_err ]) result),
+  (Cstruct.t *
+   (Cstruct.t -> (X509.Certificate.t * X509.Certificate.t list, [> q_err ]) result),
    [> `Msg of string ]) result
 (** [query rng pubkey name] is a [buffer] with a DNS TLSA query for the given
    [name], and a function that decodes a given answer, either returning a X.509
-   certificate or an error. *)
+   certificate and a chain, or an error. *)

certify/dune

@@ -2,4 +2,4 @@
  (name dns_certify)
  (public_name dns-certify)
  (wrapped false)
- (libraries dns dns-tsig x509 randomconv))
+ (libraries dns dns-tsig x509 randomconv logs))

dns-certify.opam

@@ -15,13 +15,14 @@ depends: [
   "dns-mirage" {= version}
   "randomconv" {>= "0.1.2"}
   "duration" {>= "0.1.2"}
-  "x509" {>= "0.8.0"}
+  "x509" {>= "0.10.0"}
   "lwt" {>= "4.2.1"}
-  "tls" {>= "0.10.3"}
+  "tls" {>= "0.11.0"}
   "mirage-random" {>= "2.0.0"}
   "mirage-time" {>= "2.0.0"}
   "mirage-clock" {>= "3.0.0"}
   "mirage-stack" {>= "2.0.0"}
+  "logs"
 ]
 
 build: [

dns-cli.opam

@@ -19,8 +19,9 @@ depends: [
   "bos" {>= "0.2.0"}
   "cmdliner" {>= "1.0.0"}
   "fpath" {>= "0.7.2"}
-  "x509" {>= "0.8.0"}
-  "nocrypto" {>= "0.5.4"}
+  "x509" {>= "0.10.0"}
+  "mirage-crypto"
+  "mirage-crypto-rng"
   "hex" {>= "1.4.0"}
   "ptime" {>= "0.8.5"}
   "mtime" {>= "1.2.0"}

dns-server.opam

@@ -18,7 +18,7 @@ depends: [
   "mirage-time" {>= "2.0.0"}
   "mirage-clock" {>= "3.0.0"}
   "mirage-stack" {>= "2.0.0"}
-  "nocrypto" {with-test}
+  "mirage-crypto-rng" {with-test}
   "alcotest" {with-test}
   "dns-tsig" {with-test}
   "metrics"

dns-tsig.opam

@@ -11,7 +11,8 @@ depends: [
   "dune" {>= "1.2.0"}
   "ocaml" {>= "4.07.0"}
   "dns" {= version}
-  "nocrypto" {>= "0.5.4"}
+  "mirage-crypto"
+  "base64" {>= "3.0.0"}
   "alcotest" {with-test}
 ]