From 5503107f9ed9ab6e43ae535ea3f656414537f48f Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 15 Mar 2019 14:10:09 +0000 Subject: [PATCH 1/9] test: move the DNS tests to a separate file Signed-off-by: David Scott --- src/hostnet_test/suite.ml | 105 +---------------------------- src/hostnet_test/test_dns.ml | 126 +++++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+), 104 deletions(-) create mode 100644 src/hostnet_test/test_dns.ml diff --git a/src/hostnet_test/suite.ml b/src/hostnet_test/suite.ml index 8c0656841..d571ff116 100644 --- a/src/hostnet_test/suite.ml +++ b/src/hostnet_test/suite.ml @@ -28,94 +28,6 @@ let test_dhcp_query () = in run ~pcap:"test_dhcp_query.pcap" t -let set_dns_policy ?builtin_names use_host = - Mclock.connect () >|= fun clock -> - Dns_policy.remove ~priority:3; - Dns_policy.add ~priority:3 - ~config:(if use_host then `Host else Dns_policy.google_dns); - Slirp_stack.Debug.update_dns ?builtin_names clock - -let test_dns_query server use_host () = - let t _ stack = - set_dns_policy use_host >>= fun () -> - let resolver = DNS.create stack.Client.t in - DNS.gethostbyname ~server resolver "www.google.com" >|= function - | (_ :: _) as ips -> - Log.info (fun f -> f "www.google.com has IPs: %a" pp_ips ips); - | _ -> - Log.err (fun f -> f "Failed to lookup www.google.com"); - failwith "Failed to lookup www.google.com" - in - run ~pcap:"test_dns_query.pcap" t - -let test_builtin_dns_query server use_host () = - let name = "experimental.host.name.localhost" in - let t _ stack = - set_dns_policy ~builtin_names:[ Dns.Name.of_string name, Ipaddr.V4 (Ipaddr.V4.localhost) ] use_host - >>= fun () -> - let resolver = DNS.create stack.Client.t in - DNS.gethostbyname ~server resolver name >>= function - | (_ :: _) as ips -> - Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); - Lwt.return () - | _ -> - Log.err (fun f -> f "Failed to lookup %s" name); - failwith ("Failed to lookup " ^ name) - in - run ~pcap:"test_builtin_dns_query.pcap" t - -let test_etc_hosts_query server use_host () = - let test_name = "vpnkit.is.cool.yes.really" in - let t _ stack = - set_dns_policy use_host >>= fun () -> - let resolver = DNS.create stack.Client.t in - DNS.gethostbyname ~server resolver test_name >>= function - | (_ :: _) as ips -> - Log.err (fun f -> - f "This test relies on the name %s not existing but it really \ - has IPs: %a" test_name pp_ips ips); - Fmt.kstrf failwith "Test name %s really does exist" test_name - | _ -> - Hosts.etc_hosts := [ - test_name, Ipaddr.V4 (Ipaddr.V4.localhost); - ]; - DNS.gethostbyname ~server resolver test_name >|= function - | (_ :: _) as ips -> - Log.info (fun f -> f "Name %s has IPs: %a" test_name pp_ips ips); - Hosts.etc_hosts := [] - | _ -> - Log.err (fun f -> f "Failed to lookup name from /etc/hosts"); - Hosts.etc_hosts := []; - failwith "failed to lookup name from /etc/hosts" - in - run ~pcap:"test_etc_hosts_query.pcap" t - -let test_etc_hosts_priority server use_host () = - let name = "builtins.should.be.higher.priority" in - let builtin_ip = Ipaddr.of_string_exn "127.0.0.1" in - let hosts_ip = Ipaddr.of_string_exn "127.0.0.2" in - let t _ stack = - set_dns_policy ~builtin_names:[ Dns.Name.of_string name, builtin_ip ] use_host - >>= fun () -> - Hosts.etc_hosts := [ - name, hosts_ip; - ]; - let resolver = DNS.create stack.Client.t in - DNS.gethostbyname ~server resolver name >>= function - | [ ip ] -> - Log.info (fun f -> f "%s has single IP: %a" name Ipaddr.pp_hum ip); - if Ipaddr.compare ip builtin_ip = 0 - then Lwt.return () - else failwith ("Builtin DNS names should have higher priority than /etc/hosts") - | (_ :: _) as ips -> - Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); - failwith ("Duplicate DNS names resolved for " ^ name); - | _ -> - Log.err (fun f -> f "Failed to lookup %s" name); - failwith ("Failed to lookup " ^ name) - in - run ~pcap:"test_etc_hosts_priority.pcap" t - let test_max_connections () = let t _ stack = Lwt.finalize (fun () -> @@ -373,21 +285,6 @@ let test_dhcp = [ ["check that the DHCP server works", `Quick, test_dhcp_query]; ] -let test_dns use_host = - let prefix = if use_host then "Host resolver" else "DNS forwarder" in [ - prefix ^ ": lookup ", - ["", `Quick, test_dns_query primary_dns_ip use_host]; - - prefix ^ ": builtins", - [ "", `Quick, test_builtin_dns_query primary_dns_ip use_host ]; - - prefix ^ ": _etc_hosts", - [ "", `Quick, test_etc_hosts_query primary_dns_ip use_host ]; - - prefix ^ ": _etc_hosts_priority", - [ "", `Quick, test_etc_hosts_priority primary_dns_ip use_host ]; - ] - let test_tcp = [ "HTTP GET", [ "HTTP GET http://www.google.com/", `Quick, test_http_fetch ]; @@ -412,7 +309,7 @@ let test_tcp = [ let tests = Hosts_test.tests @ Forwarding.tests @ test_dhcp - @ (test_dns true) @ (test_dns false) + @ Test_dns.suite @ test_tcp @ Test_nat.tests @ Test_http.tests @ Test_http.Exclude.tests @ Test_half_close.tests @ Test_ping.tests @ Test_bridge.tests @ Test_forward_protocol.suite diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml new file mode 100644 index 000000000..e59fbc23b --- /dev/null +++ b/src/hostnet_test/test_dns.ml @@ -0,0 +1,126 @@ +open Lwt.Infix +open Slirp_stack + +let src = + let src = Logs.Src.create "dns" ~doc:"Test the DNS forwarder" in + Logs.Src.set_level src (Some Logs.Debug); + src + +module Log = (val Logs.src_log src : Logs.LOG) + +let pp_ips = Fmt.(list ~sep:(unit ", ") Ipaddr.pp_hum) +let pp_ip4s = Fmt.(list ~sep:(unit ", ") Ipaddr.V4.pp_hum) + +let run_test ?(timeout=Duration.of_sec 60) t = + let timeout = + Host.Time.sleep_ns timeout >>= fun () -> + Lwt.fail_with "timeout" + in + Host.Main.run @@ Lwt.pick [ timeout; t ] + +let run ?timeout ~pcap t = run_test ?timeout (with_stack ~pcap t) + +let set_dns_policy ?builtin_names use_host = + Mclock.connect () >|= fun clock -> + Dns_policy.remove ~priority:3; + Dns_policy.add ~priority:3 + ~config:(if use_host then `Host else Dns_policy.google_dns); + Slirp_stack.Debug.update_dns ?builtin_names clock + +let test_dns_query server use_host () = + let t _ stack = + set_dns_policy use_host >>= fun () -> + let resolver = DNS.create stack.Client.t in + DNS.gethostbyname ~server resolver "www.google.com" >|= function + | (_ :: _) as ips -> + Log.info (fun f -> f "www.google.com has IPs: %a" pp_ips ips); + | _ -> + Log.err (fun f -> f "Failed to lookup www.google.com"); + failwith "Failed to lookup www.google.com" + in + run ~pcap:"test_dns_query.pcap" t + +let test_builtin_dns_query server use_host () = + let name = "experimental.host.name.localhost" in + let t _ stack = + set_dns_policy ~builtin_names:[ Dns.Name.of_string name, Ipaddr.V4 (Ipaddr.V4.localhost) ] use_host + >>= fun () -> + let resolver = DNS.create stack.Client.t in + DNS.gethostbyname ~server resolver name >>= function + | (_ :: _) as ips -> + Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); + Lwt.return () + | _ -> + Log.err (fun f -> f "Failed to lookup %s" name); + failwith ("Failed to lookup " ^ name) + in + run ~pcap:"test_builtin_dns_query.pcap" t + +let test_etc_hosts_query server use_host () = + let test_name = "vpnkit.is.cool.yes.really" in + let t _ stack = + set_dns_policy use_host >>= fun () -> + let resolver = DNS.create stack.Client.t in + DNS.gethostbyname ~server resolver test_name >>= function + | (_ :: _) as ips -> + Log.err (fun f -> + f "This test relies on the name %s not existing but it really \ + has IPs: %a" test_name pp_ips ips); + Fmt.kstrf failwith "Test name %s really does exist" test_name + | _ -> + Hosts.etc_hosts := [ + test_name, Ipaddr.V4 (Ipaddr.V4.localhost); + ]; + DNS.gethostbyname ~server resolver test_name >|= function + | (_ :: _) as ips -> + Log.info (fun f -> f "Name %s has IPs: %a" test_name pp_ips ips); + Hosts.etc_hosts := [] + | _ -> + Log.err (fun f -> f "Failed to lookup name from /etc/hosts"); + Hosts.etc_hosts := []; + failwith "failed to lookup name from /etc/hosts" + in + run ~pcap:"test_etc_hosts_query.pcap" t + +let test_etc_hosts_priority server use_host () = + let name = "builtins.should.be.higher.priority" in + let builtin_ip = Ipaddr.of_string_exn "127.0.0.1" in + let hosts_ip = Ipaddr.of_string_exn "127.0.0.2" in + let t _ stack = + set_dns_policy ~builtin_names:[ Dns.Name.of_string name, builtin_ip ] use_host + >>= fun () -> + Hosts.etc_hosts := [ + name, hosts_ip; + ]; + let resolver = DNS.create stack.Client.t in + DNS.gethostbyname ~server resolver name >>= function + | [ ip ] -> + Log.info (fun f -> f "%s has single IP: %a" name Ipaddr.pp_hum ip); + if Ipaddr.compare ip builtin_ip = 0 + then Lwt.return () + else failwith ("Builtin DNS names should have higher priority than /etc/hosts") + | (_ :: _) as ips -> + Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); + failwith ("Duplicate DNS names resolved for " ^ name); + | _ -> + Log.err (fun f -> f "Failed to lookup %s" name); + failwith ("Failed to lookup " ^ name) + in + run ~pcap:"test_etc_hosts_priority.pcap" t + +let test_dns use_host = + let prefix = if use_host then "Host resolver" else "DNS forwarder" in [ + prefix ^ ": lookup ", + ["", `Quick, test_dns_query primary_dns_ip use_host]; + + prefix ^ ": builtins", + [ "", `Quick, test_builtin_dns_query primary_dns_ip use_host ]; + + prefix ^ ": _etc_hosts", + [ "", `Quick, test_etc_hosts_query primary_dns_ip use_host ]; + + prefix ^ ": _etc_hosts_priority", + [ "", `Quick, test_etc_hosts_priority primary_dns_ip use_host ]; + ] + +let suite = test_dns true @ (test_dns false) From 0054721b787330c690c692d23ca000af2e14760d Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 15 Mar 2019 17:22:54 +0000 Subject: [PATCH 2/9] test: add a skeleton UDP server for a DNS test Signed-off-by: David Scott --- src/hostnet_test/test_dns.ml | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index e59fbc23b..4b4bf00e5 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -123,4 +123,36 @@ let test_dns use_host = [ "", `Quick, test_etc_hosts_priority primary_dns_ip use_host ]; ] -let suite = test_dns true @ (test_dns false) +module Server = struct + open Host.Sockets.Datagram + type t = { + ip: Ipaddr.t; + port: int; + server: Udp.server; + } + let with_server ip f = + Udp.bind ~description:"DNS server" (ip, 0) + >>= fun server -> + Udp.listen server + (fun _flow -> + Log.debug (fun f -> f "Received UDP datagram"); + Lwt.return_unit + ); + let _, realport = Udp.getsockname server in + let t = { ip; port = realport; server } in + Lwt.finalize (fun () -> f t.port) (fun () -> Udp.shutdown t.server) +end + +let truncate_big_response () = + let t _ _stack = + let ip = Ipaddr.V4 Ipaddr.V4.localhost in + Server.with_server ip + (fun _port -> + Lwt.return_unit + ) in + run ~pcap:"truncate_big_response.pcap" t + +let suite = test_dns true @ (test_dns false) @ [ + "big UDP responses are truncated", + [ "", `Quick, truncate_big_response ] +] From 48dcc2495165acf51986dab0ac022cc2393418e5 Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 15 Mar 2019 17:32:15 +0000 Subject: [PATCH 3/9] test: make the DNS policy more flexible per test case Signed-off-by: David Scott --- src/hostnet_test/test_dns.ml | 39 +++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index 4b4bf00e5..f0806288a 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -20,16 +20,17 @@ let run_test ?(timeout=Duration.of_sec 60) t = let run ?timeout ~pcap t = run_test ?timeout (with_stack ~pcap t) -let set_dns_policy ?builtin_names use_host = +let default_upstream_dns = Dns_policy.google_dns + +let set_dns_policy ?builtin_names config = Mclock.connect () >|= fun clock -> Dns_policy.remove ~priority:3; - Dns_policy.add ~priority:3 - ~config:(if use_host then `Host else Dns_policy.google_dns); + Dns_policy.add ~priority:3 ~config; Slirp_stack.Debug.update_dns ?builtin_names clock -let test_dns_query server use_host () = +let test_dns_query server config () = let t _ stack = - set_dns_policy use_host >>= fun () -> + set_dns_policy config >>= fun () -> let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver "www.google.com" >|= function | (_ :: _) as ips -> @@ -40,10 +41,10 @@ let test_dns_query server use_host () = in run ~pcap:"test_dns_query.pcap" t -let test_builtin_dns_query server use_host () = +let test_builtin_dns_query server config () = let name = "experimental.host.name.localhost" in let t _ stack = - set_dns_policy ~builtin_names:[ Dns.Name.of_string name, Ipaddr.V4 (Ipaddr.V4.localhost) ] use_host + set_dns_policy ~builtin_names:[ Dns.Name.of_string name, Ipaddr.V4 (Ipaddr.V4.localhost) ] config >>= fun () -> let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver name >>= function @@ -56,10 +57,10 @@ let test_builtin_dns_query server use_host () = in run ~pcap:"test_builtin_dns_query.pcap" t -let test_etc_hosts_query server use_host () = +let test_etc_hosts_query server config () = let test_name = "vpnkit.is.cool.yes.really" in let t _ stack = - set_dns_policy use_host >>= fun () -> + set_dns_policy config >>= fun () -> let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver test_name >>= function | (_ :: _) as ips -> @@ -82,12 +83,12 @@ let test_etc_hosts_query server use_host () = in run ~pcap:"test_etc_hosts_query.pcap" t -let test_etc_hosts_priority server use_host () = +let test_etc_hosts_priority server config () = let name = "builtins.should.be.higher.priority" in let builtin_ip = Ipaddr.of_string_exn "127.0.0.1" in let hosts_ip = Ipaddr.of_string_exn "127.0.0.2" in let t _ stack = - set_dns_policy ~builtin_names:[ Dns.Name.of_string name, builtin_ip ] use_host + set_dns_policy ~builtin_names:[ Dns.Name.of_string name, builtin_ip ] config >>= fun () -> Hosts.etc_hosts := [ name, hosts_ip; @@ -108,19 +109,19 @@ let test_etc_hosts_priority server use_host () = in run ~pcap:"test_etc_hosts_priority.pcap" t -let test_dns use_host = - let prefix = if use_host then "Host resolver" else "DNS forwarder" in [ +let test_dns config = + let prefix = Dns_policy.(Config.to_string @@ config ()) in [ prefix ^ ": lookup ", - ["", `Quick, test_dns_query primary_dns_ip use_host]; + ["", `Quick, test_dns_query primary_dns_ip config]; prefix ^ ": builtins", - [ "", `Quick, test_builtin_dns_query primary_dns_ip use_host ]; + [ "", `Quick, test_builtin_dns_query primary_dns_ip config ]; prefix ^ ": _etc_hosts", - [ "", `Quick, test_etc_hosts_query primary_dns_ip use_host ]; + [ "", `Quick, test_etc_hosts_query primary_dns_ip config ]; prefix ^ ": _etc_hosts_priority", - [ "", `Quick, test_etc_hosts_priority primary_dns_ip use_host ]; + [ "", `Quick, test_etc_hosts_priority primary_dns_ip config ]; ] module Server = struct @@ -148,11 +149,13 @@ let truncate_big_response () = let ip = Ipaddr.V4 Ipaddr.V4.localhost in Server.with_server ip (fun _port -> + set_dns_policy default_upstream_dns + >>= fun () -> Lwt.return_unit ) in run ~pcap:"truncate_big_response.pcap" t -let suite = test_dns true @ (test_dns false) @ [ +let suite = test_dns `Host @ (test_dns default_upstream_dns) @ [ "big UDP responses are truncated", [ "", `Quick, truncate_big_response ] ] From c18572275dfb875cfc55de8259877190c8125789 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 16 Mar 2019 20:10:06 +0000 Subject: [PATCH 4/9] test: flesh out the DNS client and server harness Signed-off-by: David Scott --- src/hostnet_test/test_dns.ml | 67 ++++++++++++++++++++++++++++++++---- 1 file changed, 60 insertions(+), 7 deletions(-) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index f0806288a..2162166d3 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -135,9 +135,48 @@ module Server = struct Udp.bind ~description:"DNS server" (ip, 0) >>= fun server -> Udp.listen server - (fun _flow -> + (fun flow -> Log.debug (fun f -> f "Received UDP datagram"); - Lwt.return_unit + let open Dns.Packet in + Udp.read flow + >>= function + | Error _ -> + Log.err (fun f -> f "Udp.listen failed to read"); + Lwt.return_unit + | Ok `Eof -> + Log.err (fun f -> f "Udp.read got EOF"); + Lwt.return_unit + | Ok (`Data buf) -> + let len = Cstruct.len buf in + begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with + | None -> + Log.err (fun f -> f "failed to parse DNS packet"); + Lwt.return_unit + | Some ({ questions = [ _question ]; _ } as request) -> + + let reply answers = + let id = request.id in + let detail = + { request.detail with Dns.Packet.qr = Dns.Packet.Response; ra = true } + in + let questions = request.questions in + let authorities = [] and additionals = [] in + { Dns.Packet.id; detail; questions; answers; authorities; additionals } + in + let answers = [] in + let buf = marshal @@ reply answers in + begin Udp.write flow buf + >>= function + | Ok () -> + Lwt.return_unit + | Error _ -> + Log.err (fun f -> f "Failed to send UDP response"); + Lwt.return_unit + end + | Some _ -> + Log.info (fun f -> f "Dropping unexpected DNS request"); + Lwt.return_unit + end ); let _, realport = Udp.getsockname server in let t = { ip; port = realport; server } in @@ -145,13 +184,27 @@ module Server = struct end let truncate_big_response () = - let t _ _stack = + let t _ stack = let ip = Ipaddr.V4 Ipaddr.V4.localhost in Server.with_server ip - (fun _port -> - set_dns_policy default_upstream_dns - >>= fun () -> - Lwt.return_unit + (fun port -> + let open Dns_forward.Config in + let servers = Server.Set.of_list [ + { Server.address = { Address.ip; port }; + zones = Domain.Set.empty; + timeout_ms = Some 2000; order = 0 + } + ] in + let config = `Upstream { servers; search = []; assume_offline_after_drops = None } in + set_dns_policy config + >>= fun () -> + let resolver = DNS.create stack.Client.t in + DNS.gethostbyname ~server:primary_dns_ip resolver "very.big.name" >|= function + | (_ :: _) as ips -> + Log.info (fun f -> f "very.big.name has IPs: %a" pp_ips ips); + | _ -> + Log.err (fun f -> f "Failed to lookup very.big.name"); + failwith "Failed to lookup very.big.name" ) in run ~pcap:"truncate_big_response.pcap" t From 97a4350f0a622ea90b88248a658e00b9e7968302 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Mar 2019 11:53:15 +0000 Subject: [PATCH 5/9] test: send a larger than 512 byte DNS response Signed-off-by: David Scott --- src/hostnet_test/test_dns.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index 2162166d3..632d38d04 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -131,7 +131,7 @@ module Server = struct port: int; server: Udp.server; } - let with_server ip f = + let with_server ip answers f = Udp.bind ~description:"DNS server" (ip, 0) >>= fun server -> Udp.listen server @@ -163,8 +163,8 @@ module Server = struct let authorities = [] and additionals = [] in { Dns.Packet.id; detail; questions; answers; authorities; additionals } in - let answers = [] in let buf = marshal @@ reply answers in + Log.info (fun f -> f "DNS response is a UDP datagram of length %d" (Cstruct.len buf)); begin Udp.write flow buf >>= function | Ok () -> @@ -186,7 +186,11 @@ end let truncate_big_response () = let t _ stack = let ip = Ipaddr.V4 Ipaddr.V4.localhost in - Server.with_server ip + (* The DNS response will be over 512 bytes *) + let answers = Array.to_list @@ Array.make 64 + { Dns.Packet.name = Dns.Name.of_string "anything"; cls = RR_IN; + flush = false; ttl = 0l; rdata = A Ipaddr.V4.localhost } in + Server.with_server ip answers (fun port -> let open Dns_forward.Config in let servers = Server.Set.of_list [ From 5428747e44d96b3143437d3634e69e8d5a603f8c Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Mar 2019 12:43:25 +0000 Subject: [PATCH 6/9] test: check if the large response has the TC bit set Note we parse only the DNS details because if the packet is truncated then `Dns.Protocol.Server.parse` will raise an exception (unhelpfully) Signed-off-by: David Scott --- src/hostnet_test/test_dns.ml | 65 +++++++++++++++++++++++++++++++----- 1 file changed, 56 insertions(+), 9 deletions(-) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index 632d38d04..8f2367cc5 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -124,6 +124,7 @@ let test_dns config = [ "", `Quick, test_etc_hosts_priority primary_dns_ip config ]; ] +(* A real UDP server listening on a physical port *) module Server = struct open Host.Sockets.Datagram type t = { @@ -137,7 +138,7 @@ module Server = struct Udp.listen server (fun flow -> Log.debug (fun f -> f "Received UDP datagram"); - let open Dns.Packet in + let open Dns.Packet in Udp.read flow >>= function | Error _ -> @@ -183,8 +184,47 @@ module Server = struct Lwt.finalize (fun () -> f t.port) (fun () -> Udp.shutdown t.server) end +let err_udp e = Fmt.kstrf failwith "%a" Client.UDPV4.pp_error e + +let udp_rpc client src_port dst dst_port buffer = + let udpv4 = Client.udpv4 client.Client.t in + let send_request () = + Client.UDPV4.write ~src_port ~dst ~dst_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> Lwt.return_unit in + + let response = ref None in + Client.listen_udpv4 client.Client.t ~port:src_port (fun ~src:_ ~dst:_ ~src_port:remote_src_port buffer -> + Log.debug (fun f -> + f "Received UDP %d -> %d" remote_src_port src_port); + begin match !response with + | Some _ -> () (* drop duplicates *) + | None -> response := Some buffer + end; + Lwt.return_unit + ); + let rec loop () = + send_request () + >>= fun () -> + match !response with + | Some x -> Lwt.return x + | None -> + Host.Time.sleep_ns (Duration.of_sec 1) + >>= fun () -> + loop () in + loop () + +let query_a name = + let open Dns.Packet in + let id = Random.int 0xffff in + let detail = { qr = Query; opcode = Standard; aa = false; tc = false; rd = true; ra = false; rcode = NoError } in + let questions = [ { q_name = Dns.Name.of_string name; q_type = Q_A; q_class = Q_IN; q_unicast = Q_Normal }] in + let answers = [] and authorities = [] and additionals = [] in + { id; detail; questions; answers; authorities; additionals } + let truncate_big_response () = - let t _ stack = + let t _ client = let ip = Ipaddr.V4 Ipaddr.V4.localhost in (* The DNS response will be over 512 bytes *) let answers = Array.to_list @@ Array.make 64 @@ -202,13 +242,20 @@ let truncate_big_response () = let config = `Upstream { servers; search = []; assume_offline_after_drops = None } in set_dns_policy config >>= fun () -> - let resolver = DNS.create stack.Client.t in - DNS.gethostbyname ~server:primary_dns_ip resolver "very.big.name" >|= function - | (_ :: _) as ips -> - Log.info (fun f -> f "very.big.name has IPs: %a" pp_ips ips); - | _ -> - Log.err (fun f -> f "Failed to lookup very.big.name"); - failwith "Failed to lookup very.big.name" + udp_rpc client 1024 primary_dns_ip 53 (Dns.Packet.marshal @@ query_a "very.big.name") + >>= fun response -> + Log.err (fun f -> f "UDP response has length %d" (Cstruct.len response)); + (* Manually parse the details field to look for the TC bit. The full parser will throw + an exception. + The header fields are: + - id: uint16 + - detail: uint16 *) + Cstruct.hexdump response; + let detail = Cstruct.BE.get_uint16 response 2 in + let tc = (detail lsr 9 land 1) <> 0 in + if not tc then failwith "DNS packet does not have TC bit set"; + Log.info (fun f -> f "DNS response has truncated bit set"); + Lwt.return_unit ) in run ~pcap:"truncate_big_response.pcap" t From ea048e0e0c34427880fdb791ce47a2ab42b45e53 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Mar 2019 14:47:40 +0000 Subject: [PATCH 7/9] test: reset the DNS configuration after the TC test Signed-off-by: David Scott --- src/hostnet_test/slirp_stack.ml | 2 ++ src/hostnet_test/test_dns.ml | 43 ++++++++++++++++++++------------- 2 files changed, 28 insertions(+), 17 deletions(-) diff --git a/src/hostnet_test/slirp_stack.ml b/src/hostnet_test/slirp_stack.ml index 65ea42890..d2ab2e0a3 100644 --- a/src/hostnet_test/slirp_stack.ml +++ b/src/hostnet_test/slirp_stack.ml @@ -39,6 +39,8 @@ module Dns_policy = struct let t = ref (IntMap.add 0 google_dns IntMap.empty) + let clear () = t := (IntMap.add 0 google_dns IntMap.empty) + let config () = snd @@ IntMap.max_binding !t diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index 8f2367cc5..0d42149d3 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -24,10 +24,15 @@ let default_upstream_dns = Dns_policy.google_dns let set_dns_policy ?builtin_names config = Mclock.connect () >|= fun clock -> - Dns_policy.remove ~priority:3; - Dns_policy.add ~priority:3 ~config; + Dns_policy.remove ~priority:4; + Dns_policy.add ~priority:4 ~config; Slirp_stack.Debug.update_dns ?builtin_names clock +let reset_dns_policy () = + Dns_policy.clear (); + Mclock.connect () >|= fun clock -> + Slirp_stack.Debug.update_dns clock + let test_dns_query server config () = let t _ stack = set_dns_policy config >>= fun () -> @@ -242,21 +247,25 @@ let truncate_big_response () = let config = `Upstream { servers; search = []; assume_offline_after_drops = None } in set_dns_policy config >>= fun () -> - udp_rpc client 1024 primary_dns_ip 53 (Dns.Packet.marshal @@ query_a "very.big.name") - >>= fun response -> - Log.err (fun f -> f "UDP response has length %d" (Cstruct.len response)); - (* Manually parse the details field to look for the TC bit. The full parser will throw - an exception. - The header fields are: - - id: uint16 - - detail: uint16 *) - Cstruct.hexdump response; - let detail = Cstruct.BE.get_uint16 response 2 in - let tc = (detail lsr 9 land 1) <> 0 in - if not tc then failwith "DNS packet does not have TC bit set"; - Log.info (fun f -> f "DNS response has truncated bit set"); - Lwt.return_unit - ) in + Lwt.finalize + (fun () -> + udp_rpc client 1024 primary_dns_ip 53 (Dns.Packet.marshal @@ query_a "very.big.name") + >>= fun response -> + Log.err (fun f -> f "UDP response has length %d" (Cstruct.len response)); + (* Manually parse the details field to look for the TC bit. The full parser will throw + an exception. + The header fields are: + - id: uint16 + - detail: uint16 *) + Cstruct.hexdump response; + let detail = Cstruct.BE.get_uint16 response 2 in + let tc = (detail lsr 9 land 1) <> 0 in + if not tc then failwith "DNS packet does not have TC bit set"; + Log.info (fun f -> f "DNS response has truncated bit set"); + Lwt.return_unit + ) reset_dns_policy + ) + in run ~pcap:"truncate_big_response.pcap" t let suite = test_dns `Host @ (test_dns default_upstream_dns) @ [ From dcaa4d10fe3f043a3611d79d4792a5f8917ab58b Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 20 Mar 2019 16:49:04 +0000 Subject: [PATCH 8/9] test: check truncated DNS responses are still valid responses Although the spec is written ambigiously, practice seems to be to truncate the answers list but not the raw packet itself. Signed-off-by: David Scott --- src/hostnet_test/test_dns.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index 0d42149d3..d973be9e7 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -252,17 +252,17 @@ let truncate_big_response () = udp_rpc client 1024 primary_dns_ip 53 (Dns.Packet.marshal @@ query_a "very.big.name") >>= fun response -> Log.err (fun f -> f "UDP response has length %d" (Cstruct.len response)); - (* Manually parse the details field to look for the TC bit. The full parser will throw - an exception. - The header fields are: - - id: uint16 - - detail: uint16 *) - Cstruct.hexdump response; - let detail = Cstruct.BE.get_uint16 response 2 in - let tc = (detail lsr 9 land 1) <> 0 in - if not tc then failwith "DNS packet does not have TC bit set"; - Log.info (fun f -> f "DNS response has truncated bit set"); - Lwt.return_unit + begin match Dns.Protocol.Server.parse response with + | None -> + failwith "failed to parse truncated DNS response" + | Some { Dns.Packet.detail = { tc = true; _ }; answers; _ } -> + Log.info (fun f -> f "DNS response has truncated bit set"); + if List.length answers <> 29 + then failwith (Printf.sprintf "expected 29 answers, got %d" (List.length answers)); + Lwt.return_unit + | Some { Dns.Packet.detail = { tc = false; _ }; _ } -> + failwith "DNS response does not have truncated bit set" + end ) reset_dns_policy ) in From ea9dbeaf887f5dad8391f4a34d127501fb6bbf64 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Mar 2019 14:11:58 +0000 Subject: [PATCH 9/9] dns: if UDP response is over 512 bytes, truncate and set TC From https://www.ietf.org/rfc/rfc1035.txt > 4.2.1. UDP usage > > Messages sent using UDP user server port 53 (decimal). > > Messages carried by UDP are restricted to 512 bytes (not counting the IP > or UDP headers). Longer messages are truncated and the TC bit is set in > the header. Note we need to handle 2 cases: 1. we have gathered the answer RRs ourselves 2. we have received a marshalled buffer from ocaml-dns-forward Signed-off-by: David Scott --- src/hostnet/hostnet_dns.ml | 88 +++++++++++++++++++++++++++++++++----- 1 file changed, 77 insertions(+), 11 deletions(-) diff --git a/src/hostnet/hostnet_dns.ml b/src/hostnet/hostnet_dns.ml index ab74e1024..a1b312223 100644 --- a/src/hostnet/hostnet_dns.ml +++ b/src/hostnet/hostnet_dns.ml @@ -7,6 +7,9 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) +(* Maximum size of a UDP DNS response before we must truncate *) +let max_udp_response = 512 + module Config = struct type t = [ | `Upstream of Dns_forward.Config.t @@ -326,6 +329,24 @@ struct Log.info (fun f -> f "Will use the host's DNS resolver"); Lwt.return { local_ip; builtin_names; resolver = Host } + let search f low high = + if not(f low) + then None (* none of the elements satisfy the predicate *) + else + let rec loop low high = + if low = high + then Some low + else + let mid = (low + high + 1) / 2 in + (* since low <> high, mid <> low but it might be mid = high *) + if f mid + then loop mid high + else + if mid = high + then Some low + else loop low mid in + loop low high + let answer t is_tcp buf = let open Dns.Packet in let len = Cstruct.len buf in @@ -333,10 +354,10 @@ struct | None -> Lwt.return (Error (`Msg "failed to parse DNS packet")) | Some ({ questions = [ question ]; _ } as request) -> - let reply answers = + let reply ~tc answers = let id = request.id in let detail = - { request.detail with Dns.Packet.qr = Dns.Packet.Response; ra = true } + { request.detail with Dns.Packet.qr = Dns.Packet.Response; ra = true; tc } in let questions = request.questions in let authorities = [] and additionals = [] in @@ -354,31 +375,70 @@ struct { Dns.Packet.id; detail; questions; answers; authorities; additionals } in + let marshal_reply answers = + let buf = marshal @@ reply ~tc:false answers in + if is_tcp + then Some buf (* No need to truncate for TCP *) + else begin + (* If the packet is too big then set the TC bit and truncate by dropping answers *) + let take n from = + let rec loop n from acc = match n, from with + | 0, _ -> acc + | _, [] -> acc + | n, x :: xs -> loop (n - 1) xs (x :: acc) in + List.rev @@ loop n from [] in + if Cstruct.len buf > max_udp_response then begin + match search (fun num -> + (* use only the first 'num' answers *) + Cstruct.len (marshal @@ reply ~tc:true (take num answers)) <= max_udp_response + ) 0 (List.length answers) with + | None -> None + | Some num -> Some (marshal @@ reply ~tc:true (take num answers)) + end + else Some buf + end in begin (* Consider the builtins (from the command-line) to have higher priority than the addresses in the /etc/hosts file. *) match try_builtins t.builtin_names question with | `Does_not_exist -> - Lwt.return (Ok (marshal nxdomain)) + Lwt.return (Ok (Some (marshal nxdomain))) | `Answers answers -> - Lwt.return (Ok (marshal @@ reply answers)) + Lwt.return (Ok (marshal_reply answers)) | `Dont_know -> match try_etc_hosts question with | Some answers -> - Lwt.return (Ok (marshal @@ reply answers)) + Lwt.return (Ok (marshal_reply answers)) | None -> match is_tcp, t.resolver with | true, Upstream { dns_tcp_resolver; _ } -> - Dns_tcp_resolver.answer buf dns_tcp_resolver + begin + Dns_tcp_resolver.answer buf dns_tcp_resolver + >>= function + | Error e -> Lwt.return (Error e) + | Ok buf -> Lwt.return (Ok (Some buf)) + end | false, Upstream { dns_udp_resolver; _ } -> - Dns_udp_resolver.answer buf dns_udp_resolver + begin + Dns_udp_resolver.answer buf dns_udp_resolver + >>= function + | Error e -> Lwt.return (Error e) + | Ok buf -> + (* We need to parse and re-marshal so we can set the TC bit and truncate *) + begin match Dns.Protocol.Server.parse buf with + | None -> + Lwt.return (Error (`Msg "Failed to unmarshal DNS response from upstream")) + | Some { answers; _ } -> + Lwt.return (Ok (marshal_reply answers)) + end + end | _, Host -> D.resolve question >>= function | [] -> - Lwt.return (Ok (marshal nxdomain)) + Lwt.return (Ok (Some (marshal nxdomain))) | answers -> - Lwt.return (Ok (marshal @@ reply answers)) + Lwt.return (Ok (marshal_reply answers)) end | _ -> Lwt.return (Error (`Msg "DNS packet had multiple questions")) @@ -395,7 +455,10 @@ struct | Error (`Msg m) -> Log.warn (fun f -> f "%s lookup failed: %s" (describe buf) m); Lwt.return (Ok ()) - | Ok buffer -> + | Ok None -> + Log.err (fun f -> f "%s unable to marshal response" (describe buf)); + Lwt.return (Ok ()) + | Ok (Some buffer) -> Udp.write ~src_port:53 ~dst:src ~dst_port:src_port udp buffer let handle_tcp ~t = @@ -414,7 +477,10 @@ struct | Error (`Msg m) -> Log.warn (fun f -> f "%s lookup failed: %s" (describe request) m); Lwt.return_unit - | Ok buffer -> + | Ok None -> + Log.err (fun f -> f "%s unable to marshal response to" (describe request)); + Lwt.return_unit + | Ok (Some buffer) -> Dns_tcp_framing.write packets buffer >>= function | Error (`Msg m) -> Log.warn (fun f ->