Merge pull request #505 from hannesm/no-ppx

remove ppx from mirage-tcpip

src/icmp/dune

@@ -4,6 +4,4 @@
  (instrumentation
   (backend bisect_ppx))
  (libraries logs tcpip ipaddr tcpip.checksum)
- (preprocess
-  (pps ppx_cstruct))
  (wrapped false))

src/icmp/icmpv4.ml

@@ -48,7 +48,6 @@ module Make (IP : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) = struct
           f "ICMP: error parsing message from %a: %s" Ipaddr.V4.pp src s);
       Lwt.return_unit
     | Ok (message, payload) ->
-      let open Icmpv4_wire in
       match message.ty, message.subheader with
       | Echo_reply, _ ->
         Log.info (fun f ->
@@ -65,7 +64,7 @@ module Make (IP : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) = struct
         if t.echo_reply then begin
           let icmp = {
             code = 0x00;
-            ty   = Icmpv4_wire.Echo_reply;
+            ty   = Echo_reply;
             subheader = Id_and_seq (id, seq);
           } in
           writev t ~dst:src [ Marshal.make_cstruct icmp ~payload; payload ]
@@ -77,7 +76,7 @@ module Make (IP : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) = struct
       | ty, _ ->
         Log.info (fun f ->
             f "ICMP unknown ty %s from %a"
-              (ty_to_string ty) Ipaddr.V4.pp src);
+              (Icmpv4_wire.ty_to_string ty) Ipaddr.V4.pp src);
         Lwt.return_unit
 
 end

src/icmp/icmpv4_packet.ml

@@ -23,7 +23,7 @@ let pp fmt t =
     | Address addr -> say fmt "subheader: ip %a" Ipaddr.V4.pp addr
     | Unused -> ()
   in
-  say fmt "ICMP type %s, code %d, subheader [%a]" (Icmpv4_wire.ty_to_string t.ty)
+  say fmt "ICMP type %s, code %d, subheader [%a]" (ty_to_string t.ty)
     t.code pp_subheader t.subheader
 
 let subheader_eq = function
@@ -64,14 +64,14 @@ module Unmarshal = struct
         Error "packet too short for ICMPv4 header"
       else Ok () in
     let check_ty () =
-      match int_to_ty (get_icmpv4_ty buf) with
+      match int_to_ty (get_ty buf) with
       | None -> Error "unrecognized ICMPv4 type"
       | Some ty -> Ok ty
     in
     (* TODO: check checksum as well, and return an error if it's invalid *)
     let* () = check_len () in
     let* ty = check_ty () in
-    let code = get_icmpv4_code buf in
+    let code = get_code buf in
     let subheader = subheader_of_cstruct ty (Cstruct.shift buf 4) in
     let payload = Cstruct.shift buf sizeof_icmpv4 in
     Ok ({ code; ty; subheader}, payload)
@@ -91,15 +91,15 @@ module Marshal = struct
     | Unused -> set_uint32 buf 0 Int32.zero
 
   let unsafe_fill {ty; code; subheader} buf ~payload =
-    set_icmpv4_ty buf (ty_to_int ty);
-    set_icmpv4_code buf code;
-    set_icmpv4_csum buf 0x0000;
+    set_ty buf (ty_to_int ty);
+    set_code buf code;
+    set_checksum buf 0x0000;
     subheader_into_cstruct ~buf:(Cstruct.shift buf 4) subheader;
-    let packets = [(Cstruct.sub buf 0 Icmpv4_wire.sizeof_icmpv4); payload] in
-    set_icmpv4_csum buf (Tcpip_checksum.ones_complement_list packets)
+    let packets = [(Cstruct.sub buf 0 sizeof_icmpv4); payload] in
+    set_checksum buf (Tcpip_checksum.ones_complement_list packets)
 
   let check_len buf =
-    if Cstruct.length buf < Icmpv4_wire.sizeof_icmpv4 then
+    if Cstruct.length buf < sizeof_icmpv4 then
       Error "Not enough space for ICMP header"
     else Ok ()
 
@@ -109,7 +109,7 @@ module Marshal = struct
     Ok ()
 
   let make_cstruct t ~payload =
-    let buf = Cstruct.create Icmpv4_wire.sizeof_icmpv4 in
+    let buf = Cstruct.create sizeof_icmpv4 in
     unsafe_fill t buf ~payload;
     buf
 end

src/icmp/icmpv4_wire.ml

@@ -1,32 +1,58 @@
-[%%cstruct
-  type icmpv4 = {
-    ty:   uint8_t;
-    code: uint8_t;
-    csum: uint16_t;
-    id:   uint16_t;
-    seq:  uint16_t;
-  } [@@big_endian]
-]
-
-[%%cenum
 type ty =
-  | Echo_reply [@id 0]
-  | Destination_unreachable [@id 3]
+  | Echo_reply
+  | Destination_unreachable
   | Source_quench
   | Redirect
-  | Echo_request [@id 8]
-  | Time_exceeded [@id 11]
+  | Echo_request
+  | Time_exceeded
   | Parameter_problem
   | Timestamp_request
   | Timestamp_reply
   | Information_request
   | Information_reply
-  [@@uint8_t]
-]
 
-[%%cenum
+let ty_to_string = function
+  | Echo_reply -> "echo reply"
+  | Destination_unreachable -> "destination unreachable"
+  | Source_quench -> "source quench"
+  | Redirect -> "redirect"
+  | Echo_request -> "echo request"
+  | Time_exceeded -> "time exceeded"
+  | Parameter_problem -> "parameter problem"
+  | Timestamp_request -> "timestamp request"
+  | Timestamp_reply -> "timestamp reply"
+  | Information_request -> "information request"
+  | Information_reply -> "information reply"
+
+let int_to_ty = function
+  | 0 -> Some Echo_reply
+  | 3 -> Some Destination_unreachable
+  | 4 -> Some Source_quench
+  | 5 -> Some Redirect
+  | 8 -> Some Echo_request
+  | 11 -> Some Time_exceeded
+  | 12 -> Some Parameter_problem
+  | 13 -> Some Timestamp_request
+  | 14 -> Some Timestamp_reply
+  | 15 -> Some Information_request
+  | 16 -> Some Information_reply
+  | _ -> None
+
+let ty_to_int = function
+  | Echo_reply -> 0
+  | Destination_unreachable -> 3
+  | Source_quench -> 4
+  | Redirect -> 5
+  | Echo_request -> 8
+  | Time_exceeded -> 11
+  | Parameter_problem -> 12
+  | Timestamp_request -> 13
+  | Timestamp_reply -> 14
+  | Information_request -> 15
+  | Information_reply -> 16
+
 type unreachable_reason =
-  | Network_unreachable [@id 0]
+  | Network_unreachable
   | Host_unreachable
   | Protocol_unreachable
   | Port_unreachable
@@ -41,6 +67,37 @@ type unreachable_reason =
   | TOS_host_unreachable
   | Communication_prohibited
   | Host_precedence_violation
-  | Precedence_insufficient [@id 15]
-  [@@uint8_t]
-]
+  | Precedence_insufficient
+
+let unreachable_reason_to_int = function
+  | Network_unreachable -> 0
+  | Host_unreachable -> 1
+  | Protocol_unreachable -> 2
+  | Port_unreachable -> 3
+  | Would_fragment -> 4
+  | Source_route_failed -> 5
+  | Destination_network_unknown -> 6
+  | Destination_host_unknown -> 7
+  | Source_host_isolated -> 8
+  | Destination_net_prohibited -> 9
+  | Destination_host_prohibited -> 10
+  | TOS_network_unreachable -> 11
+  | TOS_host_unreachable -> 12
+  | Communication_prohibited -> 13
+  | Host_precedence_violation -> 14
+  | Precedence_insufficient -> 15
+
+let sizeof_icmpv4 = 8
+
+let ty_off = 0
+let code_off = 1
+let csum_off = 2
+
+let get_ty buf = Cstruct.get_uint8 buf ty_off
+let set_ty buf value = Cstruct.set_uint8 buf ty_off value
+
+let get_code buf = Cstruct.get_uint8 buf code_off
+let set_code buf value = Cstruct.set_uint8 buf code_off value
+
+let get_checksum buf = Cstruct.BE.get_uint16 buf csum_off
+let set_checksum buf value = Cstruct.BE.set_uint16 buf csum_off value

src/icmp/icmpv4_wire.mli

@@ -0,0 +1,47 @@
+type ty =
+  | Echo_reply
+  | Destination_unreachable
+  | Source_quench
+  | Redirect
+  | Echo_request
+  | Time_exceeded
+  | Parameter_problem
+  | Timestamp_request
+  | Timestamp_reply
+  | Information_request
+  | Information_reply
+
+val ty_to_string : ty -> string
+val int_to_ty : int -> ty option
+val ty_to_int : ty -> int
+
+type unreachable_reason =
+  | Network_unreachable
+  | Host_unreachable
+  | Protocol_unreachable
+  | Port_unreachable
+  | Would_fragment
+  | Source_route_failed
+  | Destination_network_unknown
+  | Destination_host_unknown
+  | Source_host_isolated
+  | Destination_net_prohibited
+  | Destination_host_prohibited
+  | TOS_network_unreachable
+  | TOS_host_unreachable
+  | Communication_prohibited
+  | Host_precedence_violation
+  | Precedence_insufficient
+
+val unreachable_reason_to_int : unreachable_reason -> int
+
+val sizeof_icmpv4 : int
+
+val get_ty : Cstruct.t -> int
+val set_ty : Cstruct.t -> int -> unit
+
+val get_code : Cstruct.t -> int
+val set_code : Cstruct.t -> int -> unit
+
+val get_checksum : Cstruct.t -> int
+val set_checksum : Cstruct.t -> int -> unit

src/ipv4/dune

@@ -5,6 +5,4 @@
   (backend bisect_ppx))
  (libraries logs ipaddr cstruct tcpip tcpip.udp tcpip.checksum mirage-random
    mirage-clock randomconv lru arp.mirage ethernet)
- (preprocess
-  (pps ppx_cstruct))
  (wrapped false))

src/ipv4/fragments.ml

@@ -196,7 +196,7 @@ let fragment ~mtu hdr payload =
       if more then Cstruct.split payload data_size else payload, Cstruct.empty
     in
     let payload_len = Cstruct.length this_payload in
-    Ipv4_wire.set_ipv4_csum hdr_buf 0;
+    Ipv4_wire.set_checksum hdr_buf 0;
     (match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr' hdr_buf with
      (* hdr_buf is allocated with hdr_size (computed below) bytes, thus
         into_cstruct will never return an error! *)

src/ipv4/ipv4_packet.ml

@@ -54,17 +54,17 @@ module Marshal = struct
       | k -> (4 - k) + n
     in
     let options_len = nearest_4 @@ Cstruct.length t.options in
-    set_ipv4_hlen_version buf ((4 lsl 4) + 5 + (options_len / 4));
-    set_ipv4_id buf t.id;
-    set_ipv4_off buf t.off;
-    set_ipv4_ttl buf t.ttl;
-    set_ipv4_proto buf t.proto;
-    set_ipv4_src buf (Ipaddr.V4.to_int32 t.src);
-    set_ipv4_dst buf (Ipaddr.V4.to_int32 t.dst);
+    set_hlen_version buf ((4 lsl 4) + 5 + (options_len / 4));
+    set_id buf t.id;
+    set_off buf t.off;
+    set_ttl buf t.ttl;
+    set_proto buf t.proto;
+    set_src buf t.src;
+    set_dst buf t.dst;
     Cstruct.blit t.options 0 buf sizeof_ipv4 (Cstruct.length t.options);
-    set_ipv4_len buf (sizeof_ipv4 + options_len + payload_len);
+    set_len buf (sizeof_ipv4 + options_len + payload_len);
     let checksum = Tcpip_checksum.ones_complement @@ Cstruct.sub buf 0 (20 + options_len) in
-    set_ipv4_csum buf checksum
+    set_checksum buf checksum
 
 
   let into_cstruct ~payload_len t buf =
@@ -99,7 +99,7 @@ module Unmarshal = struct
     let open Ipv4_wire in
     let check_version buf =
       let version n = (n land 0xf0) in
-      match get_ipv4_hlen_version buf |> version with
+      match get_hlen_version buf |> version with
       | 0x40 -> Ok ()
       | n -> Error (Printf.sprintf "IPv4 presented with a packet that claims a different IP version: %x" n)
     in
@@ -109,28 +109,29 @@ module Unmarshal = struct
     in
     let get_header_length buf =
       let length_of_hlen_version n = (n land 0x0f) * 4 in
-      let hlen = get_ipv4_hlen_version buf |> length_of_hlen_version in
-        if (get_ipv4_len buf) < sizeof_ipv4 then
-          Error (Printf.sprintf
-                   "total length %d is smaller than minimum header length"
-                   (get_ipv4_len buf))
-        else if get_ipv4_len buf < hlen then
-          Error (Printf.sprintf
-                   "total length %d is smaller than stated header length %d"
-                   (get_ipv4_len buf) hlen)
-        else if hlen < sizeof_ipv4 then
-          Error (Printf.sprintf "IPv4 header claimed to have size < 20: %d" hlen)
-        else if Cstruct.length buf < hlen then
-          Error (Printf.sprintf "IPv4 packet w/length %d claimed to have header of size %d" (Cstruct.length buf) hlen)
-        else Ok hlen
+      let hlen = get_hlen_version buf |> length_of_hlen_version in
+      let len = get_len buf in
+      if len < sizeof_ipv4 then
+        Error (Printf.sprintf
+                 "total length %d is smaller than minimum header length" len)
+      else if len < hlen then
+        Error (Printf.sprintf
+                 "total length %d is smaller than stated header length %d"
+                 len hlen)
+      else if hlen < sizeof_ipv4 then
+        Error (Printf.sprintf "IPv4 header claimed to have size < 20: %d" hlen)
+      else if Cstruct.length buf < hlen then
+        Error (Printf.sprintf "IPv4 packet w/length %d claimed to have header of size %d" (Cstruct.length buf) hlen)
+      else Ok hlen
     in
     let parse buf options_end =
-      let src = Ipaddr.V4.of_int32 (get_ipv4_src buf) in
-      let dst = Ipaddr.V4.of_int32 (get_ipv4_dst buf) in
-      let id = get_ipv4_id buf in
-      let off = get_ipv4_off buf in
-      let ttl = get_ipv4_ttl buf in
-      let proto = get_ipv4_proto buf in
+      let src = get_src buf
+      and dst = get_dst buf
+      and id = get_id buf
+      and off = get_off buf
+      and ttl = get_ttl buf
+      and proto = get_proto buf
+      in
       let options =
         if options_end > sizeof_ipv4 then (Cstruct.sub buf sizeof_ipv4 (options_end - sizeof_ipv4))
         else (Cstruct.create 0)
@@ -143,9 +144,8 @@ module Unmarshal = struct
     parse buf hl
 
   let of_cstruct buf =
-    let open Ipv4_wire in
     let parse buf options_end =
-      let payload_len = (get_ipv4_len buf) - options_end in
+      let payload_len = Ipv4_wire.get_len buf - options_end in
       let payload_available = Cstruct.length buf - options_end in
       if payload_available < payload_len then (
         Error (Printf.sprintf "Payload buffer (%d bytes) too small to contain payload (of size %d from header)" payload_available payload_len)
@@ -172,7 +172,7 @@ module Unmarshal = struct
     | `TCP -> (* checksum isn't optional in tcp, but pkt must be long enough *)
       check ipv4_header ~proto (Cstruct.length transport_packet)
     | `UDP ->
-      match Udp_wire.get_udp_checksum transport_packet with
+      match Udp_wire.get_checksum transport_packet with
       | n when (=) 0 @@ compare n 0x0000 -> true (* no checksum supplied, so the check trivially passes *)
       | _ ->
         check ipv4_header ~proto (Cstruct.length transport_packet)