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)