client: use Randomconv.int16, provide rng via create

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

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

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 ->

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. *)

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"

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)

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

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

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)
 )

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