Merge pull request #94 from hannesm/layering

adjustments for mirage-net 2.0.0 changes

.travis.yml

@@ -8,7 +8,7 @@ env:
   global:
   - TESTS=true
   - PINS="charrua-core.dev:. charrua-unix.dev:. charrua-client.dev:. charrua-client-lwt.dev:. charrua-client-mirage.dev:."
-  - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git"
+  - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git#layering"
   matrix:
   - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="charrua-client"
   - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="charrua-client-lwt"

charrua-client-lwt.opam

@@ -18,15 +18,15 @@ depends: [
   "ocaml" {>= "4.04.2"}
   "alcotest"     {with-test}
   "cstruct-unix" {with-test}
-  "charrua-core" {>= "0.11.1"}
-  "charrua-client" {>= "0.11.1"}
+  "charrua-core" {>= "0.12.0"}
+  "charrua-client" {>= "0.12.0"}
   "cstruct" {>="3.0.2"}
   "ipaddr" {>="3.0.0"}
   "rresult"
   "mirage-random" {>= "1.0.0"}
   "duration"
   "mirage-time-lwt"
-  "mirage-net-lwt"
+  "mirage-net-lwt" {>= "2.0.0"}
   "logs"
   "tcpip" {>= "3.6.0"}
   "fmt"

charrua-client-mirage.opam

@@ -15,9 +15,9 @@ build: [
 depends: [
   "dune" {build & >= "1.0"}
   "ocaml" {>= "4.04.2"}
-  "charrua-core" {>= "0.11.1"}
-  "charrua-client-lwt" {>= "0.11.1"}
-  "charrua-client" {>= "0.11.1"}
+  "charrua-core" {>= "0.12.0"}
+  "charrua-client-lwt" {>= "0.12.0"}
+  "charrua-client" {>= "0.12.0"}
   "cstruct" {>="3.0.2"}
   "ipaddr" {>= "3.0.0"}
   "rresult"

charrua-client.opam

@@ -19,7 +19,7 @@ depends: [
   "alcotest"     {with-test}
   "cstruct-unix" {with-test}
   "mirage-random-test" {with-test}
-  "charrua-core" {>= "0.11.1"}
+  "charrua-core" {>= "0.12.0"}
   "cstruct" {>="3.0.2"}
   "ipaddr"
   "macaddr"

charrua-core.opam

@@ -26,7 +26,6 @@ depends: [
   "ethernet"
   "tcpip"         {>= "3.7.0"}
   "rresult"
-  "io-page-unix"  {with-test}
   "cstruct-unix"  {with-test}
 ]
 synopsis: "DHCP wire frame encoder and decoder"

charrua-unix.opam

@@ -14,7 +14,7 @@ depends: [
   "ocaml" {>= "4.03.0"}
   "lwt" {>="3.0.0"}
   "lwt_log"
-  "charrua-core" {>= "0.11.0"}
+  "charrua-core" {>= "0.12.0"}
   "cstruct-unix"
   "cmdliner"
   "rawlink" {>= "1.0"}

client/dhcp_client.ml

@@ -23,8 +23,6 @@ type t = {
   state  : state;
 }
 
-type buffer = Cstruct.t
-
 (* constant fields are represented here for convenience.
    This module can then be locally opened where required *)
 module Constants = struct
@@ -172,8 +170,7 @@ let create ?requests xid srcmac =
       Parameter_requests requests;
     ];
   } in
-  {srcmac; request_options = requests; state = Selecting pkt},
-    Dhcp_wire.buf_of_pkt pkt
+  {srcmac; request_options = requests; state = Selecting pkt}, pkt
 
 (* for a DHCP client, figure out whether an incoming packet should modify the
    state, and if a response message is warranted, generate it.
@@ -202,7 +199,7 @@ let input t buf =
                           ~xid:dhcpdiscover.xid
                           ~chaddr:dhcpdiscover.chaddr in
         `Response ({t with state = Requesting (incoming, dhcprequest)},
-          (Dhcp_wire.buf_of_pkt dhcprequest))
+                   dhcprequest)
     | Some DHCPOFFER, _ -> (* DHCPOFFER is irrelevant when we're not selecting *)
       `Noop
     | Some DHCPACK, Renewing _
@@ -229,11 +226,11 @@ let input t buf =
 (* try to renew the lease, probably because some time has elapsed. *)
 let renew t = match t.state with
   | Selecting _ | Requesting _ -> `Noop
-  | Renewing (_lease, request) -> `Response (t, Dhcp_wire.buf_of_pkt request)
+  | Renewing (_lease, request) -> `Response (t, request)
   | Bound lease ->
     let open Dhcp_wire in
     let request = offer t ~xid:lease.xid ~chaddr:lease.chaddr
       ~server_ip:lease.siaddr ~request_ip:lease.yiaddr
       ~offer_options:lease.options in
     let state = Renewing (lease, request) in
-    `Response ({t with state = state}, (Dhcp_wire.buf_of_pkt request))
+    `Response ({t with state = state}, request)

client/dhcp_client.mli

@@ -1,10 +1,9 @@
 type t
-type buffer = Cstruct.t
 (** we expect all serialization and deserialization to happen through Cstruct.t *)
 
 val pp : Format.formatter -> t -> unit
 
-val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr.t -> (t * buffer)
+val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr.t -> (t * Dhcp_wire.pkt)
 (** [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.
@@ -15,7 +14,7 @@ val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr
  * guess rather than requesting nothing.
  *)
 
-val input : t -> buffer -> [`Response of (t * buffer) | `New_lease of (t * Dhcp_wire.pkt) | `Noop ]
+val input : t -> Cstruct.t -> [`Response of t * Dhcp_wire.pkt | `New_lease of t * Dhcp_wire.pkt | `Noop ]
 (** [input t buf] attempts to advance the state of [t]
  * with the contents of [buf].  If [buf] is invalid or not useful given
  * the current state of [t], [`Noop] is returned indicating no action should be taken.
@@ -32,7 +31,7 @@ val lease : t -> Dhcp_wire.pkt option
  * necessary.
  * If [t] hasn't yet completed a lease transaction, [None] will be returned. *)
 
-val renew : t -> [`Response of (t * buffer) | `Noop]
+val renew : t -> [`Response of t * Dhcp_wire.pkt | `Noop]
 (** [renew t] returns either a [`Response] with the next state and suggested action
  * of the client attempting to renew [t]'s lease,
  * or [`Noop] if [t] does not have a lease and therefore can't be renewed. *)

client/lwt/dhcp_client_lwt.ml

@@ -14,6 +14,8 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne
     (* 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 header_size = Ethernet_wire.sizeof_ethernet in
+    let size = Net.mtu net + header_size in
 
     let xid = match xid with
       | None -> Cstruct.BE.get_uint32 (Random.generate 4) 0
@@ -26,9 +28,9 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne
       Time.sleep_ns @@ Duration.of_sec t >>= fun () ->
       match Dhcp_client.renew c with
       | `Noop -> Log.debug (fun f -> f "Can't renew this lease; won't try");  Lwt.return_unit
-      | `Response (c, buf) ->
+      | `Response (c, pkt) ->
         Log.debug (fun f -> f "attempted to renew lease: %a" Dhcp_client.pp c);
-        Net.write net buf >>= function
+        Net.write net ~size (Dhcp_wire.pkt_into_buf pkt) >>= function
           | Error e ->
             Log.err (fun f -> f "Failed to write lease renewal request: %a" Net.pp_error e);
             Lwt.return_unit
@@ -37,7 +39,7 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne
     in
     let rec get_lease push dhcpdiscover =
       Log.debug (fun f -> f "Sending DHCPDISCOVER...");
-      Net.write net dhcpdiscover >>= function
+      Net.write net ~size (Dhcp_wire.pkt_into_buf dhcpdiscover) >>= function
       | Error e ->
         Log.err (fun f -> f "Failed to write initial lease discovery request: %a" Net.pp_error e);
         Lwt.return_unit
@@ -54,27 +56,27 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne
           get_lease push dhcpdiscover
     in
     let listen push () =
-      Net.listen net (fun buf ->
+      Net.listen net ~header_size (fun buf ->
         match Dhcp_client.input !c buf with
         | `Noop ->
           Log.debug (fun f -> f "No action! State is %a" Dhcp_client.pp !c);
           Lwt.return_unit
         | `Response (s, action) -> begin
-          Net.write net action >>= function
-          | Error e ->
-            Log.err (fun f -> f "Failed to write lease transaction response: %a" Net.pp_error e);
-            Lwt.return_unit
-          | Ok () ->
-            Log.debug (fun f -> f "State advanced! Now %a" Dhcp_client.pp s);
-            c := s;
-            Lwt.return_unit
+            Net.write net ~size (Dhcp_wire.pkt_into_buf action) >>= function
+            | Error e ->
+              Log.err (fun f -> f "Failed to write lease transaction response: %a" Net.pp_error e);
+              Lwt.return_unit
+            | Ok () ->
+              Log.debug (fun f -> f "State advanced! Now %a" Dhcp_client.pp s);
+              c := s;
+              Lwt.return_unit
         end
         | `New_lease (s, l) ->
           let open Dhcp_wire in
           (* a lease is obtained! Note it, and replace the current listener *)
           Log.info (fun f -> f "Lease obtained! IP: %a, routers: %a"
-          Ipaddr.V4.pp l.yiaddr
-          (Fmt.list Ipaddr.V4.pp) (collect_routers l.options));
+                       Ipaddr.V4.pp l.yiaddr
+                       (Fmt.list Ipaddr.V4.pp) (collect_routers l.options));
           push @@ Some l;
           c := s;
           match renew with

lib/dhcp_wire.ml

@@ -1051,8 +1051,8 @@ let pkt_of_buf buf len =
     (* Handle ethernet *)
     Ethernet_packet.Unmarshal.of_cstruct buf >>= fun (eth_header, eth_payload) ->
     match eth_header.Ethernet_packet.ethertype with
-    | Ethernet_wire.ARP | Ethernet_wire.IPv6 -> Error "packet is not ipv4"
-    | Ethernet_wire.IPv4 ->
+    | `ARP | `IPv6 -> Error "packet is not ipv4"
+    | `IPv4 ->
       Ipv4_packet.Unmarshal.of_cstruct eth_payload
       >>= fun (ipv4_header, ipv4_payload) ->
       match Ipv4_packet.Unmarshal.int_to_protocol ipv4_header.Ipv4_packet.proto with
@@ -1103,9 +1103,10 @@ let pkt_of_buf buf len =
   in
   try wrap () with | Invalid_argument e -> Error e
 
-let buf_of_pkt pkt =
-  (* TODO mtu *)
-  let dhcp = Cstruct.create 2048 in
+let pkt_into_buf pkt buf =
+  let eth, rest = Cstruct.split buf Ethernet_wire.sizeof_ethernet in
+  let ip, rest' = Cstruct.split rest Ipv4_wire.sizeof_ipv4 in
+  let udp, dhcp = Cstruct.split rest' Udp_wire.sizeof_udp in
   set_dhcp_op dhcp (op_to_int pkt.op);
   set_dhcp_htype dhcp
     (if pkt.htype = Ethernet_10mb then
@@ -1127,10 +1128,10 @@ let buf_of_pkt pkt =
   set_dhcp_file (Util.string_extend_if_le pkt.file 128) 0 dhcp;
   let options_start = Cstruct.shift dhcp sizeof_dhcp in
   let options_end = buf_of_options options_start pkt.options in
-  let partial_len = (Cstruct.len dhcp) - (Cstruct.len options_end) in
+  let partial_len = Cstruct.len dhcp - Cstruct.len options_end in
   let buf_end =
-    if 300 - partial_len > 0 then
-      let pad_len = 300 - partial_len in
+    let pad_len = 300 - partial_len in
+    if pad_len > 0 then
       let () =
         for i = 0 to pad_len do
           Cstruct.set_uint8 options_end i 0
@@ -1140,39 +1141,52 @@ let buf_of_pkt pkt =
     else
       options_end
   in
-  let dhcp = Cstruct.set_len dhcp ((Cstruct.len dhcp) - (Cstruct.len buf_end)) in
+  let dhcp = Cstruct.sub dhcp 0 (Cstruct.len dhcp - Cstruct.len buf_end) in
   (* Ethernet *)
-  let ethernet = Ethernet_packet.(Marshal.make_cstruct
-                                 { source = pkt.srcmac;
-                                   destination = pkt.dstmac;
-                                   ethertype = Ethernet_wire.IPv4; })
-  in
+  (match Ethernet_packet.(Marshal.into_cstruct
+                            { source = pkt.srcmac;
+                              destination = pkt.dstmac;
+                              ethertype = `IPv4; } eth)
+   with
+   | Ok () -> ()
+   | Error e -> invalid_arg e) ;
   (* IPv4 *)
+  let payload_len = Udp_wire.sizeof_udp + Cstruct.len dhcp in
   let pseudoheader = Ipv4_packet.Marshal.pseudoheader
-      ~src:pkt.srcip ~dst:pkt.dstip ~proto:`UDP
-      (Udp_wire.sizeof_udp + Cstruct.len dhcp)
+      ~src:pkt.srcip ~dst:pkt.dstip ~proto:`UDP payload_len
   in
   (* UDP *)
-  let udp = Udp_packet.(Marshal.make_cstruct ~pseudoheader ~payload:dhcp
+  (match Udp_packet.(Marshal.into_cstruct ~pseudoheader ~payload:dhcp
                           { src_port = pkt.srcport;
-                            dst_port = pkt.dstport })
-  in
-  let ip = Ipv4_packet.(Marshal.make_cstruct ~payload_len:(Cstruct.lenv [udp;dhcp])
+                            dst_port = pkt.dstport } udp)
+   with
+   | Ok () -> ()
+   | Error e -> invalid_arg e) ;
+  (match Ipv4_packet.(Marshal.into_cstruct ~payload_len
                           { src = pkt.srcip; dst = pkt.dstip;
                             id = 0 (* TODO: random? *); off = 0 ;
                             proto = (Marshal.protocol_to_int `UDP);
                             ttl = 255;
-                            options = Cstruct.create 0; })
-  in
-  Cstruct.concat [ ethernet; ip; udp; dhcp ]
+                            options = Cstruct.create 0; }
+                          ip)
+   with
+   | Ok () -> ()
+   | Error e -> invalid_arg e) ;
+  Ethernet_wire.sizeof_ethernet + Ipv4_wire.sizeof_ipv4 + Udp_wire.sizeof_udp + Cstruct.len dhcp
+
+let buf_of_pkt pkg =
+  (* TODO mtu *)
+  let dhcp = Cstruct.create 2048 in
+  let l = pkt_into_buf pkg dhcp in
+  Cstruct.sub dhcp 0 l
 
 let is_dhcp buf len =
   let open Rresult in
   let aux buf =
     Ethernet_packet.Unmarshal.of_cstruct buf >>= fun (eth_header, eth_payload) ->
     match eth_header.Ethernet_packet.ethertype with
-    | Ethernet_wire.ARP | Ethernet_wire.IPv6 -> Ok false
-    | Ethernet_wire.IPv4 ->
+    | `ARP | `IPv6 -> Ok false
+    | `IPv4 ->
       Ipv4_packet.Unmarshal.of_cstruct eth_payload >>= fun (ipv4_header, ipv4_payload) ->
       (* TODO: tcpip doesn't currently do checksum checking, so we lose some
          functionality by making this change *)

lib/dhcp_wire.mli

@@ -754,6 +754,7 @@ type pkt = {
 
 val pkt_of_buf : Cstruct.t -> int -> (pkt, string) result
 val buf_of_pkt : pkt -> Cstruct.t
+val pkt_into_buf : pkt -> Cstruct.t -> int
 
 val pkt_of_sexp : Sexplib.Sexp.t -> pkt
 val sexp_of_pkt : pkt -> Sexplib.Sexp.t

test/client/lwt/test_client_lwt.ml

@@ -15,23 +15,24 @@ module No_time = struct
 end
 
 module No_net = struct
-  type error = Mirage_device.error
-  let pp_error = Mirage_device.pp_error
+  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 page_aligned_buffer = Io_page.t
   type buffer = Cstruct.t
   type t = { mac : Macaddr.t; mutable packets : Cstruct.t list }
   let disconnect _ = Lwt.return_unit
-  let writev t l =
-    t.packets <- t.packets @ l;
+  let write t ~size fillf =
+    let buf = Cstruct.create size in
+    let l = fillf buf in
+    assert (l <= size);
+    let b = Cstruct.sub buf 0 l in
+    t.packets <- t.packets @ [b];
     Lwt.return_ok ()
-  let write t p =
-    t.packets <- p :: t.packets;
-    Lwt.return_ok ()
-  let listen _ _ = Lwt.return_ok ()
+  let listen _ ~header_size:_ _ = Lwt.return_ok ()
   let mac t = t.mac
+  let mtu t = 1500
   let reset_stats_counters _ = ()
   let get_stats_counters _ = {
     Mirage_net.rx_bytes = 0L;