rework usage of randomness in Dhcp_client

Dhcp_client.create used to call into Stdlibrandom (provided by mirage-random <=1.1.0).

Dhcp_client_lwt already depends on Mirage libraries, I added the Mirage_random.C
signature, and provide the random xid, if necessary, in Dhcp_client_lwt.

Author: hannesm

charrua-client.opam

@@ -21,6 +21,7 @@ depends: [
   "jbuilder" {build & >= "1.0+beta9"}
   "alcotest"     {test}
   "cstruct-unix" {test}
+  "mirage-random-test" {test}
   "charrua-core" {>= "0.10"}
   "cstruct" {>="3.0.2"}
   "ipaddr"

client/dhcp_client.ml

@@ -142,13 +142,9 @@ let offer t ~xid ~chaddr ~server_ip ~request_ip ~offer_options =
 (* make a new DHCP client. allow the user to request a specific xid, any
    requests, and the MAC address to use as the source for Ethernet messages and
    the chaddr in the fixed-length part of the message *)
-let create ?with_xid ?requests srcmac =
+let create ?requests xid srcmac =
   let open Constants in
   let open Dhcp_wire in
-  let xid = match with_xid with
-  | None -> Stdlibrandom.initialize (); Cstruct.BE.get_uint32 (Stdlibrandom.generate 4) 0
-  | Some xid -> xid
-  in
   let requests = match requests with
   | None | Some [] -> default_requests
   | Some requests -> requests
@@ -212,7 +208,7 @@ let input t buf =
     | Some DHCPACK, Renewing _
     | Some DHCPACK, Requesting _ -> `New_lease ({t with state = Bound incoming}, incoming)
     | Some DHCPNAK, Requesting _ | Some DHCPNAK, Renewing _ ->
-      `Response (create ~with_xid:(xid t) ~requests:t.request_options t.srcmac)
+      `Response (create ~requests:t.request_options (xid t) t.srcmac)
     | Some DHCPACK, Selecting _ (* too soon *)
     | Some DHCPACK, Bound _ -> (* too late *)
       `Noop

client/dhcp_client.mli

@@ -4,11 +4,11 @@ type buffer = Cstruct.t
 
 val pp : Format.formatter -> t -> unit
 
-val create : ?with_xid : Cstruct.uint32 -> ?requests : Dhcp_wire.option_code list -> Macaddr.t -> (t * buffer)
-(** [create mac] returns a pair of [t, buffer].  [t] represents the current 
+val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr.t -> (t * buffer)
+(** [create xid mac] returns a pair of [t, buffer].  [t] represents the current
  * state of the client in the lease transaction, and [buffer] is the suggested
  * next packet the caller should take to progress toward accepting a lease.
- * The optional argument [with_xid] allows the caller to specify a transaction ID
+ * The argument [xid] allows the caller to specify a transaction ID
  * to use for the lease attempt.
  * [requests] is a list of option codes which the client should ask for in its
  * attempt to get a DHCP lease.  If [requests] is not given, we'll make an educated

client/lwt/dhcp_client_lwt.ml

@@ -1,21 +1,25 @@
 let src = Logs.Src.create "dhcp_client_lwt"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Make(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct
+module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct
   open Lwt.Infix
 
   type lease = Dhcp_wire.pkt
 
   type t = lease Lwt_stream.t
 
   let connect ?(renew = true)
-              ?(with_xid)
+              ?xid
               ?(requests : Dhcp_wire.option_code list option) net =
     (* listener needs to occasionally check to see whether the state has advanced,
      * and if not, start a new attempt at a lease transaction *)
     let sleep_interval = Duration.of_sec 4 in
 
-    let (client, dhcpdiscover) = Dhcp_client.create ?with_xid ?requests (Net.mac net) in
+    let xid = match xid with
+      | None -> Cstruct.BE.get_uint32 (Random.generate 4) 0
+      | Some xid -> xid
+    in
+    let (client, dhcpdiscover) = Dhcp_client.create ?requests xid (Net.mac net) in
     let c = ref client in
 
     let rec do_renew c t =
@@ -42,7 +46,8 @@ module Make(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct
         match Dhcp_client.lease !c with
         | Some lease -> Lwt.return_unit
         | None ->
-          let (client, dhcpdiscover) = Dhcp_client.create ?requests (Net.mac net) in
+          let xid = Cstruct.BE.get_uint32 (Random.generate 4) 0 in
+          let (client, dhcpdiscover) = Dhcp_client.create ?requests xid (Net.mac net) in
           c := client;
           Log.info (fun f -> f "Timeout expired without a usable lease!  Starting over...");
           Log.debug (fun f -> f "New lease attempt: %a" Dhcp_client.pp !c);

client/lwt/dhcp_client_lwt.mli

@@ -1,11 +1,11 @@
-module Make(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) : sig
+module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) : sig
   type lease = Dhcp_wire.pkt
 
   type t = lease Lwt_stream.t
 
-  val connect : ?renew:bool -> ?with_xid : Cstruct.uint32 ->
+  val connect : ?renew:bool -> ?xid:Cstruct.uint32 ->
     ?requests:Dhcp_wire.option_code list -> Net.t -> t Lwt.t
-  (** [connect renew with_xid requests net] starts a DHCP client communicating
+  (** [connect renew ~xid requests net] starts a DHCP client communicating
       over the network interface [net].  The client will attempt to get a DHCP
       lease at least once, and will return any leases obtained in the stream
       returned by [connect].  If [renew] is true, which it is by default,

client/mirage/dhcp_client_mirage.ml

@@ -19,14 +19,14 @@ let config_of_lease lease : Mirage_protocols_lwt.ipv4_config option =
     | hd::_ ->
       Some Mirage_protocols_lwt.{ address; network; gateway = (Some hd) }
 
-module Make(Time : Mirage_types_lwt.TIME) (Net : Mirage_types_lwt.NETWORK) = struct
+module Make(Random : Mirage_random.C)(Time : Mirage_types_lwt.TIME) (Net : Mirage_types_lwt.NETWORK) = struct
   open Lwt.Infix
   open Mirage_protocols_lwt
 
   type t = ipv4_config Lwt_stream.t
 
   let connect ?(requests : Dhcp_wire.option_code list option) net =
-    let module Lwt_client = Dhcp_client_lwt.Make(Time)(Net) in
+    let module Lwt_client = Dhcp_client_lwt.Make(Random)(Time)(Net) in
     Lwt_client.connect ~renew:false ?requests net >>= fun lease_stream ->
     Lwt.return @@ Lwt_stream.filter_map config_of_lease lease_stream
 

client/mirage/dhcp_client_mirage.mli

@@ -1,4 +1,4 @@
-module Make(Time : Mirage_types_lwt.TIME) (Network : Mirage_types_lwt.NETWORK) : sig
+module Make(Random : Mirage_random.C)(Time : Mirage_types_lwt.TIME) (Network : Mirage_types_lwt.NETWORK) : sig
   type t = Mirage_protocols_lwt.ipv4_config Lwt_stream.t
   val connect : ?requests:Dhcp_wire.option_code list
     -> Network.t -> t Lwt.t

test/client/jbuild

@@ -2,7 +2,7 @@
 
 (executables
  ((names (test_client))
-  (libraries (cstruct-unix alcotest charrua-client charrua-core.server tcpip.unix))))
+  (libraries (cstruct-unix alcotest charrua-client charrua-core.server tcpip.unix mirage-random-test))))
 
 (alias
  ((name    runtest)

test/client/lwt/test_client_lwt.ml

@@ -2,6 +2,12 @@ open Lwt.Infix
 
 (* additional tests for time- and network-dependent code *)
 
+module No_random = struct
+  type buffer = Cstruct.t
+  type g
+  let generate ?g n = Cstruct.create n
+end
+
 module No_time = struct
   type 'a io = 'a Lwt.t
   let sleep_ns n = Format.printf "Ignoring request to wait %f seconds\n" @@ Duration.to_f n;
@@ -39,7 +45,7 @@ end
 
 let keep_trying () =
   Lwt_main.run @@ (
-    let module Client = Dhcp_client_lwt.Make(No_time)(No_net) in
+    let module Client = Dhcp_client_lwt.Make(No_random)(No_time)(No_net) in
     let net = No_net.connect ~mac:(Macaddr.of_string_exn "c0:ff:ee:c0:ff:ee") () in
     let test =
       Client.connect net >>= Lwt_stream.get >|= function

test/client/test_client.ml

@@ -24,8 +24,8 @@ module Defaults = struct
 end
 
 let random_buffer () =
-  let sz = Cstruct.BE.get_uint16 (Stdlibrandom.generate 2) 0 in
-  Stdlibrandom.generate sz
+  let sz = Cstruct.BE.get_uint16 (Mirage_random_test.generate 2) 0 in
+  Mirage_random_test.generate sz
 
 let rec no_result t n () =
   if n <= 0 then ()
@@ -39,17 +39,19 @@ let rec no_result t n () =
   end
 ;;
 
-let parseable buf = 
+let parseable buf =
   Alcotest.(check bool) "buffer we constructed is valid dhcp" true (Dhcp_wire.is_dhcp buf (Cstruct.len buf))
 
+let random_xid () = Cstruct.BE.get_uint32 (Mirage_random_test.generate 4) 0
+
 let start_makes_dhcp () =
-  let (_s, buf) = Dhcp_client.create Defaults.client_mac in
+  let (_s, buf) = Dhcp_client.create (random_xid ()) Defaults.client_mac in
   (* for now, any positive result is fine *)
   parseable buf
 
 let client_to_selecting () =
   let open Defaults in
-  let (s, buf) = Dhcp_client.create client_mac in
+  let (s, buf) = Dhcp_client.create (random_xid ()) client_mac in
   let answer = Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in
   Alcotest.(check (result pass reject)) "input succeeds" answer answer;
   (s, Rresult.R.get_ok answer)
@@ -136,7 +138,7 @@ Alcotest.fail "client wanted to send more packets after receiving DHCPACK"
        Alcotest.(check (option pass)) "lease is held" (Some dhcpack) (Dhcp_client.lease s)
 
 let random_init n =
-  let (s, _) = Dhcp_client.create Defaults.client_mac in
+  let (s, _) = Dhcp_client.create (random_xid ()) Defaults.client_mac in
   "random buffer entry to INIT client", `Quick, (no_result s n)
 
 let random_selecting n =
@@ -166,8 +168,9 @@ let random_bound n =
 a new lease"
     | `New_lease (s, response) ->
       "random buffer entry to BOUND client", `Quick, (no_result s n)
-  
+
 let () =
+  Mirage_random_test.initialize () ;
   let nfuzz = 100 in
   Alcotest.run "client tests" [
     (* these tests will programmatically put [Dhcp_client.t] into a particular