From 9ed17dab4058d2a54b17eed723e5530b507c2186 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 3 May 2024 15:32:59 +0200 Subject: [PATCH 1/8] Provide a Miou implementation of dns-client --- dns-client-miou-unix.opam | 34 ++++++++++++++++++++++++++++ miou/client/dns_client_miou_unix.ml | 3 +++ miou/client/dns_client_miou_unix.mli | 6 +++++ miou/client/dune | 5 ++++ 4 files changed, 48 insertions(+) create mode 100644 dns-client-miou-unix.opam create mode 100644 miou/client/dns_client_miou_unix.ml create mode 100644 miou/client/dns_client_miou_unix.mli create mode 100644 miou/client/dune diff --git a/dns-client-miou-unix.opam b/dns-client-miou-unix.opam new file mode 100644 index 00000000..7c5959a7 --- /dev/null +++ b/dns-client-miou-unix.opam @@ -0,0 +1,34 @@ +opam-version: "2.0" +maintainer: "team AT robur dot coop" +authors: ["Robur "] +homepage: "https://github.com/mirage/ocaml-dns" +bug-reports: "https://github.com/mirage/ocaml-dns/issues" +dev-repo: "git+https://github.com/mirage/ocaml-dns.git" +license: "BSD-2-Clause" + +build: [ + [ "dune" "subst"] {dev} + [ "dune" "build" "-p" name "-j" jobs ] + [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} +] + +depends: [ + "dune" {>="2.0.0"} + "ocaml" {>= "4.08.0"} + "dns-client" {= "7.0.3"} + "domain-name" {>= "0.4.0"} + "ipaddr" {>= "5.3.0"} + "miou" {>= "0.1.0"} + "happy-eyeballs" {>= "0.6.0"} + "happy-eyeballs-miou-unix" +] +synopsis: "DNS client API for Miou" +description: """ +A client implementation using uDNS using Miou. +""" + +pin-depends: [ + [ "miou.dev" "git+https://github.com/robur-coop/miou.git#ed5087b832797616df073bd8ec9baed2ec4e474c" ] + [ "happy-eyeballs-miou-unix.0.6.0" "git+https://github.com/dinosaure/happy-eyeballs.git#4499f0d3fedb71d0585befe6422ab432825ad76d" ] + [ "tls-miou-unix.0.17.4" "git+https://github.com/dinosaure/ocaml-tls.git#d2c7a2f26e633bd5493adab8e0ae2f8fdff5ba00" ] +] diff --git a/miou/client/dns_client_miou_unix.ml b/miou/client/dns_client_miou_unix.ml new file mode 100644 index 00000000..a0e7298d --- /dev/null +++ b/miou/client/dns_client_miou_unix.ml @@ -0,0 +1,3 @@ +module Transport = Happy_eyeballs_miou_unix + +include Dns_client.Make (Transport) diff --git a/miou/client/dns_client_miou_unix.mli b/miou/client/dns_client_miou_unix.mli new file mode 100644 index 00000000..f11e1fee --- /dev/null +++ b/miou/client/dns_client_miou_unix.mli @@ -0,0 +1,6 @@ +module Transport : Dns_client.S + with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] + and type +'a io = 'a + and type stack = Happy_eyeballs_miou_unix.happy + +include module type of Dns_client.Make (Transport) diff --git a/miou/client/dune b/miou/client/dune new file mode 100644 index 00000000..53845938 --- /dev/null +++ b/miou/client/dune @@ -0,0 +1,5 @@ +(library + (name dns_client_miou_unix) + (modules dns_client_miou_unix) + (public_name dns-client-miou-unix) + (libraries happy-eyeballs-miou-unix)) From d9ad45b1f7bcc86e5dc478fd26114590a7de9a8e Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 3 May 2024 21:07:06 +0200 Subject: [PATCH 2/8] Update pin-depends --- dns-client-miou-unix.opam | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/dns-client-miou-unix.opam b/dns-client-miou-unix.opam index 7c5959a7..6fe5308b 100644 --- a/dns-client-miou-unix.opam +++ b/dns-client-miou-unix.opam @@ -15,7 +15,7 @@ build: [ depends: [ "dune" {>="2.0.0"} "ocaml" {>= "4.08.0"} - "dns-client" {= "7.0.3"} + "dns-client" {= version} "domain-name" {>= "0.4.0"} "ipaddr" {>= "5.3.0"} "miou" {>= "0.1.0"} @@ -28,7 +28,7 @@ A client implementation using uDNS using Miou. """ pin-depends: [ - [ "miou.dev" "git+https://github.com/robur-coop/miou.git#ed5087b832797616df073bd8ec9baed2ec4e474c" ] - [ "happy-eyeballs-miou-unix.0.6.0" "git+https://github.com/dinosaure/happy-eyeballs.git#4499f0d3fedb71d0585befe6422ab432825ad76d" ] - [ "tls-miou-unix.0.17.4" "git+https://github.com/dinosaure/ocaml-tls.git#d2c7a2f26e633bd5493adab8e0ae2f8fdff5ba00" ] + [ "miou.dev" "git+https://git.robur.coop/robur/miou.git#ed5087b832797616df073bd8ec9baed2ec4e474c" ] + [ "happy-eyeballs-miou-unix.0.6.0" "git+https://github.com/dinosaure/happy-eyeballs.git#4ff9ff889500b764adcefaf719852298c8d51a40" ] + [ "tls-miou-unix.0.17.4" "git+https://github.com/dinosaure/ocaml-tls.git#6b635d130b83bb45007e374d828f877332ab2b2e" ] ] From fe5889b950a1ff1589b14fbb1d3d883c35421fb0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 22 Aug 2024 18:28:38 +0200 Subject: [PATCH 3/8] Implement the DNS protocol on the Miou implementation (it was previously into the happy-eyeballs implementation) --- miou/client/dns_client_miou_unix.ml | 185 ++++++++++++++++++++++++++- miou/client/dns_client_miou_unix.mli | 2 +- miou/client/dune | 2 +- 3 files changed, 186 insertions(+), 3 deletions(-) diff --git a/miou/client/dns_client_miou_unix.ml b/miou/client/dns_client_miou_unix.ml index a0e7298d..f58feb2b 100644 --- a/miou/client/dns_client_miou_unix.ml +++ b/miou/client/dns_client_miou_unix.ml @@ -1,3 +1,186 @@ -module Transport = Happy_eyeballs_miou_unix +let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt + +let src_daemon = Logs.Src.create "dns-client-miou-unix" + +module Log = (val Logs.src_log src_daemon : Logs.LOG) + +module Transport = struct + open Happy_eyeballs_miou_unix + + type +'a io = 'a + + type io_addr = + [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] + + type t = { + nameservers: io_addr list + ; proto: Dns.proto + ; timeout: float + ; happy: stack + } + and stack = Happy_eyeballs_miou_unix.t + + type context = + { fd : [ `Udp of Miou_unix.file_descr + | `Tcp of Miou_unix.file_descr + | `Tls of Tls_miou_unix.t ] + ; timeout : float } + + let clock = Mtime_clock.elapsed_ns + + let same_address ipaddr' port' = function + | `Plaintext (ipaddr, port) -> Ipaddr.compare ipaddr ipaddr' = 0 && port = port' + | `Tls (_, ipaddr, port) -> Ipaddr.compare ipaddr ipaddr' = 0 && port = port' + + exception Timeout + + let with_timeout ~timeout:ts fn = + let timeout () = Miou_unix.sleep ts; raise Timeout in + let prm1 = Miou.async timeout in + let prm0 = Miou.async fn in + Miou.await_first [ prm0; prm1 ] + + let connect_to_nameservers t = + let ( let* ) = Result.bind in + match t.proto with + | `Tcp -> + let ip_of_nameserver = function + | `Plaintext (ipaddr, port) -> (ipaddr, port) + | `Tls (_, ipaddr, port) -> (ipaddr, port) in + let ips = List.map ip_of_nameserver t.nameservers in + let* ((ipaddr, port) as addr), fd = connect_ip t.happy ips in + begin match List.find (same_address ipaddr port) t.nameservers with + | `Plaintext _ -> Ok (addr, `Tcp fd) + | `Tls (config, _, _) -> + try let fd = Tls_miou_unix.client_of_fd config fd in + Ok (addr, `Tls fd) + with End_of_file -> + Miou_unix.close fd; + error_msgf "Connection to nameservers (via TLS) impossible" end + | `Udp -> + let is_plaintext = function `Plaintext v -> Either.Left v | _ -> Either.Right () in + let[@warning "-8"] (ipaddr, port) :: _, _ = List.partition_map is_plaintext t.nameservers in + let proto_number, socket_type = Unix.((getprotobyname "udp").p_proto, SOCK_DGRAM) in + let domain = match ipaddr with + | Ipaddr.V4 _ -> Unix.PF_INET + | Ipaddr.V6 _ -> Unix.PF_INET6 in + let fd = Unix.socket domain socket_type proto_number in + let addr = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ipaddr, port) in + let connect () = + Unix.connect fd addr; + ((ipaddr, port), `Udp (Miou_unix.of_file_descr fd)) in + match with_timeout ~timeout:t.timeout connect with + | Ok value -> Ok value + | Error Timeout -> + Unix.close fd; + error_msgf "Connection to nameservers (via UDP) timeout" + | Error exn -> + Unix.close fd; + error_msgf "Unexpected error: %S" (Printexc.to_string exn) + + let nameservers { nameservers; proto; _ } = (proto, nameservers) + let bind x f = f x + let lift = Fun.id + let rng = Mirage_crypto_rng.generate ?g:None + + let connect t = + let ( let* ) = Result.bind in + let* ((addr, port), fd) = connect_to_nameservers t in + Log.debug (fun m -> m "Connected to a nameserver %a:%d" Ipaddr.pp addr port); + match fd with + | `Tcp _ | `Tls _ -> Ok (`Tcp, { fd; timeout= t.timeout }) + | `Udp _ -> Ok (`Udp, { fd; timeout= t.timeout }) + + let send_recv_tls ~timeout ~id fd str = + let send () = Tls_miou_unix.write fd str in + let recv () = + let rec go buf rx_len = + let expected_len = + if rx_len >= 2 then Some (Bytes.get_uint16_be buf 0) else None in + match expected_len with + | None -> + let len = Tls_miou_unix.read fd buf ~off:rx_len in + if rx_len + len >= 2 && len > 0 then go buf (rx_len + len) + else failwith "TLS connection closed by nameserver" + | Some expected_len when rx_len >= expected_len + 2 -> + let id' = Bytes.get_uint16_be buf 2 in + if id = id' + then Bytes.sub_string buf 0 (expected_len + 2) + else + let buf' = Bytes.make 2048 '\000' in + let rx_len' = rx_len - (expected_len + 2) in + Bytes.blit buf (expected_len + 2) buf' 0 rx_len'; + go buf' rx_len' + | Some expected_len when Bytes.length buf >= expected_len + 2 -> + let len = (expected_len + 2) - rx_len in + Tls_miou_unix.really_read fd buf ~off:rx_len ~len; + go buf (rx_len + len) + | Some expected_len -> + let buf' = Bytes.make (expected_len + 2) '\000' in + Bytes.blit buf 0 buf' 0 rx_len; + go buf rx_len in + go (Bytes.make 2048 '\000') 0 in + let ( >>= ) = Result.bind in + match with_timeout ~timeout send >>= fun () -> + with_timeout ~timeout recv with + | Ok _ as rx -> rx + | Error Timeout -> error_msgf "DNS request timeout" + | Error (Failure msg) -> Error (`Msg msg) + | Error (End_of_file | Tls_miou_unix.Closed_by_peer) -> + error_msgf "End of file reading from nameserver" + | Error exn -> + error_msgf "Got an unexpected exception: %s" + (Printexc.to_string exn) + + let send_recv { fd; timeout } str = + if String.length str > 4 then begin + match fd with + | `Tls fd -> + let id = String.get_int16_be str 2 in + send_recv_tls ~timeout ~id fd str + | `Udp fd | `Tcp fd -> + let fd = Miou_unix.to_file_descr fd in + Unix.clear_nonblock fd; + let send () = + Log.debug (fun m -> m "sending a dns packet to resolver"); + Unix.setsockopt_float fd Unix.SO_SNDTIMEO timeout; + let len = Unix.send_substring fd str 0 (String.length str) [] in + if len <> String.length str + then failwith "Broken write to upstream nameserver" in + let recv () = + let buffer = Bytes.make 2048 '\000' in + Unix.setsockopt_float fd Unix.SO_RCVTIMEO timeout; + let len = Unix.recv fd buffer 0 (Bytes.length buffer) [] in + (* TODO(dinosaure): should we check rx_len and continue until we got + the full packet (only for tcp/ip)? *) + if len > 0 && len <= Bytes.length buffer + then Bytes.sub_string buffer 0 len + else failwith "Reading from nameserver socket failed" in + let ( >>= ) = Result.bind in + match with_timeout ~timeout send >>= fun () -> + with_timeout ~timeout recv with + | Ok _ as rx -> rx + | Error Timeout -> error_msgf "DNS request timeout" + | Error (Failure msg) -> Error (`Msg msg) + | Error exn -> + error_msgf "Got an unexpected exception: %s" + (Printexc.to_string exn) + end + else error_msgf "Invalid context (data length <= 4)" + + let close { fd; _ } = match fd with + | `Tcp fd | `Udp fd -> Miou_unix.close fd + | `Tls fd -> Tls_miou_unix.close fd + + let of_ns ns = Int64.to_float ns /. 1_000_000_000. + + let create ?nameservers ~timeout happy = + let proto, nameservers = + match nameservers with + | None -> (`Udp, [ `Plaintext (Ipaddr.of_string_exn "8.8.8.8", 53) ]) + | Some (a, nss) -> (a, nss) + in + { nameservers; proto; timeout= of_ns timeout; happy } +end include Dns_client.Make (Transport) diff --git a/miou/client/dns_client_miou_unix.mli b/miou/client/dns_client_miou_unix.mli index f11e1fee..5abf44a8 100644 --- a/miou/client/dns_client_miou_unix.mli +++ b/miou/client/dns_client_miou_unix.mli @@ -1,6 +1,6 @@ module Transport : Dns_client.S with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] and type +'a io = 'a - and type stack = Happy_eyeballs_miou_unix.happy + and type stack = Happy_eyeballs_miou_unix.t include module type of Dns_client.Make (Transport) diff --git a/miou/client/dune b/miou/client/dune index 53845938..bab0731a 100644 --- a/miou/client/dune +++ b/miou/client/dune @@ -2,4 +2,4 @@ (name dns_client_miou_unix) (modules dns_client_miou_unix) (public_name dns-client-miou-unix) - (libraries happy-eyeballs-miou-unix)) + (libraries dns-client tls-miou-unix happy-eyeballs-miou-unix)) From d9f460e61e7bf386b6106dc94ed373f68958ab36 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 25 Aug 2024 10:06:42 +0200 Subject: [PATCH 4/8] Lint pin-depends --- dns-client-miou-unix.opam | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/dns-client-miou-unix.opam b/dns-client-miou-unix.opam index 6fe5308b..6ddb084c 100644 --- a/dns-client-miou-unix.opam +++ b/dns-client-miou-unix.opam @@ -28,7 +28,5 @@ A client implementation using uDNS using Miou. """ pin-depends: [ - [ "miou.dev" "git+https://git.robur.coop/robur/miou.git#ed5087b832797616df073bd8ec9baed2ec4e474c" ] - [ "happy-eyeballs-miou-unix.0.6.0" "git+https://github.com/dinosaure/happy-eyeballs.git#4ff9ff889500b764adcefaf719852298c8d51a40" ] - [ "tls-miou-unix.0.17.4" "git+https://github.com/dinosaure/ocaml-tls.git#6b635d130b83bb45007e374d828f877332ab2b2e" ] + [ "happy-eyeballs-miou-unix.1.1.0" "git+https://github.com/robur-coop/happy-eyeballs.git#2a2f276b547d9ac34c0ce9ca40a19b67c7db726f" ] ] From bb1a9b7cba4b9db534055e5044e53aa609cb29bb Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 25 Aug 2024 10:10:07 +0200 Subject: [PATCH 5/8] Add tls-miou-unix as a dependency for dns-client-miou-unix --- dns-client-miou-unix.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/dns-client-miou-unix.opam b/dns-client-miou-unix.opam index 6ddb084c..0db9dfa1 100644 --- a/dns-client-miou-unix.opam +++ b/dns-client-miou-unix.opam @@ -19,6 +19,7 @@ depends: [ "domain-name" {>= "0.4.0"} "ipaddr" {>= "5.3.0"} "miou" {>= "0.1.0"} + "tls-miou-unix" "happy-eyeballs" {>= "0.6.0"} "happy-eyeballs-miou-unix" ] From 00f8b6c66f7c3ba352c06e4b7cf4347112ea6f9b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 25 Aug 2024 20:15:52 +0200 Subject: [PATCH 6/8] Update dns-client-miou-unix.opam --- dns-client-miou-unix.opam | 4 ---- 1 file changed, 4 deletions(-) diff --git a/dns-client-miou-unix.opam b/dns-client-miou-unix.opam index 0db9dfa1..6868dd7e 100644 --- a/dns-client-miou-unix.opam +++ b/dns-client-miou-unix.opam @@ -27,7 +27,3 @@ synopsis: "DNS client API for Miou" description: """ A client implementation using uDNS using Miou. """ - -pin-depends: [ - [ "happy-eyeballs-miou-unix.1.1.0" "git+https://github.com/robur-coop/happy-eyeballs.git#2a2f276b547d9ac34c0ce9ca40a19b67c7db726f" ] -] From 852080053386c56927e40a0a4bfd95e015821350 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 25 Aug 2024 20:39:35 +0200 Subject: [PATCH 7/8] Update dns-client-miou-unix.opam --- dns-client-miou-unix.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dns-client-miou-unix.opam b/dns-client-miou-unix.opam index 6868dd7e..20063bff 100644 --- a/dns-client-miou-unix.opam +++ b/dns-client-miou-unix.opam @@ -14,7 +14,7 @@ build: [ depends: [ "dune" {>="2.0.0"} - "ocaml" {>= "4.08.0"} + "ocaml" {>= "5.0.0"} "dns-client" {= version} "domain-name" {>= "0.4.0"} "ipaddr" {>= "5.3.0"} From 8d97f0d3668b88139e7294c165f2e88a0b289982 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 25 Aug 2024 22:30:43 +0200 Subject: [PATCH 8/8] Fix a misleading variable into the TLS read loop of the Miou impl. --- miou/client/dns_client_miou_unix.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/miou/client/dns_client_miou_unix.ml b/miou/client/dns_client_miou_unix.ml index f58feb2b..d7b7134f 100644 --- a/miou/client/dns_client_miou_unix.ml +++ b/miou/client/dns_client_miou_unix.ml @@ -1,8 +1,8 @@ let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt -let src_daemon = Logs.Src.create "dns-client-miou-unix" +let src = Logs.Src.create "dns-client-miou-unix" -module Log = (val Logs.src_log src_daemon : Logs.LOG) +module Log = (val Logs.src_log src : Logs.LOG) module Transport = struct open Happy_eyeballs_miou_unix @@ -116,9 +116,12 @@ module Transport = struct Tls_miou_unix.really_read fd buf ~off:rx_len ~len; go buf (rx_len + len) | Some expected_len -> + (* NOTE(dinosaure): in this branch, [buf] is not large enough to store + the DNS packet. We allocate a new buffer which can store the actual + DNS packet and use it for the next [go] iteration. *) let buf' = Bytes.make (expected_len + 2) '\000' in Bytes.blit buf 0 buf' 0 rx_len; - go buf rx_len in + go buf' rx_len in go (Bytes.make 2048 '\000') 0 in let ( >>= ) = Result.bind in match with_timeout ~timeout send >>= fun () ->