Merge pull request #105 from hannesm/easy

adapt to mirage API changes

.travis.yml

@@ -8,13 +8,11 @@ env:
   global:
   - TESTS=true
   - PINS="charrua.dev:. charrua-server.dev:. charrua-unix.dev:. charrua-client.dev:. charrua-client-lwt.dev:. charrua-client-mirage.dev:."
-  - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git"
-  - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y"
   matrix:
-  - DISTRO="alpine" OCAML_VERSION="4.08" PACKAGE="charrua-client" DEPOPTS="charrua-server"
-  - DISTRO="debian-unstable" OCAML_VERSION="4.07" PACKAGE="charrua-client"
-  - DISTRO="ubuntu-lts" OCAML_VERSION="4.07" PACKAGE="charrua-client-lwt"
-  - DISTRO="ubuntu" OCAML_VERSION="4.06" PACKAGE="charrua-client-mirage"
-  - DISTRO="debian-stable" OCAML_VERSION="4.06" PACKAGE="charrua-server"
-  - DISTRO="alpine" OCAML_VERSION="4.05" PACKAGE="charrua"
-  - DISTRO="centos" OCAML_VERSION="4.04" PACKAGE="charrua-unix"
+  - DISTRO="alpine" OCAML_VERSION="4.09" PACKAGE="charrua-client" DEPOPTS="charrua-server"
+  - DISTRO="debian-unstable" OCAML_VERSION="4.08" PACKAGE="charrua-client"
+  - DISTRO="ubuntu-lts" OCAML_VERSION="4.08" PACKAGE="charrua-client-lwt"
+  - DISTRO="ubuntu" OCAML_VERSION="4.07" PACKAGE="charrua-client-mirage"
+  - DISTRO="debian-stable" OCAML_VERSION="4.07" PACKAGE="charrua-server"
+  - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="charrua"
+  - DISTRO="centos" OCAML_VERSION="4.06" PACKAGE="charrua-unix"

charrua-client-lwt.opam

@@ -14,21 +14,21 @@ build: [
 ]
 
 depends: [
-  "dune" {>= "1.0"}
-  "ocaml" {>= "4.04.2"}
+  "dune" {>= "1.2.0"}
+  "ocaml" {>= "4.06.0"}
   "alcotest"     {with-test}
   "cstruct-unix" {with-test}
   "charrua" {= version}
   "charrua-client" {= version}
   "cstruct" {>="3.0.2"}
-  "ipaddr" {>="3.0.0"}
-  "mirage-random" {>= "1.0.0"}
+  "ipaddr" {>="4.0.0"}
+  "mirage-random" {>= "2.0.0"}
   "duration"
-  "mirage-time-lwt"
-  "mirage-net-lwt" {>= "2.0.0"}
+  "mirage-time" {>= "2.0.0"}
+  "mirage-net" {>= "3.0.0"}
   "logs"
   "fmt"
-  "lwt"
+  "lwt" {>= "4.0.0"}
 ]
 synopsis: "A DHCP client using lwt as effectful layer"
 description: """

charrua-client-mirage.opam

@@ -13,17 +13,17 @@ build: [
 ]
 
 depends: [
-  "dune" {>= "1.0"}
-  "ocaml" {>= "4.04.2"}
+  "dune" {>= "1.2.0"}
+  "ocaml" {>= "4.06.0"}
   "charrua-client-lwt" {= version}
-  "ipaddr" {>= "3.0.0"}
-  "mirage-random" {>= "1.0.0"}
-  "mirage-clock"
-  "mirage-time-lwt"
-  "mirage-net-lwt" {>= "2.0.0"}
-  "mirage-protocols-lwt" {>= "2.0.0"}
+  "ipaddr" {>= "4.0.0"}
+  "mirage-random" {>= "2.0.0"}
+  "mirage-clock" {>= "3.0.0"}
+  "mirage-time" {>= "2.0.0"}
+  "mirage-net" {>= "3.0.0"}
+  "mirage-protocols" {>= "4.0.0"}
   "logs"
-  "lwt"
+  "lwt" {>= "4.0.0"}
 ]
 synopsis: "A DHCP client for MirageOS"
 description: """

charrua-client.opam

@@ -14,16 +14,16 @@ build: [
 ]
 
 depends: [
-  "dune" {>= "1.0"}
-  "ocaml" {>= "4.04.2"}
+  "dune" {>= "1.2.0"}
+  "ocaml" {>= "4.06.0"}
   "alcotest"     {with-test}
   "cstruct-unix" {with-test}
-  "mirage-random-test" {with-test}
+  "mirage-random-test" {with-test & >= "0.1.0"}
   "charrua-server" {= version & with-test}
   "charrua" {= version}
   "cstruct" {>="3.0.2"}
-  "ipaddr"
-  "macaddr"
+  "ipaddr" {>= "4.0.0"}
+  "macaddr" {>= "4.0.0"}
 ]
 synopsis: "DHCP client implementation"
 description: """

charrua-server.opam

@@ -14,11 +14,11 @@ build: [
 ]
 
 depends: [
-  "dune"
+  "ocaml"         {>= "4.06.0"}
+  "dune"          {>= "1.2.0"}
   "ppx_sexp_conv" {>= "v0.9.0"}
   "menhir"        {build}
   "charrua"       {= version}
-  "ocaml"         {>= "4.04.2"}
   "cstruct"       {>= "3.0.1"}
   "sexplib"
   "ipaddr"        {>= "4.0.0"}

charrua-unix.opam

@@ -10,8 +10,8 @@ build: [
   ["dune" "build" "-p" name "-j" jobs]
 ]
 depends: [
-  "dune" {>= "1.0"}
-  "ocaml" {>= "4.04.2"}
+  "dune" {>= "1.2.0"}
+  "ocaml" {>= "4.06.0"}
   "lwt" {>="3.0.0"}
   "lwt_log"
   "charrua" {= version}

charrua.opam

@@ -13,8 +13,8 @@ build: [
 ]
 
 depends: [
-  "ocaml"         {>= "4.04.2"}
-  "dune"
+  "ocaml"         {>= "4.06.0"}
+  "dune"          {>= "1.2.0"}
   "ppx_sexp_conv" {>="v0.10.0"}
   "ppx_cstruct"
   "cstruct"       {>= "3.0.1"}
@@ -23,8 +23,8 @@ depends: [
   "macaddr"       {>= "4.0.0"}
   "ipaddr-sexp"
   "macaddr-sexp"
-  "ethernet"      {>= "2.0.0"}
-  "tcpip"         {>= "3.7.0"}
+  "ethernet"      {>= "2.2.0"}
+  "tcpip"         {>= "4.0.0"}
   "rresult"
 ]
 synopsis: "DHCP wire frame encoder and decoder"

client/lwt/dhcp_client_lwt.ml

@@ -1,7 +1,7 @@
 let src = Logs.Src.create "dhcp_client_lwt"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct
+module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Net : Mirage_net.S) = struct
   open Lwt.Infix
 
   type lease = Dhcp_wire.pkt

client/lwt/dhcp_client_lwt.mli

@@ -1,4 +1,4 @@
-module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) : sig
+module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Net : Mirage_net.S) : sig
   type lease = Dhcp_wire.pkt
 
   type t = lease Lwt_stream.t

client/lwt/dune

@@ -2,5 +2,5 @@
  (name dhcp_client_lwt)
  (public_name charrua-client-lwt)
  (modules dhcp_client_lwt)
- (libraries charrua lwt charrua-client cstruct ipaddr mirage-time-lwt
-   mirage-random mirage-net-lwt duration fmt logs))
+ (libraries charrua lwt charrua-client cstruct ipaddr mirage-time
+   mirage-random mirage-net duration fmt logs))

client/mirage/dhcp_client_mirage.ml

@@ -1,7 +1,7 @@
 let src = Logs.Src.create "dhcp_client_mirage"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let config_of_lease lease : Mirage_protocols_lwt.ipv4_config option =
+let config_of_lease lease : Mirage_protocols.ipv4_config option =
   let open Dhcp_wire in
   (* ipv4_config expects a single IP address and the information
    * needed to construct a prefix.  It can optionally use one router. *)
@@ -15,15 +15,14 @@ let config_of_lease lease : Mirage_protocols_lwt.ipv4_config option =
     let network = Ipaddr.V4.Prefix.of_netmask subnet address in
     let valid_routers = Dhcp_wire.collect_routers lease.options in
     match valid_routers with
-    | [] -> Some Mirage_protocols_lwt.{ address; network; gateway = None }
+    | [] -> Some Mirage_protocols.{ address; network; gateway = None }
     | hd::_ ->
-      Some Mirage_protocols_lwt.{ address; network; gateway = (Some hd) }
+      Some Mirage_protocols.{ address; network; gateway = (Some hd) }
 
-module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct
+module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Net : Mirage_net.S) = struct
   open Lwt.Infix
-  open Mirage_protocols_lwt
 
-  type t = ipv4_config Lwt_stream.t
+  type t = Mirage_protocols.ipv4_config Lwt_stream.t
 
   let connect ?(requests : Dhcp_wire.option_code list option) net =
     let module Lwt_client = Dhcp_client_lwt.Make(Random)(Time)(Net) in

client/mirage/dhcp_client_mirage.mli

@@ -1,5 +1,5 @@
-module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Network : Mirage_net_lwt.S) : sig
-  type t = Mirage_protocols_lwt.ipv4_config Lwt_stream.t
+module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Network : Mirage_net.S) : sig
+  type t = Mirage_protocols.ipv4_config Lwt_stream.t
   val connect : ?requests:Dhcp_wire.option_code list
     -> Network.t -> t Lwt.t
   (** [connect ?requests net] attempts to use [net] to obtain a valid

client/mirage/dhcp_ipv4.ml

@@ -1,10 +1,9 @@
 open Lwt.Infix
-open Mirage_protocols_lwt
 
-module Make(Dhcp_client : DHCP_CLIENT) (R : Mirage_random.C) (C : Mirage_clock.MCLOCK) (E : ETHERNET) (Arp : ARP) = struct
+module Make(Dhcp_client : Mirage_protocols.DHCP_CLIENT) (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (E : Mirage_protocols.ETHERNET) (Arp : Mirage_protocols.ARP) = struct
   (* for now, just wrap a static ipv4 *)
   include Static_ipv4.Make(R)(C)(E)(Arp)
-  let connect dhcp clock ethernet arp =
-    Lwt_stream.last_new dhcp >>= fun (config : ipv4_config) ->
-    connect ~ip:config.address ~network:config.network ~gateway:config.gateway clock ethernet arp
+  let connect dhcp ethernet arp =
+    Lwt_stream.last_new dhcp >>= fun (config : Mirage_protocols.ipv4_config) ->
+    connect ~ip:(config.network, config.address) ?gateway:config.gateway ethernet arp
 end

client/mirage/dhcp_ipv4.mli

@@ -14,8 +14,8 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-module Make (D: Mirage_protocols_lwt.DHCP_CLIENT) (R : Mirage_random.C) (C : Mirage_clock.MCLOCK) (E:Mirage_protocols_lwt.ETHERNET) (A: Mirage_protocols_lwt.ARP) : sig
-  include Mirage_protocols_lwt.IPV4
-  val connect : D.t -> C.t -> E.t -> A.t -> t Lwt.t
+module Make (D: Mirage_protocols.DHCP_CLIENT) (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (E:Mirage_protocols.ETHERNET) (A: Mirage_protocols.ARP) : sig
+  include Mirage_protocols.IPV4
+  val connect : D.t -> E.t -> A.t -> t Lwt.t
     (** Connect to an ipv4 device using information from a DHCP lease. *)
 end

client/mirage/dune

@@ -1,6 +1,6 @@
 (library
  (name dhcp_client_mirage)
  (public_name charrua-client-mirage)
- (libraries charrua-client-lwt ipaddr mirage-clock mirage-random mirage-time-lwt
-   mirage-net-lwt mirage-protocols-lwt logs)
+ (libraries charrua-client-lwt ipaddr mirage-clock mirage-random mirage-time
+   mirage-net mirage-protocols logs)
  (wrapped false))

test/client/lwt/test_client_lwt.ml

@@ -3,24 +3,20 @@ 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
+  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;
+  let sleep_ns n =
+    Format.printf "Ignoring request to wait %f seconds\n" (Duration.to_f n);
     Lwt_main.yield ()
 end
 
 module No_net = struct
   type error = Mirage_net.Net.error
   let pp_error = Mirage_net.Net.pp_error
   type stats = Mirage_net.stats
-  type 'a io = 'a Lwt.t
-  type macaddr = Macaddr.t
-  type buffer = Cstruct.t
   type t = { mac : Macaddr.t; mutable packets : Cstruct.t list }
   let disconnect _ = Lwt.return_unit
   let write t ~size fillf =
@@ -32,7 +28,7 @@ module No_net = struct
     Lwt.return_ok ()
   let listen _ ~header_size:_ _ = Lwt.return_ok ()
   let mac t = t.mac
-  let mtu t = 1500
+  let mtu _t = 1500
   let reset_stats_counters _ = ()
   let get_stats_counters _ = {
     Mirage_net.rx_bytes = 0L;

test/client/test_client.ml

@@ -30,14 +30,13 @@ let random_buffer () =
 let rec no_result t n () =
   if n <= 0 then ()
   else begin
-  let buf = random_buffer () in
-  (* TODO: it would be better to randomize a valid DHCP message; currently
-   * we're fuzz testing the Dhcp_wire parser's ability to handle random garbage *)
-  let res = Dhcp_client.input t buf in
-  Alcotest.(check bool) "no action" true (res = `Noop);
-  no_result t (n - 1) ()
+    let buf = random_buffer () in
+    (* TODO: it would be better to randomize a valid DHCP message; currently
+     * we're fuzz testing the Dhcp_wire parser's ability to handle random garbage *)
+    let res = Dhcp_client.input t buf in
+    Alcotest.(check bool) "no action" true (res = `Noop);
+    no_result t (n - 1) ()
   end
-;;
 
 let parseable buf =
   Alcotest.(check bool) "buffer we constructed is valid dhcp" true (Dhcp_wire.is_dhcp buf (Cstruct.len buf))
@@ -97,7 +96,7 @@ let client_asks_dhcprequest () =
     match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with
     | `Noop -> Alcotest.fail "response to DHCPOFFER was silence"
     | `New_lease _ -> Alcotest.fail "thought a DHCPOFFER was a lease???"
-    | `Response (s, pkt) ->
+    | `Response (_s, pkt) ->
       let buf = Dhcp_wire.buf_of_pkt pkt in
       parseable buf;
       let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in
@@ -114,7 +113,7 @@ let server_gives_dhcpack () =
   match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpoffer) with
   | `Noop -> Alcotest.fail "couldn't get client to respond to DHCPOFFER"
   | `New_lease _-> Alcotest.fail "thought a DHCPOFFER was a lease"
-  | `Response (s, pkt) ->
+  | `Response (_s, pkt) ->
     let buf = Dhcp_wire.buf_of_pkt pkt in
     let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in
     let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in
@@ -138,7 +137,7 @@ let client_returns_lease () =
     | `Response _ ->
 Alcotest.fail "client wanted to send more packets after receiving DHCPACK"
     | `Noop -> Alcotest.fail "client disregarded its lease"
-    | `New_lease (s, l) ->
+    | `New_lease (s, _l) ->
        Alcotest.(check (option pass)) "lease is held" (Some dhcpack) (Dhcp_client.lease s)
 
 let random_init n =
@@ -155,7 +154,7 @@ let random_requesting n =
   let (pkt, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in
   match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with
   | `Noop | `New_lease _ -> Alcotest.fail "couldn't enter REQUESTING properly"
-| `Response (s, dhcprequest) ->
+| `Response (s, _dhcprequest) ->
   "random buffer entry to REQUESTING client", `Quick, (no_result s n)
 
 let random_bound n =
@@ -167,11 +166,11 @@ let random_bound n =
   | `Response (s, dhcprequest) ->
     let buf = Dhcp_wire.buf_of_pkt dhcprequest in
     let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in
-    let (dhcpack, db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in
+    let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in
     match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpack) with
     | `Noop | `Response _ -> Alcotest.fail "client did not recognize DHCPACK as
 a new lease"
-    | `New_lease (s, response) ->
+    | `New_lease (s, _response) ->
       "random buffer entry to BOUND client", `Quick, (no_result s n)
 
 let () =

test/test.ml

@@ -385,7 +385,6 @@ let t_discover_range () = t_discover false
 let t_discover_fixed () = t_discover true
 
 let t_discover_no_range () =
-  let open Dhcp_server.Config in
   let config = Config.make
       ~hostname:"Duder DHCP server!"
       ~default_lease_time:(60 * 60 * 1)
@@ -621,7 +620,7 @@ let t_request_fixed () =
       let () =
         match Lease.lease_of_client_id (Id "W.Sobchak") db with
         | None -> () (* good, lease is not there. *)
-        | Some l -> failwith "Found a fixed lease, bad juju."
+        | Some _l -> failwith "Found a fixed lease, bad juju."
       in
       assert (reply.srcmac = mac_t);
       assert (reply.dstmac = Macaddr.broadcast);
@@ -735,11 +734,11 @@ let t_request () =
         | Some l ->
           let open Dhcp_server.Lease in
           assert (l.client_id = (Id "W.Sobchak"));
-          assert (not (expired l now));
+          assert (not (expired l ~now));
           assert (l.tm_start <= now);
           assert (l.tm_end >= now);
-          assert ((Lease.timeleft l now) <= (Int32.of_int 3600));
-          assert ((Lease.timeleft l now) >= (Int32.of_int 3599));
+          assert ((Lease.timeleft l ~now) <= (Int32.of_int 3600));
+          assert ((Lease.timeleft l ~now) >= (Int32.of_int 3599));
       in
       assert (reply.srcmac = mac_t);
       assert (reply.dstmac = Macaddr.broadcast);
@@ -796,7 +795,6 @@ let t_request () =
   | _ -> failwith "No reply"
 
 let t_request_no_range () =
-  let open Dhcp_server.Config in
   let config = Config.make
       ~hostname:"Duder DHCP server!"
       ~default_lease_time:(60 * 60 * 1)
@@ -931,7 +929,7 @@ let t_request_no_range_fixed () =
     let () =
       match Lease.lease_of_client_id (Id "W.Sobchak") db with
       | None -> () (* good, lease is not there. *)
-      | Some l -> failwith "Found a fixed lease, bad juju."
+      | Some _l -> failwith "Found a fixed lease, bad juju."
     in
     assert (reply.srcmac = mac_t);
     assert (reply.dstmac = Macaddr.broadcast);