Merge pull request #204 from hannesm/client-api

Client API improvements

CHANGES.md

@@ -1,3 +1,27 @@
+### v4.3.0 (2020-01-09)
+
+* dns
+  - BUGFIX Name_rr_map.remove_sub remove empty maps (#205, @hannesm)
+* server (#205, @hannesm)
+  - authentication refactoring: given a key by its Domain_name.t (name._op.zone),
+    this is valid for operation `op` for `zone` and subdomains thereof. The
+    operation may be one of `update`, `transfer`, and `notify`, with an `update`
+    key being valid for any operation, and a `transfer` key valid for
+    notifications as well
+  - Primary.create has a new optional argument `unauthenticated_zone_transfer`
+    to allow unsigned zone transfer requests
+  - the type `Authentication.a` and value `Authentication.tsig_auth` are removed
+    - Primary.create and Secondary.create no longer have the `a` argument
+  - authentication uniformly uses `Authentication.access`
+  - handle_update / handle_axfr_request / handle_ixfr_request are provided and
+    under test
+  - tests for authentication and handle_question
+* client (#204, @hannesm)
+  - introduce get_resource_record which is the same as getaddrinfo, but returns
+    the error as variant instead of [ `Msg of string ]
+  - BUGFIX follow_cname handles replies with a cname and no data for the alias
+    appropriately (and a regression test has been developed)
+
 ### v4.2.0 (2019-11-20)
 
 * dns

client/dns_client.ml

@@ -28,22 +28,20 @@ module Pure = struct
   (* name: the originally requested domain name. *)
   let rec follow_cname name ~iterations:iterations_left ~answer ~state =
     let open Rresult in
-    if iterations_left <= 0 then Error (`Msg "CNAME recursion too deep")
+    if iterations_left <= 0
+    then Error (`Msg "CNAME recursion too deep")
     else
-      Domain_name.Map.find_opt name answer
-      |> R.of_option ~none:(fun () ->
-          R.error_msgf "Can't find relevant map in response:@ %a in [%a]"
-            Domain_name.pp name
-            Name_rr_map.pp answer
-        ) >>= fun relevant_map ->
-      match Rr_map.find state.key relevant_map with
-        | Some response -> Ok response
+      match Domain_name.Map.find_opt name answer with
+      | None -> Ok (`Need_soa name)
+      | Some relevant_map ->
+        match Rr_map.find state.key relevant_map with
+        | Some response -> Ok (`Data response)
         | None ->
           match Rr_map.(find Cname relevant_map) with
-            | None -> Error (`Msg "Invalid DNS response")
-            | Some (_ttl, redirected_host) ->
-              let iterations = pred iterations_left in
-              follow_cname redirected_host ~iterations ~answer ~state
+          | None -> Error (`Msg "Invalid DNS response")
+          | Some (_ttl, redirected_host) ->
+            let iterations = pred iterations_left in
+            follow_cname redirected_host ~iterations ~answer ~state
 
   let consume_protocol_prefix buf =
     function (* consume TCP two-byte length prefix: *)
@@ -91,13 +89,22 @@ module Pure = struct
     | Ok t ->
       to_msg t (Packet.reply_matches_request ~request:state.query t)
       >>= function
-      | `Answer (answer, _) when not (Domain_name.Map.is_empty answer) ->
-        follow_cname (fst state.query.question) ~iterations:20 ~answer ~state
-        >>| fun x -> `Data x
+      | `Answer (answer, authority) when not (Domain_name.Map.is_empty answer) ->
+        begin
+          let q = fst state.query.question in
+          follow_cname q ~iterations:20 ~answer ~state >>= function
+          | `Data x -> Ok (`Data x)
+          | `Need_soa _name ->
+            (* should we retain CNAMEs (and send them to the client)? *)
+            (* should we 'adjust' the SOA name to be _name? *)
+            match find_soa authority with
+            | Some soa -> Ok (`No_data soa)
+            | None -> Error (`Msg "invalid reply, couldn't find SOA")
+        end
       | `Answer (_, authority) ->
         begin match find_soa authority with
           | Some soa -> Ok (`No_data soa)
-          | None -> Error (`Msg "invalid reply, no SOA in nodomain")
+          | None -> Error (`Msg "invalid reply, no SOA in no data")
         end
       | `Rcode_error (NXDomain, Query, Some (_answer, authority)) ->
         begin match find_soa authority with
@@ -178,10 +185,11 @@ struct
   (* result-bind-and-lift *)
   let (>>|=) a f = a >>| fun b -> Transport.lift (f b)
 
-  let getaddrinfo (type requested) t ?nameserver (query_type:requested Dns.Rr_map.key) name
-    : (requested, [> `Msg of string]) result Transport.io =
-    let domain_name = (Domain_name.raw name) in
-
+  let get_resource_record (type requested) t ?nameserver (query_type:requested Dns.Rr_map.key) name
+    : (requested, [> `Msg of string
+                  | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
+                  | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result Transport.io =
+    let domain_name = Domain_name.raw name in
     match Dns_cache.get t.cache (t.clock ()) domain_name query_type with
     | Ok `Entry (B (query_type', value)) ->
       (* to satisfy the type checker, we need to prove that
@@ -195,12 +203,8 @@ struct
         | _ -> Transport.lift @@
           Rresult.R.error_msgf "should not happen request_type <> request_type'"
       end
-    | Ok `No_data (name, _soa) ->
-      Rresult.R.error_msgf "No_data for %a" Domain_name.pp name
-      |> Transport.lift
-    | Ok `No_domain (name, _soa) ->
-      Rresult.R.error_msgf "No_domain for %a" Domain_name.pp name
-      |> Transport.lift
+    | Ok (`No_data _ as nodata) -> Error nodata |> Transport.lift
+    | Ok (`No_domain _ as nodom) -> Error nodom |> Transport.lift
     | Ok (`Serv_fail _)
     | Error _ ->
       let proto, _ = match nameserver with
@@ -229,19 +233,29 @@ struct
          match Pure.parse_response state buf with
          | Ok `Data x ->
           update_cache (`Entry (Rr_map.B (query_type, x)));
-          Transport.lift (Ok x)
+          Ok x |> Transport.lift
         | Ok ((`No_data _ | `No_domain _) as nodom) ->
           update_cache nodom;
-          Transport.lift @@
-          Rresult.R.error_msgf "resolution of %a failed (no domain / no data)"
-            Domain_name.pp domain_name
-        | Error `Msg xxx -> Transport.lift (Error (`Msg xxx))
+          Error nodom |> Transport.lift
+        | Error `Msg xxx -> Error (`Msg xxx) |> Transport.lift
         | Ok `Partial when proto = `TCP -> recv_loop buf
-        | Ok `Partial -> Transport.lift (Error (`Msg "Truncated UDP response"))
+        | Ok `Partial -> Error (`Msg "Truncated UDP response") |> Transport.lift
       in recv_loop Cstruct.empty) >>= fun r ->
       Transport.close socket >>= fun () ->
       Transport.lift r
 
+  let lift_cache_error m =
+    (match m with
+     | Ok a -> Ok a
+     | Error `Msg msg -> Error (`Msg msg)
+     | Error (#Dns_cache.entry as e) ->
+       Rresult.R.error_msgf "DNS cache error @[%a@]" Dns_cache.pp_entry e)
+    |> Transport.lift
+
+  let getaddrinfo (type requested) t ?nameserver (query_type:requested Dns.Rr_map.key) name
+    : (requested, [> `Msg of string ]) result Transport.io =
+    get_resource_record t ?nameserver query_type name >>= lift_cache_error
+
   let gethostbyname stack ?nameserver domain =
     getaddrinfo stack ?nameserver Dns.Rr_map.A domain >>|= fun (_ttl, resp) ->
     match Dns.Rr_map.Ipv4_set.choose_opt resp with

client/dns_client.mli

@@ -77,20 +77,21 @@ sig
   (** [create ~size ~rng ~nameserver ~clock stack] creates the state of the DNS client. *)
 
   val nameserver : t -> T.ns_addr
-  (** [nameserver t] returns the default nameserver to be used. *)
+  (** [nameserver state] returns the default nameserver to be used. *)
 
   val getaddrinfo : t -> ?nameserver:T.ns_addr -> 'response Dns.Rr_map.key ->
-    'a Domain_name.t -> ('response, [> `Msg of string ]) result T.io
-  (** [getaddrinfo nameserver query_type name] is the [query_type]-dependent
-      response from [nameserver] regarding [name], or an [Error _] message.
-      See {!Dns_client.query_state} for more information about the
-      result types.
+    'a Domain_name.t ->
+    ('response, [> `Msg of string ]) result T.io
+  (** [getaddrinfo state nameserver query_type name] is the
+      [query_type]-dependent response from [nameserver] regarding [name], or
+      an [Error _] message. See {!Dns_client.query_state} for more information
+      about the result types.
   *)
 
   val gethostbyname : t -> ?nameserver:T.ns_addr -> [ `host ] Domain_name.t ->
     (Ipaddr.V4.t, [> `Msg of string ]) result T.io
-    (** [gethostbyname state ~nameserver domain] is the IPv4 address of [domain]
-        resolved via the [state] and [nameserver] specified.
+    (** [gethostbyname state ~nameserver hostname] is the IPv4 address of
+        [hostname] resolved via the [state] and [nameserver] specified.
         If the query fails, or if the [domain] does not have any IPv4 addresses,
         an [Error _] message is returned.
         Any extraneous IPv4 addresses are ignored.
@@ -100,12 +101,26 @@ sig
 
   val gethostbyname6 : t -> ?nameserver:T.ns_addr -> [ `host ] Domain_name.t ->
     (Ipaddr.V6.t, [> `Msg of string ]) result T.io
-    (** [gethostbyname6 state ~nameserver domain] is the IPv6 address of
-        [domain] resolved via the [state] and [nameserver] specified.
+    (** [gethostbyname6 state ~nameserver hostname] is the IPv6 address of
+        [hostname] resolved via the [state] and [nameserver] specified.
 
         It is the IPv6 equivalent of {!gethostbyname}.
     *)
 
+  val get_resource_record : t -> ?nameserver:T.ns_addr ->
+    'response Dns.Rr_map.key -> 'a Domain_name.t ->
+    ('response,
+     [> `Msg of string
+     | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
+     | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result T.io
+    (** [get_resource_record state ~nameserver query_type name] resolves
+        [query_type, name] via the [state] and [nameserver] specified. The
+        behaviour is equivalent to {!getaddrinfo}, apart from the error return
+        value - [get_resource_record] distinguishes some errors, at the moment
+        [No_data] if the [name] exists, but not the [query_type], and
+        [No_domain] if the [name] does not exist. This allows clients to treat
+        these error conditions explicitly. *)
+
 end
 
 module Pure : sig

test/client.ml

@@ -287,15 +287,45 @@ module Getaddrinfo_tests = struct
     let mock_state = create ~clock () in
     let ns = `UDP, ref [udp_buf] in
     match getaddrinfo mock_state Dns.Rr_map.Mx domain_name ~nameserver:ns with
-    | Ok (_, _) ->
-      failwith("Should have reported the Truncated UDP packet")
     | Error `Msg actual ->
       let expected = "Truncated UDP response" in
       Alcotest.(check string "reports the truncated UDP packet failure" expected actual)
+    | _ -> failwith "Should have reported the Truncated UDP packet"
+
+  let cname_and_nodata_packet () =
+    (* we request a non-existing record type of existing domain name, which is
+       an alias - the reply is a CNAME with NoData *)
+    (* concretely, requesting AAAA raw.githubusercontent.com, reply is
+       AN: raw.githubusercontent.com CNAME github.map.fastly.net
+       AU: SOA fastly.net *)
+    let domain_name =
+      Domain_name.(of_string_exn "raw.githubusercontent.com" |> host_exn)
+    in
+    let udp_buf = Cstruct.of_hex {|
+00 00 81 80 00 01 00 01 00 01 00 00 03 72
+61 77 11 67 69 74 68 75 62 75 73 65 72 63 6f 6e
+74 65 6e 74 03 63 6f 6d 00 00 1c 00 01 c0 0c 00
+05 00 01 00 00 00 16 00 17 06 67 69 74 68 75 62
+03 6d 61 70 06 66 61 73 74 6c 79 03 6e 65 74 00
+c0 42 00 06 00 01 00 00 00 14 00 2e 03 6e 73 31
+c0 42 0a 68 6f 73 74 6d 61 73 74 65 72 06 66 61
+73 74 6c 79 c0 22 78 39 c6 29 00 00 0e 10 00 00
+02 58 00 09 3a 80 00 00 00 1e|}
+    in
+    let clock () = 0L in
+    let mock_state = create ~clock () in
+    let ns = `UDP, ref [udp_buf] in
+    match getaddrinfo mock_state Dns.Rr_map.Aaaa domain_name ~nameserver:ns with
+    | Error `Msg actual ->
+      let expected = "DNS cache error no data fastly.net" in
+      let len = String.length expected in
+      Alcotest.(check string __LOC__ expected (Astring.String.with_range ~len actual))
+    | _ -> Alcotest.fail "Should have returned nodata"
 
   let tests = [
     "supports_mx_packets", `Quick, supports_mx_packets;
     "a partial UDP response packet fails", `Quick, fails_on_partial_udp_packet;
+    "cname and nodata in packet", `Quick, cname_and_nodata_packet;
   ]
 end