unikernel/duniverse/ocaml-dns/certify/dns_certify.ml

@@ -0,0 +1,207 @@
+open Dns
+
+let src = Logs.Src.create "dns_certify" ~doc:"DNS certify"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+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 =
+    match more_hostnames with
+    | [] -> X509.Signing_request.Ext.empty
+    | _ ->
+      let ext =
+        let additional = List.map Domain_name.to_string more_hostnames in
+        let gn = X509.General_name.(singleton DNS (host :: additional)) in
+        X509.Extension.(singleton Subject_alt_name (false, gn))
+      in
+      X509.Signing_request.Ext.(singleton Extensions ext)
+  in
+  X509.(Signing_request.create
+          [Distinguished_name.(Relative_distinguished_name.singleton (CN host))]
+          ~extensions key)
+
+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) 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 ]
+
+let pp_u_err ppf = function
+  | `Tsig e -> Fmt.pf ppf "tsig error %a" Dns_tsig.pp_e e
+  | `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 request =
+  match letsencrypt_name host with
+  | Error e -> Error e
+  | Ok host ->
+    let tlsa = csr request in
+    let zone = Packet.Question.create zone Soa
+    and update =
+      let up =
+        Domain_name.Map.singleton host
+          [
+            Packet.Update.Remove (K Tlsa) ;
+            Packet.Update.Add (B (Tlsa, (3600l, Rr_map.Tlsa_set.singleton tlsa)))
+          ]
+      in
+      (Domain_name.Map.empty, up)
+    and header = dns_header rng
+    in
+    let packet = Packet.create header zone (`Update update) in
+    let now = now () in
+    match Dns_tsig.encode_and_sign ~proto:`Tcp packet now dnskey keyname with
+    | Error e -> Error (`Msg (Fmt.to_to_string Dns_tsig.pp_s e))
+    | Ok (data, mac) ->
+      Ok (data, (fun data ->
+          match Dns_tsig.decode_and_verify now dnskey keyname ~mac data with
+          | Error e -> Error (`Tsig e)
+          | Ok (res, _, _) ->
+            match Packet.reply_matches_request ~request:packet res with
+            | Ok `Update_ack -> Ok ()
+            | Ok r -> Error (`Unexpected_reply r)
+            | Error e -> Error (`Bad_reply (e, res))))
+
+type q_err = [
+  | `Decode of Packet.err
+  | `Bad_reply of Packet.mismatch * Packet.t
+  | `Unexpected_reply of Packet.reply
+  | `No_tlsa
+]
+
+let pp_q_err ppf = function
+  | `Decode err -> Fmt.pf ppf "decoding failed %a" Packet.pp_err err
+  | `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
+  | `No_tlsa -> Fmt.pf ppf "No TLSA record found"
+
+(* may be better suited in X509? *)
+let cert_matches_csr ?until now csr cert =
+  let until = match until with None -> now | Some x -> x in
+  let csr_key = X509.Signing_request.((info csr).public_key)
+  and csr_hostnames = X509.Signing_request.hostnames csr
+  and cert_key = X509.Certificate.public_key cert
+  and cert_hostnames = X509.Certificate.hostnames cert
+  and (st, en) = X509.Certificate.validity cert
+  in
+  let valid = Ptime.is_later ~than:st now && Ptime.is_later ~than:until en in
+  if not (String.equal (X509.Public_key.fingerprint cert_key) (X509.Public_key.fingerprint csr_key)) then begin
+    Log.info (fun m -> m "public key of CSR and certificate %a do not match"
+                 X509.Certificate.pp cert);
+    false
+  end else if not (X509.Host.Set.equal cert_hostnames csr_hostnames) then begin
+    Log.info (fun m -> m "hostnames of CSR %a and certificate %a do not match"
+                 X509.Host.Set.pp csr_hostnames X509.Host.Set.pp cert_hostnames);
+    false
+  end else if not valid then begin
+    let pp_pt = Ptime.pp_rfc3339 () in
+    Log.info (fun m -> m "Certificate is not valid now %a (until %a), it is \
+                          valid from %a until %a)"
+                 pp_pt now pp_pt until pp_pt st pp_pt en);
+    false
+  end else
+    true
+
+let tlsas_to_certchain host now csr 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) ->
+            Log.warn (fun m -> m "couldn't decode tlsa record %a: %s (%a)"
+                         Domain_name.pp host msg
+                         Ohex.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
+  match List.find_opt (cert_matches_csr now csr) 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 now host csr =
+  match letsencrypt_name host with
+  | Error e -> Error e
+  | Ok host ->
+    let header = dns_header rng
+    and question = Packet.Question.create host Tlsa
+    in
+    let request = Packet.create header question `Query in
+    let out, _ = Packet.encode `Tcp request
+    and react data =
+      match Packet.decode data with
+      | Error e -> Error (`Decode e)
+      | Ok reply ->
+        match Packet.reply_matches_request ~request reply with
+        | Ok (`Answer (answer, _)) ->
+          begin match Name_rr_map.find host Tlsa answer with
+            | None -> Error `No_tlsa
+            | Some (_, tlsas) -> tlsas_to_certchain host now csr tlsas
+          end
+        | Ok (`Rcode_error (Rcode.NXDomain, Opcode.Query, _)) -> Error `No_tlsa
+        | Ok reply -> Error (`Unexpected_reply reply)
+        | Error e -> Error (`Bad_reply (e, reply))
+    in
+    Ok (out, react)

unikernel/duniverse/ocaml-dns/certify/dns_certify.mli

@@ -0,0 +1,93 @@
+open Dns
+
+val signing_request : [`host] Domain_name.t ->
+  ?more_hostnames:([`raw] Domain_name.t list) ->
+  X509.Private_key.t -> (X509.Signing_request.t, [> `Msg of string ]) result
+(** [signing_request name ~more_hostnames key] creates a X509 signing request
+    where [name] will be the common name in its subject, and if [more_hostnames]
+    is provided and non-empty, [name :: more_hostnames] will be the value of a
+    subjectAlternativeName extension. *)
+
+val letsencrypt_name : 'a Domain_name.t ->
+  ([ `raw ] Domain_name.t, [> `Msg of string ]) result
+(** [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 : string -> 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
+  | `Unexpected_reply of Packet.reply
+]
+(** The type of update errors. *)
+
+val pp_u_err : u_err Fmt.t
+(** [pp_u_err ppf u] pretty-prints [u] on [ppf]. *)
+
+val nsupdate : (int -> string) -> (unit -> Ptime.t) ->
+  host:[ `host ] Domain_name.t -> keyname:'b Domain_name.t ->
+  zone:[ `host ] Domain_name.t -> Dns.Dnskey.t -> X509.Signing_request.t ->
+  (string * (string -> (unit, [> u_err ]) result),
+   [> `Msg of string ]) result
+(** [nsupdate rng now ~host ~keyname ~zone dnskey csr] is a buffer with a DNS
+   update that removes all TLSA records from the given [host], and adds a single
+   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. *)
+
+type q_err = [
+  | `Decode of Packet.err
+  | `Bad_reply of Packet.mismatch * Packet.t
+  | `Unexpected_reply of Packet.reply
+  | `No_tlsa
+]
+(** The type for query errors. *)
+
+val pp_q_err : q_err Fmt.t
+(** [pp_q_err ppf q] pretty-prints [q] on [ppf]. *)
+
+val cert_matches_csr : ?until:Ptime.t -> Ptime.t -> X509.Signing_request.t ->
+  X509.Certificate.t -> bool
+(** [cert_matches_csr ~until now csr cert] is [true] if [cert] matches the
+    signing request [csr], and is valid from [now] until [until] (defaults to
+    [now]). The matching is [true] if the public key matches, and the set of
+    hostnames in [csr] and [cert] are equal. A log message on the info level
+    is emitted if the return value if [false]. *)
+
+val query : (int -> string) -> Ptime.t -> [ `host ] Domain_name.t ->
+  X509.Signing_request.t ->
+  (string *
+   (string -> (X509.Certificate.t * X509.Certificate.t list, [> q_err ]) result),
+   [> `Msg of string ]) result
+(** [query rng now csr] is a [buffer] with a DNS TLSA query for the name of
+   [csr], and a function that decodes a given answer, either returning a X.509
+   certificate valid [now] and matching [csr], and a CA chain, or an error. *)

unikernel/duniverse/ocaml-dns/certify/dune

@@ -0,0 +1,5 @@
+(library
+ (name dns_certify)
+ (public_name dns-certify)
+ (wrapped false)
+ (libraries dns dns-tsig x509 randomconv logs mirage-crypto-ec mirage-crypto-pk))