From adeaea5a239c81c8bb1fe068a95596d6bf9ac88c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Aug 2019 23:08:20 +0200 Subject: [PATCH] client: use Randomconv.int16, provide rng via create --- client/dns_client.ml | 4 ++-- client/dns_client.mli | 12 +++--------- client/dns_client_flow.ml | 15 ++++++++++++--- client/dns_client_flow.mli | 18 ++++++++++++++---- dns-mirage-client.opam | 1 + lwt/client/dns_client_lwt.ml | 14 ++++++++++---- mirage/client/dns_mirage_client.ml | 12 +++++++++--- mirage/client/dns_mirage_client.mli | 2 +- mirage/client/dune | 2 +- unix/client/dns_client_unix.ml | 14 ++++++++++---- 10 files changed, 63 insertions(+), 31 deletions(-) diff --git a/client/dns_client.ml b/client/dns_client.ml index 32e4ef3e1..1cec891f4 100644 --- a/client/dns_client.ml +++ b/client/dns_client.ml @@ -6,13 +6,13 @@ type 'key query_state = query : Packet.t ; } constraint 'key = 'a Rr_map.key -let make_query protocol hostname +let make_query rng protocol hostname : 'xy -> Cstruct.t * 'xy query_state = (* SRV records: Service + Protocol are case-insensitive, see RFC2728 pg2. *) fun record_type -> let question = Packet.Question.create hostname record_type in - let header = Random.int 0xffff (* TODO *), Packet.Flags.singleton `Recursion_desired in + let header = Randomconv.int16 rng, Packet.Flags.singleton `Recursion_desired in let query = Packet.create header question `Query in let cs , _ = Packet.encode protocol query in begin match protocol with diff --git a/client/dns_client.mli b/client/dns_client.mli index 3ce4fe10f..05fc13362 100644 --- a/client/dns_client.mli +++ b/client/dns_client.mli @@ -18,18 +18,12 @@ type 'key query_state constraint 'key = 'a Dns.Rr_map.key *) val make_query : - Dns.proto -> 'a Domain_name.t -> + (int -> Cstruct.t) -> Dns.proto -> 'a Domain_name.t -> 'query_type Dns.Rr_map.key -> Cstruct.t * 'query_type Dns.Rr_map.key query_state -(** [make_query protocol name query_type] is [query, query_state] +(** [make_query rng protocol name query_type] is [query, query_state] where [query] is the serialized DNS query to send to the name server, - and [query_state] is the information required to validate the response. - - NB: When querying for [TLSA] records, it is important to use the optional - [~hostname:false] parameter with the conversion functions within {!Domain_name} - when constructing the {!Domain_name.t} for the search, since these contain - labels prefixed with underscores. -*) + and [query_state] is the information required to validate the response. *) val parse_response : 'query_type Dns.Rr_map.key query_state -> Cstruct.t -> ('query_type, [`Msg of string | `Partial]) result diff --git a/client/dns_client_flow.ml b/client/dns_client_flow.ml index d56622ec4..ee3703f69 100644 --- a/client/dns_client_flow.ml +++ b/client/dns_client_flow.ml @@ -1,3 +1,11 @@ + +let stdlib_random n = + let b = Cstruct.create n in + for i = 0 to pred n do + Cstruct.set_uint8 b i (Random.int 256) + done; + b + module type S = sig type flow type +'a io @@ -6,9 +14,10 @@ module type S = sig type stack type t - val create : ?nameserver:ns_addr -> stack -> t + val create : ?rng:(int -> Cstruct.t) -> ?nameserver:ns_addr -> stack -> t val nameserver : t -> ns_addr + val rng : t -> (int -> Cstruct.t) val connect : ?nameserver:ns_addr -> t -> (flow, [> `Msg of string ]) result io val send : flow -> Cstruct.t -> (unit, [> `Msg of string ]) result io @@ -22,7 +31,7 @@ end module Make = functor (Uflow:S) -> struct - let create ?nameserver stack = Uflow.create ?nameserver stack + let create ?rng ?nameserver stack = Uflow.create ?rng ?nameserver stack let nameserver t = Uflow.nameserver t @@ -41,7 +50,7 @@ struct : (requested, [> `Msg of string]) result Uflow.io = let proto, _ = match nameserver with None -> Uflow.nameserver t | Some x -> x in let tx, state = - Dns_client.make_query + Dns_client.make_query (Uflow.rng t) (match proto with `UDP -> `Udp | `TCP -> `Tcp) name query_type in Uflow.connect ?nameserver t >>| fun socket -> diff --git a/client/dns_client_flow.mli b/client/dns_client_flow.mli index a77ae62b6..c74864aaa 100644 --- a/client/dns_client_flow.mli +++ b/client/dns_client_flow.mli @@ -4,6 +4,13 @@ better solution presents itself. *) +val stdlib_random : int -> Cstruct.t +(** [stdlib_random len] is a buffer of size [len], filled with random data. + This function is used by default (in the Unix and Lwt implementations) for + filling the ID field of the DNS packet. Internally, the {!Random} module + from the OCaml standard library is used, which is not cryptographically + secure. If desired {!Nocrypto.Rng.generate} can be passed to {!S.create}. *) + module type S = sig type flow (** A flow is a connection produced by {!U.connect} *) @@ -32,14 +39,17 @@ module type S = sig type t (** The abstract state of a DNS client. *) - val create : ?nameserver:ns_addr -> stack -> t - (** [create ~nameserver stack] creates the state record of the DNS client. *) + val create : ?rng:(int -> Cstruct.t) -> ?nameserver:ns_addr -> stack -> t + (** [create ~rng ~nameserver stack] creates the state record of the DNS client. *) val nameserver : t -> ns_addr (** The address of a nameserver that is supposed to work with the underlying flow, can be used if the user does not want to bother with configuring their own.*) + val rng : t -> (int -> Cstruct.t) + (** [rng t] is a random number generator. *) + val connect : ?nameserver:ns_addr -> t -> (flow, [> `Msg of string ]) result io (** [connect addr] is a new connection ([flow]) to [addr], or an error. *) @@ -61,8 +71,8 @@ end module Make : functor (U : S) -> sig - val create : ?nameserver:U.ns_addr -> U.stack -> U.t - (** [create ~nameserver stack] creates the state of the DNS client. *) + val create : ?rng:(int -> Cstruct.t) -> ?nameserver:U.ns_addr -> U.stack -> U.t + (** [create ~rng ~nameserver stack] creates the state of the DNS client. *) val nameserver : U.t -> U.ns_addr (** [nameserver t] returns the default nameserver to be used. *) diff --git a/dns-mirage-client.opam b/dns-mirage-client.opam index af88ceda0..8adc9c99e 100644 --- a/dns-mirage-client.opam +++ b/dns-mirage-client.opam @@ -18,6 +18,7 @@ depends: [ "domain-name" {>= "0.3.0"} "ipaddr" {>= "3.0.0"} "mirage-stack-lwt" + "mirage-random" "dns-client" {= version} ] synopsis: "DNS client library for MirageOS" diff --git a/lwt/client/dns_client_lwt.ml b/lwt/client/dns_client_lwt.ml index 6e89bae9d..f55abb483 100644 --- a/lwt/client/dns_client_lwt.ml +++ b/lwt/client/dns_client_lwt.ml @@ -16,12 +16,18 @@ module Uflow : Dns_client_flow.S type ns_addr = [`TCP | `UDP] * io_addr type +'a io = 'a Lwt.t type stack = unit - type t = { nameserver : ns_addr } + type t = { + rng : (int -> Cstruct.t) ; + nameserver : ns_addr ; + } - let create ?(nameserver = `TCP, (Unix.inet_addr_of_string "91.239.100.100", 53)) () = - { nameserver } + let create + ?(rng = Dns_client_flow.stdlib_random) + ?(nameserver = `TCP, (Unix.inet_addr_of_string "91.239.100.100", 53)) () = + { rng ; nameserver } - let nameserver { nameserver } = nameserver + let nameserver { nameserver ; _ } = nameserver + let rng { rng ; _ } = rng let close socket = Lwt.catch (fun () -> Lwt_unix.close socket) (fun _ -> Lwt.return_unit) diff --git a/mirage/client/dns_mirage_client.ml b/mirage/client/dns_mirage_client.ml index 9ccfde2a6..47d1ec9a6 100644 --- a/mirage/client/dns_mirage_client.ml +++ b/mirage/client/dns_mirage_client.ml @@ -3,7 +3,7 @@ open Lwt.Infix let src = Logs.Src.create "dns_mirage_client" ~doc:"effectful DNS client layer" module Log = (val Logs.src_log src : Logs.LOG) -module Make (S : Mirage_stack_lwt.V4) = struct +module Make (R : Mirage_random.C) (S : Mirage_stack_lwt.V4) = struct module Uflow : Dns_client_flow.S with type flow = S.TCPV4.flow @@ -16,14 +16,20 @@ module Make (S : Mirage_stack_lwt.V4) = struct type ns_addr = [`TCP | `UDP] * io_addr type +'a io = 'a Lwt.t type t = { + rng : (int -> Cstruct.t) ; nameserver : ns_addr ; stack : stack ; } - let create ?(nameserver = `TCP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) stack = - { nameserver ; stack } + let create + ?rng + ?(nameserver = `TCP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) + stack = + let rng = match rng with None -> R.generate ?g:None | Some x -> x in + { rng ; nameserver ; stack } let nameserver { nameserver ; _ } = nameserver + let rng { rng ; _ } = rng let bind = Lwt.bind let lift = Lwt.return diff --git a/mirage/client/dns_mirage_client.mli b/mirage/client/dns_mirage_client.mli index a18d2d088..07b1b8ed1 100644 --- a/mirage/client/dns_mirage_client.mli +++ b/mirage/client/dns_mirage_client.mli @@ -1,5 +1,5 @@ -module Make (S : Mirage_stack_lwt.V4) : sig +module Make (R : Mirage_random.C) (S : Mirage_stack_lwt.V4) : sig module Uflow : Dns_client_flow.S with type flow = S.TCPV4.flow and type io_addr = Ipaddr.V4.t * int diff --git a/mirage/client/dune b/mirage/client/dune index dfba26b68..62c7a6dc5 100644 --- a/mirage/client/dune +++ b/mirage/client/dune @@ -1,6 +1,6 @@ (library (name dns_mirage_client) (public_name dns-mirage-client) - (libraries domain-name ipaddr mirage-stack-lwt dns-client) + (libraries domain-name ipaddr mirage-random mirage-stack-lwt dns-client) (wrapped false) ) \ No newline at end of file diff --git a/unix/client/dns_client_unix.ml b/unix/client/dns_client_unix.ml index b60ebd5a1..76f0e8d24 100644 --- a/unix/client/dns_client_unix.ml +++ b/unix/client/dns_client_unix.ml @@ -13,13 +13,19 @@ module Uflow : Dns_client_flow.S type ns_addr = [`TCP | `UDP] * io_addr type stack = unit type flow = Unix.file_descr - type t = { nameserver : ns_addr } + type t = { + rng : int -> Cstruct.t ; + nameserver : ns_addr ; + } type +'a io = 'a - let create ?(nameserver = `TCP, (Unix.inet_addr_of_string "91.239.100.100", 53)) () = - { nameserver } + let create + ?(rng = Dns_client_flow.stdlib_random) + ?(nameserver = `TCP, (Unix.inet_addr_of_string "91.239.100.100", 53)) () = + { rng ; nameserver } - let nameserver { nameserver } = nameserver + let nameserver { nameserver ; _ } = nameserver + let rng { rng ; _ } = rng let bind a b = b a let lift v = v