IPv4 fragment reassembly

src/ipv4/fragments.ml

@@ -0,0 +1,141 @@
+let src = Logs.Src.create "ipv4-fragments" ~doc:"IPv4 fragmentation"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+open Rresult.R.Infix
+
+(* IP Fragmentation using a LRU cache:
+
+   The key of our cache is source ip * destination ip * protocol * identifier.
+   The value is a quintuple consisting of first segment received. IP options
+   (which are usually sent only in the first IP segment), "last segment
+   received" (i.e. an IPv4 segment without the more fragment bit set), a counter
+   of the length of items, and a list of pairs, which contain an offset and
+   payload.  The list is sorted by offset in descending order. *)
+
+module V = struct
+  type t = int64 * Cstruct.t * bool * int * (int * Cstruct.t) list
+
+  let weight (_, _, _, _, v) = Cstruct.lenv (List.map snd v)
+end
+
+module K = struct
+  type t = Ipaddr.V4.t * Ipaddr.V4.t * int * int
+
+  let compare (src, dst, proto, id) (src', dst', proto', id') =
+    let (&&&) a b = match a with 0 -> b | x -> x in
+    let int_cmp : int -> int -> int = compare in
+    Ipaddr.V4.compare src src' &&&
+    Ipaddr.V4.compare dst dst' &&&
+    int_cmp proto proto' &&&
+    int_cmp id id'
+end
+
+module Cache = Lru.F.Make(K)(V)
+
+(* insert_sorted inserts a fragment in a list, sort is by frag_start, descending *)
+let rec insert_sorted ((frag_start, data) as frag) = function
+  | [] -> [ frag ]
+  | ((frag'_start, data') as frag')::tl ->
+    if frag'_start <= frag_start
+    then frag::frag'::tl
+    else frag'::insert_sorted frag tl
+
+(* attempt_reassemble takes a list of fragments, and returns either
+   - Ok payload when the payload was completed
+   - Error Hole if some fragment is still missing
+   - Error Bad if the list of fragments was bad: it contains overlapping
+     segments.  This is an indication for malicious activity, and we drop the
+     IP fragment
+
+There are various attacks (and DoS) on IP reassembly, most prominent use
+overlapping segments (and selection thereof), we just drop overlapping segments
+(similar as Linux does since https://git.kernel.org/pub/scm/linux/kernel/git/davem/net-next.git/commit/?id=c30f1fc041b74ecdb072dd44f858750414b8b19f).
+*)
+
+type r = Bad | Hole
+
+let attempt_reassemble fragments =
+  Log.debug (fun m -> m "reassemble %a"
+                Fmt.(list ~sep:(unit "; ") (pair ~sep:(unit ", len ") int int))
+                (List.map (fun (off, data) -> off, Cstruct.len data) fragments)) ;
+  (* input: list of (offset, fragment) with decreasing offset *)
+  (* output: maybe a cstruct.t if there are no gaps *)
+  let len =
+    (* List.hd is safe here, since we are never called with an empty list *)
+    let off, data = List.hd fragments in
+    off + Cstruct.len data
+  in
+  let rec check until = function
+    | [] -> if until = 0 then Ok () else Error Hole
+    | (start, d)::tl ->
+      let until' = start + (Cstruct.len d) in
+      if until = until'
+      then check start tl
+      else if until' > until
+      then Error Bad
+      else Error Hole
+  in
+  check len fragments >>= fun () ->
+  let buf = Cstruct.create_unsafe len in
+  List.iter (fun (off, data) ->
+      Cstruct.blit data 0 buf off (Cstruct.len data))
+    fragments ;
+  Ok buf
+
+let max_number_of_fragments = 16
+
+let max_duration = Duration.of_sec 10
+
+let process cache ts (packet : Ipv4_packet.t) payload =
+  Log.debug (fun m -> m "process called with off %x" packet.off) ;
+  if packet.off land 0x3FFF = 0 then (* ignore reserved and don't fragment *)
+    (* fastpath *)
+    cache, Some (packet, payload)
+  else
+    let offset, more =
+      (packet.off land 0x1FFF) lsl 3, (* of 8 byte blocks *)
+      packet.off land 0x2000 = 0x2000
+    and key = (packet.src, packet.dst, packet.proto, packet.id)
+    in
+    match Cache.find key cache with
+    | None ->
+      Log.debug (fun m -> m "%a none found, inserting into cache" Ipv4_packet.pp packet) ;
+      Cache.add key (ts, packet.options, not more, 1, [(offset, payload)]) cache, None
+    | Some ((ts', options, finished, cnt, frags), cache') ->
+      if Int64.sub ts ts' >= max_duration then begin
+        Log.warn (fun m -> m "%a found some, but timestamp exceeded duration %a, dropping old segments and inserting new segment into cache" Ipv4_packet.pp packet Duration.pp max_duration) ;
+        Cache.add key (ts, packet.options, not more, 1, [(offset, payload)]) cache, None
+      end else
+        let all_frags = insert_sorted (offset, payload) frags
+        and try_reassemble = finished || not more
+        and options' = if offset = 0 then packet.options else options
+        in
+        Log.debug (fun m -> m "%d found, finished %b more %b try_reassemble %b"
+                      cnt finished more try_reassemble) ;
+        let maybe_add_to_cache c =
+          if cnt < max_number_of_fragments then
+            Cache.add key (ts', options', try_reassemble, succ cnt, all_frags) c
+          else
+            (Log.warn (fun m -> m "%a dropping from cache, maximum number of fragments exceeded"
+                          Ipv4_packet.pp packet) ;
+             Cache.remove key c)
+        in
+        if try_reassemble then
+          match attempt_reassemble all_frags with
+          | Ok p ->
+            Log.debug (fun m -> m "%a reassembled to payload %d" Ipv4_packet.pp packet (Cstruct.len p)) ;
+            let packet' = { packet with options = options' ; off = 0 } in
+            Cache.remove key cache', Some (packet', p)
+          | Error Bad ->
+            Log.warn (fun m -> m "%a dropping from cache, bad fragments (%a)"
+                         Ipv4_packet.pp packet
+                         Fmt.(list ~sep:(unit "; ") (pair ~sep:(unit ", ") int int))
+                         (List.map (fun (s, d) -> (s, Cstruct.len d)) all_frags)) ;
+            Logs.debug (fun m -> m "full fragments: %a"
+                           Fmt.(list ~sep:(unit "@.") Cstruct.hexdump_pp)
+                           (List.map snd all_frags)) ;
+
+            Cache.remove key cache', None
+          | Error Hole -> maybe_add_to_cache cache', None
+        else
+          maybe_add_to_cache cache', None

src/ipv4/ipv4_common.ml

@@ -23,7 +23,8 @@ let allocate_frame ~src ~source ~(dst:Ipaddr.V4.t) ~(proto : [`ICMP | `TCP | `UD
     let buf = Cstruct.shift ethernet_frame Ethif_wire.sizeof_ethernet in
     (* TODO: why 38 for TTL? *)
     let ipv4_header = Ipv4_packet.({options = Cstruct.create 0;
-                                    src; dst; ttl = 38; 
+                                    src; dst; ttl = 38;
+                                    off = 0 ; id = 0x0000 ;
                                     proto = Ipv4_packet.Marshal.protocol_to_int proto; }) in
     (* set the payload_len to 0, since we don't know what it'll be yet *)
     (* the caller needs to then use [writev] or [write] to output the buffer;

src/ipv4/ipv4_packet.ml

@@ -1,8 +1,10 @@
 type t = {
   src     : Ipaddr.V4.t;
   dst     : Ipaddr.V4.t;
-  proto   : Cstruct.uint8;
+  id      : Cstruct.uint16;
+  off     : Cstruct.uint16;
   ttl     : Cstruct.uint8;
+  proto   : Cstruct.uint8;
   options : Cstruct.t;
 }
 
@@ -12,14 +14,16 @@ type protocol = [
   | `UDP ]
 
 let pp fmt t =
-  Format.fprintf fmt "IPv4 packet %a -> %a: proto %d, ttl %d, options %a"
-    Ipaddr.V4.pp_hum t.src Ipaddr.V4.pp_hum t.dst t.proto t.ttl Cstruct.hexdump_pp t.options
+  Format.fprintf fmt "IPv4 packet %a -> %a: id %04x, off %d proto %d, ttl %d, options %a"
+    Ipaddr.V4.pp_hum t.src Ipaddr.V4.pp_hum t.dst t.id t.off t.proto t.ttl Cstruct.hexdump_pp t.options
 
-let equal {src; dst; proto; ttl; options} q =
+let equal {src; dst; id; off; ttl; proto; options} q =
   src = q.src &&
   dst = q.dst &&
-  proto = q.proto &&
+  id = q.id &&
+  off = q.off &&
   ttl = q.ttl &&
+  proto = q.proto &&
   Cstruct.equal options q.options
 
 module Marshal = struct
@@ -33,6 +37,7 @@ module Marshal = struct
     | `UDP    -> 17
 
   let pseudoheader ~src ~dst ~proto len =
+    (* should we do sth about id or off (assert false?) *)
     let proto = protocol_to_int proto in
     let ph = Cstruct.create 12 in
     let numify = Ipaddr.V4.to_int32 in
@@ -120,8 +125,10 @@ module Unmarshal = struct
       let payload_len = (get_ipv4_len buf) - options_end in
       let src = Ipaddr.V4.of_int32 (get_ipv4_src buf) in
       let dst = Ipaddr.V4.of_int32 (get_ipv4_dst buf) in
-      let proto = get_ipv4_proto 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 options =
         if options_end > sizeof_ipv4 then (Cstruct.sub buf sizeof_ipv4 (options_end - sizeof_ipv4))
         else (Cstruct.create 0)
@@ -131,7 +138,7 @@ module Unmarshal = struct
         Error (Printf.sprintf "Payload buffer (%d bytes) too small to contain payload (of size %d from header)" payload_available payload_len)
       ) else (
         let payload = Cstruct.sub buf options_end payload_len in
-        Ok ({src; dst; proto; ttl; options;}, payload)
+        Ok ({src; dst; id; off; ttl; proto; options;}, payload)
       )
     in
     size_check buf >>= check_version >>= get_header_length >>= parse buf

src/ipv4/ipv4_packet.mli

@@ -1,8 +1,10 @@
 type t = {
   src     : Ipaddr.V4.t;
   dst     : Ipaddr.V4.t;
-  proto   : Cstruct.uint8;
+  id      : Cstruct.uint16;
+  off     : Cstruct.uint16;
   ttl     : Cstruct.uint8;
+  proto   : Cstruct.uint8;
   options : Cstruct.t;
 }
 

src/ipv4/jbuild

@@ -3,6 +3,6 @@
  ((name        tcpip_ipv4)
   (public_name tcpip.ipv4)
   (libraries   (logs io-page mirage-protocols-lwt ipaddr cstruct rresult
-                tcpip tcpip.ethif tcpip.udp mirage-random mirage-clock randomconv))
+                tcpip tcpip.ethif tcpip.udp mirage-random mirage-clock randomconv lru))
   (preprocess (pps (ppx_cstruct)))
   (wrapped false)))

src/ipv4/static_ipv4.ml

@@ -36,9 +36,11 @@ module Make (R: Mirage_random.C) (C: Mirage_clock.MCLOCK) (Ethif: Mirage_protoco
   type t = {
     ethif : Ethif.t;
     arp : Arpv4.t;
+    clock : C.t;
     mutable ip: Ipaddr.V4.t;
     network: Ipaddr.V4.Prefix.t;
     mutable gateway: Ipaddr.V4.t option;
+    mutable cache: Fragments.Cache.t;
   }
 
   let adjust_output_header = Ipv4_common.adjust_output_header ~rng:R.generate
@@ -74,36 +76,43 @@ module Make (R: Mirage_random.C) (C: Mirage_clock.MCLOCK) (Ethif: Mirage_protoco
     writev t frame [buf]
 
   (* TODO: ought we to check to make sure the destination is relevant here?  currently we'll process all incoming packets, regardless of destination address *)
-  let input _t ~tcp ~udp ~default buf =
-    let open Ipv4_packet in
-    match Unmarshal.of_cstruct buf with
+  let input t ~tcp ~udp ~default buf =
+    match Ipv4_packet.Unmarshal.of_cstruct buf with
     | Error s ->
-      Log.info (fun f -> f "IP.input: unparseable header (%s): %S" s (Cstruct.to_string buf));
+      Log.info (fun m -> m "error %s while parsing IPv4 frame %a" s Cstruct.hexdump_pp buf);
       Lwt.return_unit
     | Ok (packet, payload) ->
-      match Unmarshal.int_to_protocol packet.proto, Cstruct.len payload with
-      | Some _, 0 ->
-        (* Don't pass on empty buffers as payloads to known protocols, as they have no relevant headers *)
-        Lwt.return_unit
-      | None, 0 -> (* we don't know anything about the protocol; an empty
-                      payload may be meaningful somehow? *)
-        default ~proto:packet.proto ~src:packet.src ~dst:packet.dst payload
-      | Some `TCP, _ -> tcp ~src:packet.src ~dst:packet.dst payload
-      | Some `UDP, _ -> udp ~src:packet.src ~dst:packet.dst payload
-      | Some `ICMP, _ | None, _ ->
-        default ~proto:packet.proto ~src:packet.src ~dst:packet.dst payload
+      if Cstruct.len payload = 0 then
+        (Log.info (fun m -> m "dropping zero length IPv4 frame %a" Ipv4_packet.pp packet) ;
+         Lwt.return_unit)
+      else
+        let ts = C.elapsed_ns t.clock in
+        let cache, res = Fragments.process t.cache ts packet payload in
+        t.cache <- cache ;
+        match res with
+        | None -> Lwt.return_unit
+        | Some (packet, payload) ->
+          let src, dst = packet.src, packet.dst in
+          match Ipv4_packet.Unmarshal.int_to_protocol packet.proto with
+          | Some `TCP -> tcp ~src ~dst payload
+          | Some `UDP -> udp ~src ~dst payload
+          | Some `ICMP | None -> default ~proto:packet.proto ~src ~dst payload
 
   let connect
       ?(ip=Ipaddr.V4.any)
       ?(network=Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any)
-      ?(gateway=None) _clock ethif arp =
+      ?(gateway=None) clock ethif arp =
     match Ipaddr.V4.Prefix.mem ip network with
     | false ->
-      Log.warn (fun f -> f "IPv4: ip %a is not in the prefix %a" Ipaddr.V4.pp_hum ip Ipaddr.V4.Prefix.pp_hum network);
+      Log.warn (fun f -> f "IPv4: ip %a is not in the prefix %a"
+                   Ipaddr.V4.pp_hum ip Ipaddr.V4.Prefix.pp_hum network);
       Lwt.fail_with "given IP is not in the network provided"
     | true ->
       Arpv4.set_ips arp [ip] >>= fun () ->
-      let t = { ethif; arp; ip; network; gateway } in
+      (* TODO currently hardcoded to 4MB, should be configurable
+         and maybe limited per-src/dst-ip as well? *)
+      let cache = Fragments.Cache.empty (1024 * 1024 * 4) in
+      let t = { ethif; arp; ip; clock; network; gateway ; cache } in
       Lwt.return t
 
   let disconnect _ = Lwt.return_unit

tcpip.opam

@@ -48,5 +48,6 @@ depends: [
   "alcotest" {test & >="0.7.0"}
   "pcap-format" {test}
   "mirage-clock-unix" {test & >= "1.2.0"}
+  "lru"
 ]
 available: [ocaml-version >= "4.03.0"]

test/test_checksums.ml

@@ -51,7 +51,7 @@ let udp_ipv4_zero_checksum () =
   let ipv4_header = Ipv4_packet.{
         src; dst;
         proto = Ipv4_packet.Marshal.protocol_to_int proto;
-        ttl; options } in
+        ttl; id = 0 ; off = 0 ; options } in
   let pseudoheader = Ipv4_packet.Marshal.pseudoheader
       ~src
       ~dst

test/test_ipv4.ml

@@ -38,7 +38,7 @@ let test_size () =
   let src = Ipaddr.V4.of_string_exn "127.0.0.1" in
   let dst = Ipaddr.V4.of_string_exn "127.0.0.2" in
   let ttl = 64 in
-  let ip = { Ipv4_packet.src; dst; proto = 17; ttl; options = (Cstruct.of_string "aaaa") } in
+  let ip = { Ipv4_packet.src; dst; proto = 17; ttl; id = 0 ; off = 0 ; options = (Cstruct.of_string "aaaa") } in
   let payload = Cstruct.of_string "abcdefgh" in
   let tmp = Ipv4_packet.Marshal.make_cstruct ~payload_len:(Cstruct.len payload) ip in
   let tmp = Cstruct.concat [tmp; payload] in

test/test_tcp_options.ml

@@ -175,7 +175,7 @@ let test_marshal_into_cstruct () =
   let src = Ipaddr.V4.of_string_exn "127.0.0.1" in
   let dst = Ipaddr.V4.of_string_exn "127.0.0.1" in
   let ipv4_header =
-    {Ipv4_packet.src; dst; proto = 6; ttl = 64; options = Cstruct.create 0}
+    {Ipv4_packet.src; dst; proto = 6; ttl = 64; id = 0 ; off = 0 ; options = Cstruct.create 0}
   in
   let payload = Cstruct.of_string "ab" in
   let pseudoheader =
@@ -232,7 +232,7 @@ let test_marshal_without_padding () =
   let src = Ipaddr.V4.of_string_exn "127.0.0.1" in
   let dst = Ipaddr.V4.of_string_exn "127.0.0.1" in
   let ipv4_header =
-    {Ipv4_packet.src; dst; proto = 6; ttl = 64; options = Cstruct.create 0}
+    {Ipv4_packet.src; dst; proto = 6; ttl = 64; id = 0 ; off = 0 ; options = Cstruct.create 0}
   in
   let payload = Cstruct.of_string "\x02\x04\x05\xb4" in
   let pseudoheader =