unikernel/duniverse/ocaml-dns/app/dns_cli.ml

@@ -0,0 +1,110 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+let reporter_with_ts ~dst () =
+  let pp_tags f tags =
+    let pp tag () =
+      let (Logs.Tag.V (def, value)) = tag in
+      Format.fprintf f " %s=%a" (Logs.Tag.name def) (Logs.Tag.printer def) value;
+      ()
+    in
+    Logs.Tag.fold pp tags ()
+  in
+  let report src level ~over k msgf =
+    let tz_offset_s = Ptime_clock.current_tz_offset_s () in
+    let posix_time = Ptime_clock.now () in
+    let src = Logs.Src.name src in
+    let k _ =
+      over ();
+      k ()
+    in
+    msgf @@ fun ?header ?tags fmt ->
+    Format.kfprintf k dst
+      ("%a:%a %a [%s] @[" ^^ fmt ^^ "@]@.")
+      (Ptime.pp_rfc3339 ?tz_offset_s ())
+      posix_time
+      Fmt.(option ~none:(any "") pp_tags)
+      tags Logs_fmt.pp_header (level, header) src
+  in
+  { Logs.report }
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (reporter_with_ts ~dst:Format.std_formatter ())
+
+let connect_tcp ip port =
+  let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
+  let fam = match ip with Ipaddr.V4 _ -> Unix.PF_INET | Ipaddr.V6 _ -> Unix.PF_INET6 in
+  let sock = Unix.(socket fam SOCK_STREAM 0) in
+  Unix.(setsockopt sock SO_REUSEADDR true) ;
+  Unix.connect sock sa ;
+  sock
+
+(* TODO EINTR, SIGPIPE *)
+let send_tcp sock buf =
+  let size = String.length buf in
+  let size_buf =
+    let b = Bytes.create 2 in
+    Bytes.set_int16_be b 0 size ;
+    b
+  in
+  let data = Bytes.cat size_buf (Bytes.of_string buf) in
+  let whole = size + 2 in
+  let rec out off =
+    if off = whole then ()
+    else
+      let bytes = Unix.send sock data off (whole - off) [] in
+      out (bytes + off)
+  in
+  out 0
+
+let recv_tcp sock =
+  let rec read_exactly buf len off =
+    if off = len then ()
+    else
+      let n = Unix.recv sock buf off (len - off) [] in
+      read_exactly buf len (off + n)
+  in
+  let buf = Bytes.create 2 in
+  read_exactly buf 2 0 ;
+  let len = Bytes.get_int16_be buf 0 in
+  let buf' = Bytes.create len in
+  read_exactly buf' len 0 ;
+  Bytes.unsafe_to_string buf'
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let ip_c = Arg.conv (Ipaddr.of_string, Ipaddr.pp)
+
+let namekey_c =
+  let parse s =
+    let ( let* ) = Result.bind in
+    let* (name, key) = Dns.Dnskey.name_key_of_string s in
+    let is_op s =
+      Domain_name.(equal_label s "_update" || equal_label s "_transfer" || equal_label s "_notify")
+    in
+    let amount = match Domain_name.find_label ~rev:true name is_op with
+      | None -> 0
+      | Some x -> succ x
+    in
+    let* zone = Domain_name.drop_label ~amount name in
+    let* zone = Domain_name.host zone in
+    Ok (name, zone, key)
+  in
+  let pp ppf (name, zone, key) =
+    Fmt.pf ppf "key name %a zone %a dnskey %a"
+      Domain_name.pp name Domain_name.pp zone Dns.Dnskey.pp key
+  in
+  Arg.conv (parse, pp)
+
+let name_c =
+  Arg.conv
+    ((fun s -> Result.bind (Domain_name.of_string s) Domain_name.host),
+     Domain_name.pp)
+
+let domain_name_c =
+  Arg.conv (Domain_name.of_string, Domain_name.pp)

unikernel/duniverse/ocaml-dns/app/dune

@@ -0,0 +1,57 @@
+(library
+ (name dns_cli)
+ (public_name dns-cli)
+ (wrapped false)
+ (modules dns_cli)
+ (libraries dns cmdliner ptime.clock.os logs.fmt fmt.cli logs.cli fmt.tty ipaddr.unix))
+
+(executable
+  (name ocertify)
+  (public_name ocertify)
+  (package dns-cli)
+  (modules ocertify)
+  (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 mirage-crypto-rng mirage-crypto-rng.unix randomconv))
+
+(executable
+  (name onotify)
+  (public_name onotify)
+  (package dns-cli)
+  (modules onotify)
+  (libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto-rng mirage-crypto-rng.unix randomconv))
+
+(executable
+  (name ozone)
+  (public_name ozone)
+  (package dns-cli)
+  (modules ozone)
+  (libraries dns dns-cli dns-server.zone dns-server bos))
+
+(executable
+  (name         odns)
+  (public_name  odns)
+  (modules      odns)
+  (package      dns-cli)
+  (libraries    dns dns-client-lwt dns-cli cmdliner mtime.clock.os
+                lwt.unix ohex bos))
+
+(executable
+  (name         odnssec)
+  (public_name  odnssec)
+  (modules      odnssec)
+  (package      dns-cli)
+  (libraries    dns dns-client-lwt dns-cli cmdliner mtime.clock.os
+                lwt.unix dnssec))
+
+(executable
+  (name         resolver)
+  (public_name  resolver)
+  (modules      resolver)
+  (package      dns-cli)
+  (libraries    dns-cli dns-resolver dns-resolver.mirage lwt.unix tcpip.stack-socket mirage-mtime.unix logs.fmt mirage-crypto-rng.unix))

unikernel/duniverse/ocaml-dns/app/ocertify.ml

@@ -0,0 +1,205 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+let ( let* ) = Result.bind
+
+let find_or_generate_key key_filename keytype keydata seed bits =
+  let* f_exists = Bos.OS.File.exists key_filename in
+  if f_exists then
+    let* data = Bos.OS.File.read key_filename in
+    X509.Private_key.decode_pem data
+  else
+    let* key =
+      match keydata with
+      | None -> Ok (X509.Private_key.generate ?seed ~bits keytype)
+      | Some s ->
+        let* s = Base64.decode s in
+        X509.Private_key.of_octets s keytype
+    in
+    let pem = X509.Private_key.encode_pem key in
+    let* () = Bos.OS.File.write ~mode:0o600 key_filename pem in
+    Ok key
+
+let query_certificate sock fqdn csr =
+  match Dns_certify.query Mirage_crypto_rng.generate (Ptime_clock.now ()) fqdn csr 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 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;
+    let data = Dns_cli.recv_tcp sock in
+    match cb data with
+    | Ok () -> Ok ()
+    | Error e -> Error (`Msg (Fmt.str "nsupdate reply error %a" Dns_certify.pp_u_err e))
+
+let jump _ server_ip port hostname more_hostnames dns_key_opt csr key keytype keydata seed bits cert force =
+  Mirage_crypto_rng_unix.use_default ();
+  let fn suffix = function
+    | None -> Fpath.(v (Domain_name.to_string hostname) + suffix)
+    | Some x -> Fpath.v x
+  in
+  let csr_filename = fn "req" csr
+  and key_filename = fn "key" key
+  and cert_filename = fn "pem" cert
+  in
+  let* csr =
+    let* f_exists = Bos.OS.File.exists csr_filename in
+    if f_exists then
+      let* data = Bos.OS.File.read csr_filename in
+      X509.Signing_request.decode_pem data
+    else
+      let* key = find_or_generate_key key_filename keytype keydata seed bits in
+      let* csr = Dns_certify.signing_request hostname ~more_hostnames key in
+      let pem = X509.Signing_request.encode_pem csr in
+      let* () = Bos.OS.File.write csr_filename pem in
+      Ok csr
+  in
+  (* before doing anything, let's check whether cert_filename is present,
+     the public key matches, and the certificate is still valid *)
+  let now = Ptime_clock.now () in
+  let tomorrow =
+    let (d, ps) = Ptime.Span.to_d_ps (Ptime.to_span now) in
+    Ptime.v (succ d, ps)
+  in
+  let* cert =
+    let* f_exists = Bos.OS.File.exists cert_filename in
+    if f_exists then
+      let* data = Bos.OS.File.read cert_filename in
+      let* certs = X509.Certificate.decode_pem_multiple data in
+      match List.filter (fun c -> X509.Certificate.supports_hostname c hostname) certs with
+      | [] -> Ok None
+      | [ cert ] -> Ok (Some cert)
+      | _ -> Error (`Msg "multiple certificates that match the hostname")
+    else
+      Ok None
+  in
+  let* () =
+    match cert with
+    | Some cert ->
+      if not force && Dns_certify.cert_matches_csr ~until:tomorrow now csr cert then
+        Error (`Msg "valid certificate with matching key already present")
+      else
+        Ok ()
+    | None -> Ok ()
+  in
+  (* 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 certs =
+    let data = X509.Certificate.encode_pem_multiple certs in
+    let* () = Bos.OS.File.delete cert_filename in
+    Bos.OS.File.write cert_filename data
+  in
+  let sock = Dns_cli.connect_tcp server_ip port in
+  let* should_update =
+    if force then
+      Ok true
+    else match query_certificate sock hostname csr with
+      | Ok (server, chain) ->
+        Logs.app (fun m -> m "found cached certificate in DNS");
+        let* () = write_certificate (server :: chain) in
+        Ok false
+      | Error `No_tlsa ->
+        Logs.debug (fun m -> m "no TLSA found, sending update");
+        Ok true
+      | Error (`Msg m) -> Error (`Msg m)
+      | Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) ->
+        Error (`Msg (Fmt.str "error %a while parsing TLSA reply"
+                       Dns_certify.pp_q_err e))
+  in
+  if not should_update then
+    Ok ()
+  else
+    let* () =
+      match dns_key_opt with
+      | None -> Error (`Msg "no dnskey provided, but required for uploading CSR")
+      | Some (keyname, zone, dnskey) ->
+        let* () = nsupdate_csr sock hostname keyname zone dnskey csr in
+        let rec request retries =
+          match query_certificate sock hostname csr with
+          | Error (`Msg msg) -> Error (`Msg msg)
+          | Error #Dns_certify.q_err when retries = 0 ->
+            Error (`Msg "failed to retrieve certificate (tried 10 times)")
+          | Error `No_tlsa ->
+            Logs.warn (fun m -> m "still no tlsa, sleeping two more seconds");
+            Unix.sleep 2;
+            request (pred retries)
+          | Error (#Dns_certify.q_err as e) ->
+            Logs.err (fun m -> m "error %a while handling TLSA reply (retrying)"
+                         Dns_certify.pp_q_err e);
+            request (pred retries)
+          | Ok (server, chain) -> write_certificate (server :: chain)
+        in
+        request 10
+    in
+    Logs.app (fun m -> m "success! your certificate is stored in %a (private key %a, csr %a)"
+                 Fpath.pp cert_filename Fpath.pp key_filename Fpath.pp csr_filename);
+    Ok ()
+
+open Cmdliner
+
+let dns_server =
+  let doc = "DNS server IP" in
+  Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"IP")
+
+let port =
+  let doc = "Port to connect to" in
+  Arg.(value & opt int 53 & info [ "port" ] ~doc)
+
+let dns_key =
+  let doc = "nsupdate key (name:alg:b64key, where name is YYY._update.zone)" in
+  Arg.(value & opt (some Dns_cli.namekey_c) None & info [ "dns-key" ] ~doc ~docv:"KEY")
+
+let hostname =
+  let doc = "Hostname (FQDN) to issue a certificate for" in
+  Arg.(required & pos 1 (some Dns_cli.name_c) None & info [] ~doc ~docv:"HOSTNAME")
+
+let more_hostnames =
+  let doc = "Additional hostnames to be included in the certificate as SubjectAlternativeName extension" in
+  Arg.(value & opt_all Dns_cli.domain_name_c [] & info ["additional"] ~doc ~docv:"HOSTNAME")
+
+let csr =
+  let doc = "certificate signing request filename (defaults to hostname.req)" in
+  Arg.(value & opt (some string) None & info [ "csr" ] ~doc)
+
+let key =
+  let doc = "private key filename (default to hostname.key)" in
+  Arg.(value & opt (some string) None & info [ "key" ] ~doc)
+
+let seed =
+  let doc = "private key seed (or full private key if keytype is a EC key)" in
+  Arg.(value & opt (some string) None & info [ "seed" ] ~doc)
+
+let bits =
+  let doc = "private key bits" in
+  Arg.(value & opt int 4096 & info [ "bits" ] ~doc)
+
+let keydata =
+  let doc = "private key (base64 encoded)" in
+  Arg.(value & opt (some string) None & info [ "data" ] ~doc)
+
+let keytype =
+  let doc = "keytype to generate" in
+  Arg.(value & opt (enum X509.Key_type.strings) `RSA & info [ "type" ] ~doc)
+
+let cert =
+  let doc = "certificate filename (defaults to hostname.pem)" in
+  Arg.(value & opt (some string) None & info [ "certificate" ] ~doc)
+
+let force =
+  let doc = "force signing request to DNS" in
+  Arg.(value & flag & info [ "force" ] ~doc)
+
+let ocertify =
+  let doc = "ocertify requests a signed certificate" in
+  let man = [ `S "BUGS"; `P "Submit bugs to me";] in
+  let term =
+    Term.(term_result (const jump $ Dns_cli.setup_log $ dns_server $ port $ hostname $ more_hostnames $ dns_key $ csr $ key $ keytype $ keydata $ seed $ bits $ cert $ force))
+  and info = Cmd.info "ocertify" ~version:"10.2.2" ~doc ~man
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval ocertify)

unikernel/duniverse/ocaml-dns/app/odns.ml

@@ -0,0 +1,433 @@
+(* odns client utility. *)
+(* RFC 768  DNS over UDP *)
+(* RFC 7766 DNS over TCP: https://tools.ietf.org/html/rfc7766 *)
+(* RFC 6698 DANE: https://tools.ietf.org/html/rfc6698*)
+
+let pp_zone ppf (domain,query_type,query_value) =
+  (* TODO dig also prints 'IN' after the TTL, we don't... *)
+  Fmt.string ppf
+    (Dns.Rr_map.text_b domain (Dns.Rr_map.B (query_type, query_value)))
+
+let pp_zone_tlsa ppf (domain,ttl,(tlsa:Dns.Tlsa.t)) =
+  (* TODO this implementation differs a bit from Dns_map.text and tries to
+     follow the `dig` output to make it easier to port existing scripts *)
+  Fmt.pf ppf "%a.\t%ld\tIN\t%d\t%d\t%d\t%s"
+    Domain_name.pp domain
+    ttl
+    (Dns.Tlsa.cert_usage_to_int tlsa.cert_usage)
+    (Dns.Tlsa.selector_to_int tlsa.selector)
+    (Dns.Tlsa.matching_type_to_int tlsa.matching_type)
+    ( (* this produces output similar to `dig`, splitting the hex string
+         in chunks of 56 chars (28 bytes): *)
+      let hex = Ohex.decode tlsa.data in
+      let hlen = String.length hex in
+      let rec loop acc = function
+        | n when n + 56 >= hlen ->
+          String.concat " " (List.rev (String.sub hex n (hlen-n)::acc))
+          |> String.uppercase_ascii
+        | n -> loop ((String.sub hex n 56)::acc) (n+56)
+      in loop [] 0)
+
+let pp_nameserver ppf = function
+  | `Plaintext (ip, port) -> Fmt.pf ppf "TCP %a:%d" Ipaddr.pp ip port
+  | `Tls (tls_cfg, ip, port) ->
+    Fmt.pf ppf "TLS %a:%d%a" Ipaddr.pp ip port
+      Fmt.(option ~none:(any "") (append (any "#") Domain_name.pp))
+      ((Tls.Config.of_client tls_cfg).Tls.Config.peer_name)
+
+let do_a nameservers domains () =
+  let happy_eyeballs = Happy_eyeballs_lwt.create () in
+  let t = Dns_client_lwt.create ?nameservers happy_eyeballs in
+  let (_, ns) = Dns_client_lwt.nameservers t in
+  Logs.info (fun m -> m "querying NS %a for A records of %a"
+                pp_nameserver (List.hd ns) Fmt.(list ~sep:(any ", ") Domain_name.pp) domains);
+  let job =
+    Lwt_list.iter_p (fun domain ->
+        let open Lwt in
+        Logs.debug (fun m -> m "looking up %a" Domain_name.pp domain);
+        Dns_client_lwt.(getaddrinfo t A domain)
+        >|= function
+        | Ok (_ttl, addrs) when Ipaddr.V4.Set.is_empty addrs ->
+          (* handle empty response? *)
+          Logs.app (fun m -> m ";%a. IN %a"
+                       Domain_name.pp domain
+                       Dns.Rr_map.ppk (Dns.Rr_map.K A))
+        | Ok resp ->
+          Logs.app (fun m -> m "%a" pp_zone (domain, A, resp))
+        | Error (`Msg msg) ->
+          Logs.err (fun m -> m "Failed to lookup %a: %s\n"
+                       Domain_name.pp domain msg)
+      ) domains
+  in
+  match Lwt_main.run job with
+  | () -> Ok () (* TODO handle errors *)
+
+let for_all_domains nameservers ~domains typ f =
+  (* [for_all_domains] is a utility function that lets us avoid duplicating
+     this block of code in all the subcommands.
+     We leave {!do_a} simple to provide a more readable example. *)
+  let happy_eyeballs = Happy_eyeballs_lwt.create () in
+  let t = Dns_client_lwt.create ?nameservers happy_eyeballs in
+  let _, ns = Dns_client_lwt.nameservers t in
+  Logs.info (fun m -> m "NS: %a" pp_nameserver (List.hd ns));
+  let open Lwt in
+  match
+    Lwt_main.run
+      (Lwt_list.iter_p
+         (fun domain ->
+            Dns_client_lwt.getaddrinfo t typ domain >|= function
+            | Error `Msg msg ->
+              Logs.err (fun m ->
+                  m "Failed to lookup %a for %a: %s\n%!"
+                    Dns.Rr_map.ppk (Dns.Rr_map.K typ)
+                    Domain_name.pp domain msg) ;
+              ()
+            | Ok x -> f domain x)
+         domains)
+  with
+  | () -> Ok () (* TODO catch failed jobs *)
+
+let output_response typ domain resp =
+  Logs.app (fun m -> m "%a" pp_zone (domain, typ, resp))
+
+let do_aaaa nameserver domains () =
+  for_all_domains nameserver ~domains Dns.Rr_map.Aaaa
+    (output_response Dns.Rr_map.Aaaa)
+
+let do_mx nameserver domains () =
+  for_all_domains nameserver ~domains Dns.Rr_map.Mx
+    (output_response Dns.Rr_map.Mx)
+
+let do_tlsa nameserver domains () =
+  for_all_domains nameserver ~domains Dns.Rr_map.Tlsa
+    (fun domain (ttl, tlsa_resp) ->
+       Dns.Rr_map.Tlsa_set.iter (fun tlsa ->
+           Logs.app (fun m -> m "%a" pp_zone_tlsa (domain, ttl, tlsa))
+         ) tlsa_resp)
+
+
+let do_txt nameserver domains () =
+  for_all_domains nameserver ~domains Dns.Rr_map.Txt
+    (fun _domain (ttl, txtset) ->
+       Dns.Rr_map.Txt_set.iter (fun txtrr ->
+           Logs.app (fun m -> m "%ld: @[<v>%s@]" ttl txtrr)
+         ) txtset)
+
+
+let do_any _nameserver _domains () =
+  (* TODO *)
+  Error (`Msg "ANY functionality is not present atm due to refactorings, come back later")
+
+let do_dkim nameserver (selector:string) domains () =
+  let domains = List.map (fun original_domain ->
+      Domain_name.prepend_label_exn
+        (Domain_name.prepend_label_exn
+           (original_domain) "_domainkey") selector
+    ) domains in
+  for_all_domains nameserver ~domains Dns.Rr_map.Txt
+    (fun _domain (_ttl, txtset) ->
+       Dns.Rr_map.Txt_set.iter (fun txt ->
+           Logs.app (fun m -> m "%s" txt)
+         ) txtset)
+
+let do_type nameserver typ domains () =
+  match Dns.Rr_map.of_int typ with
+  | Ok K k ->
+    for_all_domains nameserver ~domains k
+      (fun domain resp ->
+         Logs.app (fun m -> m "%a" pp_zone (domain, k, resp)))
+  | _ -> Error (`Msg "bad argument")
+
+let do_loc nameserver domains () =
+  for_all_domains nameserver ~domains Dns.Rr_map.Loc
+    (output_response Dns.Rr_map.Loc)
+
+open Cmdliner
+
+let sdocs = Manpage.s_common_options
+
+let setup_log =
+  let setup_log (style_renderer:Fmt.style_renderer option) level : unit =
+    Fmt_tty.setup_std_outputs ?style_renderer () ;
+    Logs.set_level level ;
+    Logs.set_reporter (Logs_fmt.reporter ())
+  in
+  Term.(const setup_log $ Fmt_cli.style_renderer ~docs:sdocs ()
+        $ Logs_cli.level ~docs:sdocs ())
+
+let arg_ns : 'a Term.t =
+  let doc = "IP of nameserver to use" in
+  Arg.(value & opt (some Dns_cli.ip_c) None & info ~docv:"NS-IP" ~doc ["ns"])
+
+let arg_port : 'a Term.t =
+  let doc = "Port of nameserver" in
+  Arg.(value & opt int 53 & info ~docv:"NS-PORT" ~doc ["ns-port"])
+
+let tls_hostname =
+  let doc = "Hostname to use for TLS authentication" in
+  Arg.(value & opt (some Dns_cli.name_c) None &
+       info ~docv:"HOSTNAME" ~doc ["tls-hostname"])
+
+let tls_ca_file =
+  let doc = "TLS trust anchor file" in
+  Arg.(value & opt (some file) None &
+       info ~docv:"CAs" ~doc ["tls-ca-file"])
+
+let tls_ca_dir =
+  let doc = "TLS trust anchor directory" in
+  Arg.(value & opt (some dir) None &
+       info ~docv:"CAs" ~doc ["tls-ca-directory"])
+
+let tls_cert_fp =
+  let doc = "TLS certificate fingerprint" in
+  Arg.(value & opt (some string) None &
+       info ~docv:"FP" ~doc ["tls-cert-fingerprint"])
+
+let tls_key_fp =
+  let doc = "TLS public key fingerprint" in
+  Arg.(value & opt (some string) None &
+       info ~docv:"FP" ~doc ["tls-key-fingerprint"])
+
+let no_tls =
+  let doc = "Disable DNS-over-TLS" in
+  Arg.(value & flag & info ~docv:"no-tls" ~doc ["no-tls"])
+
+let nameserver =
+  let ( let* ) = Result.bind in
+  let ns no_tls ca_file ca_dir cert_fp key_fp hostname ip port =
+    if no_tls then
+      Option.map (fun ip -> `Tcp, [ `Plaintext (ip, port)]) ip
+    else
+      match ip with
+      | None -> None
+      | Some ip ->
+        let auth peer_name ip =
+          let cfg auth =
+            Result.join
+              (Result.map
+                 (fun authenticator -> Tls.Config.client ~authenticator ?peer_name ?ip ()) auth)
+          in
+          let time () = Some (Ptime_clock.now ()) in
+          let of_fp data =
+            let hash, fp =
+              let h_of_string = function
+                | "md5" -> Some `MD5
+                | "sha" | "sha1" -> Some `SHA1
+                | "sha224" -> Some `SHA224
+                | "sha256" -> Some `SHA256
+                | "sha384" -> Some `SHA384
+                | "sha512" -> Some `SHA512
+                | _ -> None
+              in
+              match String.split_on_char ':' data with
+              | [] -> invalid_arg "empty fingerprint"
+              | [ fp ] -> `SHA256, fp
+              | hash :: rt -> match h_of_string (String.lowercase_ascii hash) with
+                | Some h -> h, String.concat "" rt
+                | None -> invalid_arg ("unknown hash: " ^ hash)
+            in
+            let hex = Ohex.encode fp in
+            hash, hex
+          in
+          match ca_file, ca_dir, cert_fp, key_fp with
+          | None, None, None, None -> cfg (Ca_certs.authenticator ())
+          | Some f, None, None, None ->
+            let* data = Bos.OS.File.read (Fpath.v f) in
+            let* certs = X509.Certificate.decode_pem_multiple data in
+            cfg (Ok (X509.Authenticator.chain_of_trust ~time certs))
+          | None, Some d, None, None ->
+            let* files = Bos.OS.Dir.contents (Fpath.v d) in
+            let* certs =
+              List.fold_left (fun r f ->
+                  let* acc = r in
+                  let* data = Bos.OS.File.read f in
+                  let* cert = X509.Certificate.decode_pem data in
+                  Ok (cert :: acc))
+                (Ok []) files
+            in
+            cfg (Ok (X509.Authenticator.chain_of_trust ~time certs))
+          | None, None, Some fp, None ->
+            let hash, fingerprint = of_fp fp in
+            cfg (Ok (X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint))
+          | None, None, None, Some fp ->
+            let hash, fingerprint = of_fp fp in
+            cfg (Ok (X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint))
+          | _ -> invalid_arg "only one of cert-file, cert-dir, key-fingerprint, cert-fingerprint is supported"
+        in
+        let ip' = match hostname with None -> Some ip | Some _ -> None in
+        let tls = match auth hostname ip' with
+          | Ok a -> a
+          | Error `Msg msg -> invalid_arg msg
+        in
+        Some (`Tcp, [ `Tls (tls, ip, if port = 53 then 853 else port);
+                      `Plaintext (ip, port) ])
+  in
+  Term.(const ns $ no_tls $ tls_ca_file $ tls_ca_dir $ tls_cert_fp $ tls_key_fp $ tls_hostname $ arg_ns $ arg_port)
+
+let arg_domains : [ `raw ] Domain_name.t list Term.t =
+  let doc = "Domain names to operate on" in
+  Arg.(non_empty & pos_all Dns_cli.domain_name_c []
+       & info [] ~docv:"DOMAIN(s)" ~doc)
+
+let arg_selector : string Term.t =
+  let doc = "DKIM selector string" in
+  Arg.(required & opt (some string) None
+       & info ["selector"] ~docv:"SELECTOR" ~doc)
+
+let cmd_a : unit Cmd.t =
+  let doc = "Query a NS for A records" in
+  let man = [
+    `P {| Output mimics that of $(b,dig A )$(i,DOMAIN)|}
+  ] in
+  let term =
+    Term.(term_result (const do_a $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "a" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_aaaa : unit Cmd.t =
+  let doc = "Query a NS for AAAA records" in
+  let man = [
+    `P {| Output mimics that of $(b,dig AAAA )$(i,DOMAIN)|}
+  ] in
+  let term =
+    Term.(term_result (const do_aaaa $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "aaaa" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_mx : unit Cmd.t =
+  let doc = "Query a NS for mailserver (MX) records" in
+  let man = [
+    `P {| Output mimics that of $(b,dig MX )$(i,DOMAIN)|}
+  ] in
+  let term =
+    Term.(term_result (const do_mx $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "mx" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_tlsa : unit Cmd.t =
+  let doc = "Query a NS for TLSA records (see DANE / RFC 7671)" in
+  let man = [
+    `S Manpage.s_arguments ;
+    `S Manpage.s_description ;
+    `P {|Note that you must specify which $(b,service name)
+          you want to retrieve the key(s) of.
+         To retrieve the $(b,HTTPS) cert of $(i,www.example.com),
+          you would query the NS:
+          $(mname) $(tname) $(b,_443._tcp.)$(i,www.example.com)
+       |} ;
+    `P {|Brief list of other handy service name prefixes:|};
+    `P {| $(b,_5222._tcp) (XMPP); |} ;
+    `P {| $(b,_853._tcp) (DNS-over-TLS); |} ;
+    `P {| $(b,_25._tcp) (SMTP with STARTTLS); |} ;
+    `P {| $(b,_465._tcp)(SMTP); |} ;
+    `P {| $(b,_993._tcp) (IMAP) |} ;
+    `S Manpage.s_options ;
+  ] in
+  let term =
+    Term.(term_result (const do_tlsa $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "tlsa" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_txt : unit Cmd.t =
+  let doc = "Query a NS for TXT records" in
+  let man = [
+    `S Manpage.s_arguments ;
+    `S Manpage.s_description ;
+    `P {| Output format is currently: $(i,{TTL}: {text escaped in OCaml format})
+          It would be nice to mirror `dig` output here.|} ;
+    `S Manpage.s_options ;
+  ] in
+  let term =
+    Term.(term_result (const do_txt $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "txt" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_any : unit Cmd.t =
+  let doc = "Query a NS for ANY records" in
+  let man = [
+    `S Manpage.s_arguments ;
+    `S Manpage.s_description ;
+    `P {| The output will be fairly similar to $(b,dig ANY )$(i,example.com)|} ;
+    `S Manpage.s_options ;
+  ] in
+  let term =
+    Term.(term_result (const do_any $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "any" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_dkim : unit Cmd.t =
+  let doc = "Query a NS for DKIM (RFC 6376) records for a given selector" in
+  let man = [
+    `S Manpage.s_arguments ;
+    `S Manpage.s_description ;
+    `S {| Looks up DKIM (DomainKeys Identified Mail) Signatures in
+           accordance with RFC 6376.
+          Basically it's a recursive TXT lookup on
+           $(i,SELECTOR)._domainkeys.$(i,DOMAIN).
+          Each key is printed on its own concatenated line.
+       |} ;
+    `S Manpage.s_options ;
+  ] in
+  let term =
+    Term.(term_result (const do_dkim $ nameserver $ arg_selector
+                       $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "dkim" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let arg_typ : int Term.t =
+  let doc = "Type to query" in
+  Arg.(required & opt (some int) None
+       & info ["type"] ~docv:"TYPE" ~doc)
+
+let cmd_type : unit Cmd.t =
+  let doc = "Query a NS for a type, providing its integer number" in
+  let term =
+    Term.(term_result (const do_type $ nameserver $ arg_typ
+                       $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "type" ~version:(Manpage.escape "v10.2.2") ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_loc : unit Cmd.t =
+  let doc = "Query a NS for LOC records" in
+  let term =
+    Term.(term_result (const do_loc $ nameserver $ arg_domains $ setup_log))
+  and info =
+    Cmd.info "loc" ~version:(Manpage.escape "v10.2.2") ~doc ~sdocs
+  in
+  Cmd.v info term
+
+let cmd_help : 'a Term.t =
+  let help _ = `Help (`Pager, None) in
+  Term.(ret (const help $ setup_log))
+
+let cmds =
+  [ cmd_a ; cmd_tlsa; cmd_txt ; cmd_any; cmd_dkim ; cmd_aaaa ; cmd_mx ; cmd_type ; cmd_loc ]
+
+let () =
+  let doc = "OCaml uDns alternative to `dig`" in
+  let man = [
+    `P {|For more information about the available subcommands,
+run them while passing the help flag: $(tname) $(i,SUBCOMMAND) $(b,--help)
+|}
+  ] in
+  let info =
+    Cmd.info "odns" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
+  in
+  let group = Cmd.group ~default:cmd_help info cmds in
+  exit (Cmd.eval group)

unikernel/duniverse/ocaml-dns/app/odnssec.ml

@@ -0,0 +1,201 @@
+open Lwt.Infix
+
+open Dns
+
+let ( let* ) = Result.bind
+
+let pp_zone ppf (domain, query_type, query_value) =
+  Fmt.string ppf
+    (Rr_map.text_b domain (Rr_map.B (query_type, query_value)))
+
+let pp_nameserver ppf = function
+  | `Plaintext (ip, port) -> Fmt.pf ppf "TCP %a:%d" Ipaddr.pp ip port
+  | `Tls (tls_cfg, ip, port) ->
+    Fmt.pf ppf "TLS %a:%d%a" Ipaddr.pp ip port
+      Fmt.(option ~none:(any "") (append (any "#") Domain_name.pp))
+      ((Tls.Config.of_client tls_cfg).Tls.Config.peer_name)
+
+let jump () hostname typ ns =
+  match Dns.Rr_map.of_string typ with
+  | Ok K k ->
+    Lwt_main.run (
+      let edns = Edns.create ~dnssec_ok:true ~payload_size:4096 () in
+      let nameservers = match ns with
+        | None -> None
+        | Some ip -> Some (`Tcp, [ `Plaintext (ip, 53) ])
+      in
+      let happy_eyeballs = Happy_eyeballs_lwt.create () in
+      let t = Dns_client_lwt.create ?nameservers ~edns:(`Manual edns) happy_eyeballs in
+      let (_, ns) = Dns_client_lwt.nameservers t in
+      Logs.info (fun m -> m "querying NS %a for A records of %a"
+                    pp_nameserver (List.hd ns) Domain_name.pp hostname);
+      let log_err = function
+        | `Msg msg ->
+          Logs.err (fun m -> m "error from resolver %s" msg);
+          Error (`Msg "bad request")
+        | `Partial ->
+          Logs.err (fun m -> m "partial from resolver");
+          Error (`Msg "partial")
+        | #Dnssec.err as e ->
+          Logs.err (fun m -> m "dnssec error %a" Dnssec.pp_err e);
+          Error (`Msg "error")
+      in
+      let now = Ptime_clock.now () in
+      let retrieve_dnskey dnskeys ds_set requested_domain =
+        Dns_client_lwt.(get_raw_reply t Dnskey requested_domain) >|= function
+        | Error e -> log_err e
+        | Ok reply ->
+          let keys =
+            match reply with
+            | `Answer (answer, _) ->
+              Option.map
+                (fun (_, keys) ->
+                   let valid_keys =
+                     Rr_map.Ds_set.fold (fun ds acc ->
+                         match Dnssec.validate_ds requested_domain keys ds with
+                         | Ok key -> Rr_map.Dnskey_set.add key acc
+                         | Error `Msg msg ->
+                           Logs.warn (fun m -> m "couldn't validate DS (for %a): %s"
+                                         Domain_name.pp requested_domain msg);
+                           acc
+                         | Error `Extended e ->
+                           Logs.warn (fun m -> m "couldn't validate DS (for %a): %a"
+                                         Domain_name.pp requested_domain
+                                         Extended_error.pp e);
+                           acc)
+                       ds_set Rr_map.Dnskey_set.empty
+                   in
+                   Logs.debug (fun m -> m "found %d DNSKEYS with matching DS"
+                                  (Rr_map.Dnskey_set.cardinal valid_keys));
+                   valid_keys)
+                (Name_rr_map.find requested_domain Dnskey answer)
+            | _ -> None
+          in
+          let keys = Option.value ~default:dnskeys keys in
+          match Dnssec.verify_reply now keys requested_domain Dnskey reply with
+          | Error (`No_domain _ | `No_data _) ->
+            Logs.warn (fun m -> m "no DNSKEY for %a"
+                          Domain_name.pp requested_domain);
+            Error (`Msg (Fmt.str "missing DNSKEY for %a"
+                           Domain_name.pp requested_domain))
+          | Error e -> log_err e
+          | Ok (_, keys) ->
+            Logs.info (fun m -> m "verified RRSIG for DNSKEYS");
+            let keys =
+              Rr_map.Dnskey_set.filter
+                (fun k -> Dnskey.F.mem `Zone k.Dnskey.flags)
+                keys
+            in
+            Ok keys
+      in
+      let retrieve_ds dnskeys name =
+        Dns_client_lwt.(get_raw_reply t Ds name) >|= function
+        | Error e -> log_err e
+        | Ok reply ->
+          match Dnssec.verify_reply ~follow_cname:false now dnskeys name Ds reply with
+          | Ok (_, ds) -> Ok (Some ds)
+          | Error (`No_domain _ | `No_data _) ->
+            Logs.warn (fun m -> m "no data or no domain for DS in %a"
+                          Domain_name.pp name);
+            Ok None
+          | Error (`Cname a) ->
+            Logs.warn (fun m -> m "cname alias for %a (DS) to %a"
+                          Domain_name.pp name
+                          Domain_name.pp a);
+            Ok None
+          | Error e->
+            log_err e
+      in
+      let rec retrieve_validated_dnskeys hostname =
+        Logs.info (fun m -> m "validating and retrieving DNSKEYS for %a" Domain_name.pp hostname);
+        if Domain_name.equal hostname Domain_name.root then begin
+          Logs.info (fun m -> m "retrieving DNSKEYS for %a" Domain_name.pp hostname);
+          retrieve_dnskey Rr_map.Dnskey_set.empty Dnssec.root_ds hostname
+        end else
+          let open Lwt_result.Infix in
+          retrieve_validated_dnskeys Domain_name.(drop_label_exn hostname) >>= fun parent_dnskeys ->
+          Logs.info (fun m -> m "retrieving DS for %a" Domain_name.pp hostname);
+          retrieve_ds parent_dnskeys hostname >>= function
+          | Some ds_set ->
+            (* following 4509 - if there's a sha2 DS, drop sha1 ones *)
+            let ds_set' =
+              if
+                Rr_map.Ds_set.exists
+                  (fun ds ->
+                     match ds.Ds.digest_type with
+                     | Ds.SHA256 | Ds.SHA384 -> true
+                     | _ -> false)
+                  ds_set
+              then
+                Rr_map.Ds_set.filter
+                  (fun ds -> not (ds.Ds.digest_type = Ds.SHA1))
+                  ds_set
+              else
+                ds_set
+            in
+            if Rr_map.Ds_set.cardinal ds_set > Rr_map.Ds_set.cardinal ds_set' then
+              Logs.warn (fun m -> m "dropped %d DS records (SHA1)"
+                            (Rr_map.Ds_set.cardinal ds_set' - Rr_map.Ds_set.cardinal ds_set));
+            Logs.info (fun m -> m "retrieving DNSKEYS for %a" Domain_name.pp hostname);
+            retrieve_dnskey parent_dnskeys ds_set' hostname
+          | None ->
+            Logs.info (fun m -> m "no DS for %a, continuing with old keys" Domain_name.pp hostname);
+            Lwt.return (Ok parent_dnskeys)
+      in
+      retrieve_validated_dnskeys hostname >>= function
+      | Error _ as e -> Lwt.return e
+      | Ok dnskeys ->
+        Dns_client_lwt.(get_raw_reply t k hostname) >|= function
+        | Error e -> log_err e
+        | Ok reply ->
+          match Dnssec.verify_reply now dnskeys hostname k reply with
+          | Ok rrs ->
+            Logs.app (fun m -> m "%a" pp_zone (hostname, k, rrs));
+            Ok ()
+          | Error (`No_domain _ | `No_data _) ->
+            Logs.warn (fun m -> m "no data or no domain for %a (%a)"
+                          Domain_name.pp hostname Rr_map.ppk (K k));
+            Ok ()
+          | Error e -> log_err e
+    )
+  | _ -> Error (`Msg "couldn't decode type")
+
+open Cmdliner
+
+let parse_domain : [ `raw ] Domain_name.t Arg.conv =
+  Arg.conv'
+    ((fun name ->
+        Result.map_error
+          (function `Msg m -> Fmt.str "Invalid domain: %S: %s" name m)
+          (Domain_name.of_string name)),
+     Domain_name.pp)
+
+let arg_domain : [ `raw ] Domain_name.t Term.t =
+  let doc = "Host to operate on" in
+  Arg.(value & opt parse_domain (Domain_name.of_string_exn "cloudflare.com")
+       & info [ "host" ] ~docv:"HOST" ~doc)
+
+let parse_ip =
+  Arg.conv'
+    ((fun s ->
+        match Ipaddr.of_string s with
+        | Ok ip -> Ok ip
+        | Error (`Msg m) -> Error ("failed to parse IP address: " ^ m)),
+     Ipaddr.pp)
+
+let nameserver : Ipaddr.t option Term.t =
+  let doc = "Nameserver to use" in
+  Arg.(value & opt (some parse_ip) None & info [ "nameserver" ] ~docv:"NAMESERVER" ~doc)
+
+let arg_typ : string Term.t =
+  let doc = "Type to query" in
+  Arg.(value & opt string "A" & info ["type"] ~docv:"TYPE" ~doc)
+
+let cmd =
+  let term =
+    Term.(term_result (const jump $ Dns_cli.setup_log $ arg_domain $ arg_typ $ nameserver))
+  and info = Cmd.info "odnssec" ~version:"10.2.2"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-dns/app/onotify.ml

@@ -0,0 +1,95 @@
+(* (c) 2019 Hannes Mehnert, all rights reserved *)
+
+open Dns
+
+let notify zone serial key now =
+  let raw_zone = Domain_name.raw zone in
+  let question = Packet.Question.create raw_zone Soa
+  and soa =
+    { Soa.nameserver = raw_zone ; hostmaster = raw_zone ; serial ;
+      refresh = 0l; retry = 0l ; expiry = 0l ; minimum = 0l }
+  and header = Randomconv.int16 Mirage_crypto_rng.generate, Packet.Flags.singleton `Authoritative
+  in
+  let p = Packet.create header question (`Notify (Some soa)) in
+  match key with
+  | None -> Ok (p, fst (Packet.encode `Tcp p), None)
+  | Some (keyname, _, dnskey) ->
+    Logs.debug (fun m -> m "signing with key %a: %a" Domain_name.pp keyname Dnskey.pp dnskey) ;
+    match Dns_tsig.encode_and_sign ~proto:`Tcp p now dnskey keyname with
+    | Ok (cs, mac) -> Ok (p, cs, Some mac)
+    | Error e -> Error e
+
+let jump _ serverip port zone key serial =
+  Mirage_crypto_rng_unix.use_default ();
+  let now = Ptime_clock.now () in
+  Logs.app (fun m -> m "notifying to %a:%d zone %a serial %lu"
+               Ipaddr.pp serverip port Domain_name.pp zone serial) ;
+  match notify zone serial key now with
+  | Error s -> Error (`Msg (Fmt.str "signing %a" Dns_tsig.pp_s s))
+  | Ok (request, data, mac) ->
+    let data_len = String.length data in
+    Logs.debug (fun m -> m "built data %d" data_len) ;
+    let socket = Dns_cli.connect_tcp serverip port in
+    Dns_cli.send_tcp socket data ;
+    let read_data = Dns_cli.recv_tcp socket in
+    Unix.close socket ;
+    match key with
+    | None ->
+      begin match Packet.decode read_data with
+        | Ok reply ->
+          begin match Packet.reply_matches_request ~request reply with
+            | Ok `Notify_ack ->
+              Logs.app (fun m -> m "successful notify!") ;
+              Ok ()
+            | Ok r -> Error (`Msg (Fmt.str "expected notify ack, got %a" Packet.pp_reply r))
+            | Error e -> Error (`Msg (Fmt.str "notify reply %a is not ok %a"
+                                        Packet.pp reply Packet.pp_mismatch e))
+          end
+        | Error e ->
+          Error (`Msg (Fmt.str "failed to decode notify reply! %a" Packet.pp_err e))
+      end
+    | Some (keyname, _, dnskey) ->
+      match Dns_tsig.decode_and_verify now dnskey keyname ?mac read_data with
+      | Error e ->
+        Error (`Msg (Fmt.str "failed to decode TSIG signed notify reply! %a" Dns_tsig.pp_e e))
+      | Ok (reply, _, _) ->
+        match Packet.reply_matches_request ~request reply with
+        | Ok `Notify_ack ->
+          Logs.app (fun m -> m "successful TSIG signed notify!") ;
+          Ok ()
+        | Ok r -> Error (`Msg (Fmt.str "expected notify ack, got %a" Packet.pp_reply r))
+        | Error e ->
+          Error (`Msg (Fmt.str "expected reply to %a %a, got %a!"
+                         Packet.pp_mismatch e
+                         Packet.pp request Packet.pp reply))
+
+open Cmdliner
+
+let serverip =
+  let doc = "IP address of DNS server" in
+  Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"SERVERIP")
+
+let port =
+  let doc = "Port to connect to" in
+  Arg.(value & opt int 53 & info [ "port" ] ~doc)
+
+let serial =
+  let doc = "Serial number" in
+  Arg.(value & opt int32 1l & info [ "serial" ] ~doc)
+
+let key =
+  let doc = "DNS HMAC secret (name:alg:b64key)" in
+  Arg.(value & opt (some Dns_cli.namekey_c) None & info [ "key" ] ~doc ~docv:"KEY")
+
+let zone =
+  let doc = "Zone to notify" in
+  Arg.(required & pos 1 (some Dns_cli.name_c) None & info [] ~doc ~docv:"ZONE")
+
+let cmd =
+  let info = Cmd.info "onotify" ~version:"10.2.2"
+  and term =
+    Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ zone $ key $ serial))
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-dns/app/oupdate.ml

@@ -0,0 +1,91 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+open Dns
+
+let create_update zone hostname ip_address =
+  let zone = Packet.Question.create zone Soa
+  and update =
+    let up =
+      Domain_name.Map.singleton hostname
+        [
+          Packet.Update.Remove (Rr_map.K A) ;
+          Packet.Update.Add Rr_map.(B (A, (60l, Ipaddr.V4.Set.singleton ip_address)))
+        ]
+    in
+    (Domain_name.Map.empty, up)
+  and header = Randomconv.int16 Mirage_crypto_rng.generate, Packet.Flags.empty
+  in
+  Packet.create header zone (`Update update)
+
+let jump _ serverip port (keyname, zone, dnskey) hostname ip_address =
+  Mirage_crypto_rng_unix.use_default ();
+  let now = Ptime_clock.now () in
+  Logs.app (fun m -> m "updating to %a:%d zone %a A 600 %a %a"
+               Ipaddr.pp serverip port
+               Domain_name.pp zone
+               Domain_name.pp hostname
+               Ipaddr.V4.pp ip_address) ;
+  Logs.debug (fun m -> m "using key %a: %a" Domain_name.pp keyname Dns.Dnskey.pp dnskey) ;
+  let p = create_update zone hostname ip_address in
+  match Dns_tsig.encode_and_sign ~proto:`Tcp p now dnskey keyname with
+  | Error s ->
+    Error (`Msg (Fmt.str "tsig sign error %a" Dns_tsig.pp_s s))
+  | Ok (data, mac) ->
+    let data_len = String.length data in
+    Logs.debug (fun m -> m "built data %d" data_len) ;
+    let socket = Dns_cli.connect_tcp serverip port in
+    Dns_cli.send_tcp socket data ;
+    let read_data = Dns_cli.recv_tcp socket in
+    (try (Unix.close socket) with _ -> ()) ;
+    match Dns_tsig.decode_and_verify now dnskey keyname ~mac read_data with
+    | Error e ->
+      Error (`Msg (Fmt.str "nsupdate error %a" Dns_tsig.pp_e e))
+    | Ok (reply, _, _) ->
+      match Packet.reply_matches_request ~request:p reply with
+      | Ok `Update_ack ->
+        Logs.app (fun m -> m "successful and signed update!") ;
+        Ok ()
+      | Ok r ->
+        Error (`Msg (Fmt.str "nsupdate expected update ack, received %a" Packet.pp_reply r))
+      | Error e ->
+        Error (`Msg (Fmt.str "nsupdate error %a (reply %a does not match request %a)"
+                       Packet.pp_mismatch e Packet.pp reply Packet.pp p))
+
+open Cmdliner
+
+let serverip =
+  let doc = "IP address of DNS server" in
+  Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"SERVERIP")
+
+let port =
+  let doc = "Port to connect to" in
+  Arg.(value & opt int 53 & info [ "port" ] ~doc)
+
+let key =
+  let doc = "DNS HMAC secret (name:alg:b64key where name is yyy._update.zone)" in
+  Arg.(required & pos 1 (some Dns_cli.namekey_c) None & info [] ~doc ~docv:"KEY")
+
+let hostname =
+  let doc = "Hostname to modify" in
+  Arg.(required & pos 2 (some Dns_cli.domain_name_c) None & info [] ~doc ~docv:"HOSTNAME")
+
+let ipv4_c =
+  Arg.conv'
+    ((fun s ->
+        match Ipaddr.V4.of_string s with
+        | Ok ip -> Ok ip
+        | Error (`Msg m) -> Error ("failed to parse IP address: " ^ m)),
+     Ipaddr.V4.pp)
+
+let ip_address =
+  let doc = "New IP address" in
+  Arg.(required & pos 3 (some ipv4_c) None & info [] ~doc ~docv:"IP")
+
+let cmd =
+  let term =
+    Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ key $ hostname $ ip_address))
+  and info = Cmd.info "oupdate" ~version:"10.2.2"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-dns/app/ozone.ml

@@ -0,0 +1,72 @@
+(* (c) 2019 Hannes Mehnert, all rights reserved *)
+
+(* goal is to check a given zonefile whether it is valid (and to-be-used
+   by an authoritative NS - i.e. there must be a SOA record, TTL are good)
+   if a NS/MX name is within the zone, it needs an address record
+   the name of the file is taken as the domain name *)
+open Dns
+
+let ( let* ) = Result.bind
+
+let load_zone zone =
+  let* data = Bos.OS.File.read Fpath.(v zone) in
+  let* rrs = Dns_zone.parse data in
+  let domain = Domain_name.of_string_exn Fpath.(basename (v zone)) in
+  let bad = Domain_name.Map.filter
+      (fun name _ -> not (Domain_name.is_subdomain ~domain ~subdomain:name))
+      rrs
+  in
+  if not (Domain_name.Map.is_empty bad) then
+    Error (`Msg (Fmt.str "Entries of domain '%a' are not in its zone, won't handle this:@.%a"
+                   Domain_name.pp domain Dns.Name_rr_map.pp bad))
+  else
+    Ok (Dns_trie.insert_map rrs Dns_trie.empty)
+
+let jump _ zone old =
+  let* trie = load_zone zone in
+  let* () =
+    Result.map_error
+      (fun e -> `Msg (Fmt.to_to_string Dns_trie.pp_zone_check e))
+      (Dns_trie.check trie)
+  in
+  Logs.app (fun m -> m "successfully checked zone") ;
+  let zones =
+    Dns_trie.fold Soa trie
+      (fun name _ acc -> Domain_name.Set.add name acc)
+      Domain_name.Set.empty
+  in
+  if Domain_name.Set.cardinal zones = 1 then
+    let zone = Domain_name.Set.choose zones in
+    let* zone_data = Dns_server.text zone trie in
+    Logs.debug (fun m -> m "assembled zone data %s" zone_data) ;
+    (match old with
+     | None -> Ok ()
+     | Some fn ->
+       let* old = load_zone fn in
+       match Dns_trie.lookup zone Soa trie, Dns_trie.lookup zone Soa old with
+       | Ok fresh, Ok old when Soa.newer ~old fresh ->
+         Logs.debug (fun m -> m "zone %a newer than old" Domain_name.pp zone) ;
+         Ok ()
+       | _ ->
+         Error (`Msg "SOA comparison wrong"))
+  else
+    Error (`Msg "expected exactly one zone")
+
+open Cmdliner
+
+let newzone =
+  let doc = "New zone file" in
+  Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"ZONE")
+
+let oldzone =
+  let doc = "Old zone file" in
+  Arg.(value & opt (some file) None & info [ "old" ] ~doc ~docv:"ZONE")
+
+let cmd =
+  let term =
+    Term.(term_result (const jump $ Dns_cli.setup_log $ newzone $ oldzone))
+  and info = Cmd.info "ozone" ~version:"10.2.2"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-dns/app/resolver.ml

@@ -0,0 +1,97 @@
+
+module Resolver = Dns_resolver_mirage.Make(Tcpip_stack_socket.V4V6)
+
+open Lwt.Infix
+
+let pp_val ppf f =
+  let open Metrics in
+  match value f with
+  | V (String, s) -> Fmt.pf ppf "%S" s
+  | V (Int, i) -> Fmt.pf ppf "%d" i
+  | V (Int32, i32) -> Fmt.pf ppf "%ld" i32
+  | V (Int64, i64) -> Fmt.pf ppf "%Ld" i64
+  | V (Uint, u) -> Fmt.pf ppf "%u" u
+  | V (Uint32, u32) -> Fmt.pf ppf "%lu" u32
+  | V (Uint64, u64) -> Fmt.pf ppf "%Lu" u64
+  | _ -> pp_value ppf f
+
+let print_resolver_stats () =
+  let map = Metrics.get_cache () in
+  let dns_resolver_src =
+    List.find (fun src -> Metrics.Src.name src = "dns-resolver") (Metrics.Src.list ())
+  in
+  let dns_resolver_metrics =
+    match Metrics.SM.find_opt dns_resolver_src map with
+    | None ->
+      print_endline "no dns-resolver found";
+      []
+    | Some ms ->
+      List.concat_map (fun (_tags, data) -> Metrics.Data.fields data) ms
+  in
+  List.iter (fun field ->
+      Logs.app (fun m -> m "%s %a" (Metrics.key field) pp_val field))
+    dns_resolver_metrics;
+  exit 130
+
+let main dnssec qname_min opportunistic =
+  Mirage_crypto_rng_unix.use_default ();
+  let reporter = Metrics.cache_reporter () in
+  Metrics.set_reporter reporter;
+  Metrics.enable_all ();
+  Udpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun udp ->
+  Tcpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun tcp ->
+  Tcpip_stack_socket.V4V6.connect udp tcp >>= fun stack ->
+  let resolver =
+    let primary_t =
+      (* setup DNS server state: *)
+      Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate Dns_trie.empty
+    in
+    let features =
+      (if dnssec then [ `Dnssec ] else []) @
+      (if qname_min then [ `Qname_minimisation ] else []) @
+      (if opportunistic then [ `Opportunistic_tls_authoritative ] else [])
+    in
+    Dns_resolver.create features ~ip_protocol:`Ipv4_only
+      (Mirage_mtime.elapsed_ns ()) Mirage_crypto_rng.generate primary_t
+  in
+  let _resolver = Resolver.resolver ~port:53530 stack resolver in
+  let _ : Sys.signal_behavior =
+    Sys.signal Sys.sigint
+      (Signal_handle
+         (fun _ -> print_resolver_stats ()))
+  in
+  Tcpip_stack_socket.V4V6.listen stack >|= fun () ->
+  Ok ()
+
+let jump () dnssec qname_min opportunistic =
+  Lwt_main.run (main dnssec qname_min opportunistic)
+
+open Cmdliner
+
+let dnssec =
+  let doc =
+    Arg.info ~doc:"Validate DNS replies and cache DNSSEC data." [ "dnssec" ]
+  in
+  Arg.(value & flag doc)
+
+let qname_minimisation =
+  let doc =
+    Arg.info ~doc:"Use qname minimisation (RFC 9156)." [ "qname-minimisation" ]
+  in
+  Arg.(value & flag doc)
+
+let opportunistic_tls =
+  let doc =
+    Arg.info ~doc:"Use opportunistic TLS from recursive resolver to authoriative (RFC 9539)."
+      [ "opportunistic-tls-authoritative" ]
+  in
+  Arg.(value & flag doc)
+
+let cmd =
+  let term =
+    Term.(term_result (const jump $ Dns_cli.setup_log $ dnssec $ qname_minimisation $ opportunistic_tls))
+  and info = Cmd.info "resolver" ~version:"10.2.2"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)