Merge pull request #415 from hannesm/extract-fragmentation

introduce ipv4/Fragments.fragment : ~mtu:int -> Ipv4_packet.t -> Cstr…

src/ipv4/fragments.ml

@@ -180,3 +180,45 @@ let process cache ts (packet : Ipv4_packet.t) payload =
           | Error Hole -> maybe_add_to_cache cache', None
         else
           maybe_add_to_cache cache', None
+
+(* TODO hdr.options is a Cstruct.t atm, but instead we need to parse all the
+   options, and distinguish based on the first bit -- only these with the bit
+   set should be copied into all fragments (see RFC 791, 3.1, page 15) *)
+let fragment ~mtu hdr payload =
+  let rec frag1 acc hdr hdr_buf offset data_size payload =
+    let more = Cstruct.len payload > data_size in
+    let hdr' =
+      (* off is 16 bit of IPv4 header, 0x2000 sets the more fragments bit *)
+      let off = (offset / 8) lor (if more then 0x2000 else 0) in
+      { hdr with Ipv4_packet.off }
+    in
+    let this_payload, rest =
+      if more then Cstruct.split payload data_size else payload, Cstruct.empty
+    in
+    let payload_len = Cstruct.len this_payload in
+    Ipv4_wire.set_ipv4_csum 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! *)
+     | Error msg -> invalid_arg msg
+     | Ok () -> ());
+    let acc' = Cstruct.append hdr_buf this_payload :: acc in
+    if more then
+      let offset = offset + data_size in
+      (frag1[@tailcall]) acc' hdr hdr_buf offset data_size rest
+    else
+      acc'
+  in
+  let hdr_size =
+    (* padded to 4 byte boundary *)
+    let opt_size = (Cstruct.len hdr.Ipv4_packet.options + 3) / 4 * 4 in
+    opt_size + Ipv4_wire.sizeof_ipv4
+  in
+  let data_size =
+    let full = mtu - hdr_size in
+    (full / 8) * 8
+  in
+  if data_size <= 0 then
+    []
+  else
+    List.rev (frag1 [] hdr (Cstruct.create hdr_size) data_size data_size payload)

src/ipv4/fragments.mli

@@ -14,14 +14,53 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
+(** IPv4 Fragmentation and reassembly
+
+    An IPv4 packet may exceed the maximum transferable unit (MTU) of a link, and
+   thus may be fragmented into multiple packets. Since the MTU depends on the
+   underlying link, fragmentation and reassembly may happen in gateways as well
+   as endpoints. Starting at byte 6, 16 bit in the IPv4 header are used for
+   fragmentation. The first bit is reserved, the second signals if set to never
+   fragment this packet - instead if it needs to be fragmented, an ICMP error
+   must be returned (used for path MTU discovery). The third bit indicates
+   whether this is the last fragment or more are following. The remaining 13
+   bits are the offset of this fragment in the reassembled packet, divided by
+   8. All fragments of one reassembled packet use the same 16 bit IPv4
+   identifier (byte offset 4). The IPv4 header is repeated in each fragment,
+   apart from those options which highest bit is cleared. Fragments may be
+   received in any order.
+
+    This module implements a reassembly cache, using a least recently used (LRU)
+   cache underneath. For security reasons, only non-overlapping fragments are
+   accepted. To avoid denial of service attacks, the maximum number of segments
+   is limited to 16 - with a common MTU of 1500, this means that packets
+   exceeding 24000 bytes will be dropped. The arrival time of the first and last
+   fragment may not exceed 10 seconds. There is no per-source IP limit of
+   fragment data to keep, only the total amount of fragmented data can be
+   limited by the choice of the size of the LRU.
+
+    Any received packet may be the last needed for a successful reassembly (due
+   to receiving them out-of-order). When the last fragment (which has the more
+   fragments bit cleared) for a quadruple source IP, destination IP, IP
+   identifier, and protocol ID, is received, reassembly is attempted - also on
+   subsequent packets with the same quadruple. *)
+
 module V : sig
   type t = int64 * Cstruct.t * bool * int * (int * Cstruct.t) list
+  (** The type of values in the fragment cache: a timestamp of the first
+     received one, IP options (of the first fragment), whether or not the last
+     fragment was received (the one with more fragments cleared), amount of
+     received fragments, and a list of pairs of offset and fragment. *)
 
   val weight : t -> int
+  (** [weight t] is the data length of the received fragments. *)
 end
 
 module K : sig
   type t = Ipaddr.V4.t * Ipaddr.V4.t * int * int
+  (** The type of keys in the fragment cache: source IP address, destination
+      IP address, protocol type, and IP identifier. *)
+
   val compare : t -> t -> int
 end
 
@@ -30,6 +69,24 @@ module Cache : sig
 end
 
 val max_duration : int64
+(** [max_duration] is the maximum delta between first and last received
+    fragment, in nanoseconds. At the moment it is 10 seconds. *)
+
+val process : Cache.t -> int64 -> Ipv4_packet.t -> Cstruct.t -> Cache.t *
+   (Ipv4_packet.t * Cstruct.t) option (** [process t timestamp hdr payload] is
+   [t'], a new cache, and maybe a fully reassembled IPv4 packet. If reassembly
+   fails, e.g. too many fragments, delta between receive timestamp of first and
+   last packet exceeds {!max_duration}, overlapping packets, these packets
+   will be dropped from the cache. The IPv4 header options are always taken from
+   the first fragment (where offset is 0). If the provided IPv4 header has an
+   fragmentation offset of 0, and the more fragments bit is not set, the given
+   header and payload is directly returned. Handles out-of-order fragments
+   gracefully. *)
 
-val process : Cache.t -> int64 -> Ipv4_packet.t -> Cstruct.t ->
-  Cache.t * (Ipv4_packet.t * Cstruct.t) option
+val fragment : mtu:int -> Ipv4_packet.t -> Cstruct.t -> Cstruct.t list
+(** [fragment ~mtu hdr payload] is called with the IPv4 header of the first
+    fragment and the remaining payload (which did not fit into the first
+    fragment). The [data_length = ((mtu - header_length hdr) / 8) * 8] is used
+    for each fragment (and it is assumed that the first fragment contains
+    exactly that much data). The number of packets returned is
+    [len payload / data_len]. If [data_len <= 0], the empty list is returned. *)

src/ipv4/static_ipv4.ml

@@ -64,90 +64,72 @@ module Make (R: Mirage_random.C) (C: Mirage_clock.MCLOCK) (Ethernet: Mirage_prot
       (* no options here, always 20 bytes! *)
       let hdr_len = Ipv4_wire.sizeof_ipv4 in
       let needed_bytes = Cstruct.lenv bufs + hdr_len + size in
+      let multiple = needed_bytes > mtu in
       (* construct the header (will be reused across fragments) *)
-      let hdr =
-        let src = match src with None -> t.ip | Some x -> x in
-        let off = if fragment then 0x0000 else 0x4000 in
-        Ipv4_packet.{
-          options = Cstruct.empty ;
-          src ; dst ;
-          ttl ; off ; id = 0 ;
-          proto = Ipv4_packet.Marshal.protocol_to_int proto }
-      in
-      let writeout size fill =
-        Ethernet.write t.ethif mac `IPv4 ~size fill >|= function
-        | Error e ->
-          Log.warn (fun f -> f "Error sending Ethernet frame: %a" Ethernet.pp_error e);
-          Error (`Ethif e)
-        | Ok () -> Ok ()
-      in
-      Log.debug (fun m -> m "ip write: mtu is %d, hdr_len is %d, size %d payload len %d, needed_bytes %d"
-                   mtu hdr_len size (Cstruct.lenv bufs) needed_bytes) ;
-      if mtu >= needed_bytes then begin
-        (* single fragment *)
+      if not fragment && multiple then
+        Lwt.return (Error `Would_fragment)
+      else
+        let off =
+          match fragment, multiple with
+          | true, true -> 0x2000
+          | false, false -> 0x4000
+          | true, false -> 0x0000
+          | false, true -> assert false (* handled by conditional above *)
+        in
+        let hdr =
+          let src = match src with None -> t.ip | Some x -> x in
+          let id = if multiple then Randomconv.int16 R.generate else 0 in
+          Ipv4_packet.{
+            options = Cstruct.empty ;
+            src ; dst ; ttl ; off ; id ;
+            proto = Ipv4_packet.Marshal.protocol_to_int proto }
+        in
+        let writeout size fill =
+          Ethernet.write t.ethif mac `IPv4 ~size fill >|= function
+          | Error e ->
+            Log.warn (fun f -> f "Error sending Ethernet frame: %a"
+                         Ethernet.pp_error e);
+            Error (`Ethif e)
+          | Ok () -> Ok ()
+        in
+        Log.debug (fun m -> m "ip write: mtu is %d, hdr_len is %d, size %d \
+                               payload len %d, needed_bytes %d"
+                      mtu hdr_len size (Cstruct.lenv bufs) needed_bytes) ;
+        let leftover = ref Cstruct.empty in
+        (* first fragment *)
         let fill buf =
-          let hdr_buf, payload_buf = Cstruct.split buf hdr_len in
+          let payload_buf = Cstruct.shift buf hdr_len in
           let header_len = headerf payload_buf in
           if header_len > size then begin
             Log.err (fun m -> m "headers returned length exceeding size") ;
             invalid_arg "headerf exceeds size"
           end ;
           (* need to copy the given payload *)
-          let len, leftover =
+          let len, rest =
             Cstruct.fillv ~src:bufs ~dst:(Cstruct.shift payload_buf header_len)
           in
-          if leftover <> [] then begin
-            Log.err (fun m -> m "there's some leftover data") ;
-            invalid_arg "leftover data"
-          end ;
+          leftover := Cstruct.concat rest;
           let payload_len = header_len + len in
           match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr buf with
-          | Ok () -> Ipv4_common.set_checksum hdr_buf ; payload_len + hdr_len
+          | Ok () -> payload_len + hdr_len
           | Error msg ->
             Log.err (fun m -> m "failure while assembling ip frame: %s" msg) ;
             invalid_arg msg
         in
-        writeout needed_bytes fill
-      end else if fragment then begin
-        (* where are we? -- need to allocate size, execute fillf
-           --> if size + hdr_len > mtu, we need this allocated here *)
-        let proto_header = Cstruct.create size in
-        let header_len = headerf proto_header in
-        if header_len > size then begin
-            Log.err (fun m -> m "(frag) headers returned length exceeding size") ;
-            invalid_arg "(frag) headerf exceeds size"
-          end ;
-        let proto_header = Cstruct.sub proto_header 0 header_len in
-        let bufs = ref (proto_header :: bufs) in
-        let hdr = { hdr with id = Randomconv.int16 R.generate } in
-        let rec send off =
-          match !bufs with
-          | [] -> Lwt.return (Ok ())
-          | to_send ->
-            let pay_len = min (mtu - hdr_len) (Cstruct.lenv to_send) in
-            let fill buf =
-              let hdr_buf, payload_buf = Cstruct.split buf hdr_len in
-              let len, leftover = Cstruct.fillv ~src:!bufs ~dst:payload_buf in
-              Log.debug (fun m -> m "header buffer is %d, payload %d (requested was %d) len %d"
-                            (Cstruct.len hdr_buf) (Cstruct.len payload_buf)
-                            (pay_len + hdr_len) len) ;
-              bufs := leftover ;
-              let last = match leftover with [] -> true | _ -> false in
-              let off = if last then off else off lor 0x2000 in
-              let hdr = { hdr with off } in
-              match Ipv4_packet.Marshal.into_cstruct ~payload_len:len hdr buf with
-              | Ok () -> Ipv4_common.set_checksum hdr_buf ; pay_len + hdr_len
-              | Error msg ->
-                Log.err (fun m -> m "failure while assembling ip frame: %s" msg) ;
-                invalid_arg msg
-            in
-            writeout (hdr_len + pay_len) fill >>= function
-            | Error e -> Lwt.return (Error e)
-            | Ok () -> send (off + pay_len lsr 3)
-        in
-        send 0
-      end else (* error out, as described in the semantics *)
-        Lwt.return (Error `Would_fragment)
+        writeout (min mtu needed_bytes) fill >>= function
+        | Error e -> Lwt.return (Error e)
+        | Ok () ->
+          if not multiple then
+            Lwt.return (Ok ())
+          else
+            let remaining = Fragments.fragment ~mtu hdr !leftover in
+            Lwt_list.fold_left_s (fun acc p ->
+                match acc with
+                | Error e -> Lwt.return (Error e)
+                | Ok () ->
+                  let l = Cstruct.len p in
+                  writeout l (fun buf -> Cstruct.blit p 0 buf 0 l ; l))
+              (Ok ()) remaining
 
   let input t ~tcp ~udp ~default buf =
     match Ipv4_packet.Unmarshal.of_cstruct buf with

test/test_ipv4.ml

@@ -111,7 +111,7 @@ let basic_reassembly_timeout () =
   Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;
   Lwt.return_unit
 
-let reassembly_out_of_orfer () =
+let reassembly_out_of_order () =
   let more_frags = { test_packet with off = mf } in
   let off_packet = { test_packet with off = 2 } in
   let cache, res = Fragments.process empty_cache 0L off_packet gray in
@@ -121,7 +121,7 @@ let reassembly_out_of_orfer () =
               (snd @@ Fragments.process cache 0L more_frags black)) ;
   Lwt.return_unit
 
-let reassembly_multiple_out_of_orfer packets final_payload () =
+let reassembly_multiple_out_of_order packets final_payload () =
   let _, res = List.fold_left (fun (cache, res) (off, payload) ->
       Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;
       let packet = { test_packet with off } in
@@ -202,6 +202,45 @@ let rec permutations = function
   | x::xs -> List.fold_left (fun acc p -> acc @ ins_all_positions x p ) []
                (permutations xs)
 
+let fragment_simple () =
+  let hdr =
+    { Ipv4_packet.src = Ipaddr.V4.localhost ; dst = Ipaddr.V4.localhost ;
+      id = 0x42 ; off = 0 ; ttl = 10 ; proto = 10 ; options = Cstruct.empty }
+  in
+  let payload = Cstruct.create 1030 in
+  let fs = Fragments.fragment ~mtu:36 hdr payload in
+  (* 16 byte per packet -> 64 fragments (a 16 byte) + 1 (6 byte) *)
+  Alcotest.(check int __LOC__ 65 (List.length fs));
+  let second, last = List.hd fs, List.(hd (rev fs)) in
+  Alcotest.(check int __LOC__ 26 (Cstruct.len last));
+  match
+    Ipv4_packet.Unmarshal.of_cstruct second,
+    Ipv4_packet.Unmarshal.of_cstruct last
+  with
+  | Error e, _ -> Alcotest.fail ("failed to decode second fragment " ^ e)
+  | _, Error e -> Alcotest.fail ("failed to decode last fragment " ^ e)
+  | Ok (hdr, _payload), Ok (hdr', _payload') ->
+    Alcotest.(check int __LOC__ (0x2000 lor 2) hdr.Ipv4_packet.off);
+    Alcotest.(check int __LOC__ 0x42 hdr.Ipv4_packet.id);
+    Alcotest.(check int __LOC__ 130 hdr'.Ipv4_packet.off);
+    Alcotest.(check int __LOC__ 0x42 hdr'.Ipv4_packet.id);
+    let fs' = Fragments.fragment ~mtu:36 hdr (Cstruct.sub payload 0 1024) in
+    (* 16 byte per packet -> 64 fragments (a 16 byte) *)
+    Alcotest.(check int __LOC__ 64 (List.length fs'));
+    let second', last' = List.hd fs', List.(hd (rev fs')) in
+    Alcotest.(check int __LOC__ 36 (Cstruct.len last'));
+    match
+      Ipv4_packet.Unmarshal.of_cstruct second',
+      Ipv4_packet.Unmarshal.of_cstruct last'
+    with
+    | Error e, _ -> Alcotest.fail ("failed to decode second fragment' " ^ e)
+    | _, Error e -> Alcotest.fail ("failed to decode last fragment' " ^ e)
+    | Ok (hdr'', _payload''), Ok (hdr''', _payload''') ->
+      Alcotest.(check int __LOC__ (0x2000 lor 2) hdr''.Ipv4_packet.off);
+      Alcotest.(check int __LOC__ 0x42 hdr''.Ipv4_packet.id);
+      Alcotest.(check int __LOC__ 128 hdr'''.Ipv4_packet.off);
+      Alcotest.(check int __LOC__ 0x42 hdr'''.Ipv4_packet.id)
+
 let suite = [
   "unmarshal ip datagram with options", `Quick, test_unmarshal_with_options;
   "unmarshal ip datagram without options", `Quick, test_unmarshal_without_options;
@@ -212,12 +251,12 @@ let suite = [
     [ 0 ; 1 ; 2 ; 10 ; 100 ; 1000 ; 5000 ; 10000 ] @ [
     "basic reassembly", `Quick, basic_reassembly;
     "basic reassembly timeout", `Quick, basic_reassembly_timeout;
-    "reassembly out of order", `Quick, reassembly_out_of_orfer ;
+    "reassembly out of order", `Quick, reassembly_out_of_order ;
     "other ip flow", `Quick, basic_other_ip_flow ;
     "maximum amount of fragments", `Quick, max_fragment ] @
     List.mapi (fun i (packets, final) ->
       Printf.sprintf "ressembly multiple %d" i, `Quick,
-      reassembly_multiple_out_of_orfer packets final)
+      reassembly_multiple_out_of_order packets final)
     ([
       ([ (mf, white); (2, black) ], Cstruct.concat [white;black]);
       ([ (mf, black); (2, white) ], Cstruct.concat [black;white]);
@@ -259,4 +298,6 @@ let suite = [
       permutations [ (mf, gray); (4 lor mf, white); (4 lor mf, black); (6, gray)] @
       permutations [ (mf, gray); (1 lor mf, white); (3 lor mf, black); (5, gray)] @
       permutations [ (mf, gray); (2 lor mf, white); (4 lor mf, black); (7, gray)]
-    )
+    ) @ [
+    "simple fragment", `Quick, (fun () -> Lwt.return (fragment_simple ()))
+  ]