unikernel/duniverse/mirage-tcpip/src/ipv4/static_ipv4.ml

@@ -0,0 +1,187 @@
+(*
+ * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Lwt.Infix
+
+let src = Logs.Src.create "ipv4" ~doc:"Mirage IPv4"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Make (Ethernet: Ethernet.S) (Arpv4 : Arp.S) = struct
+  module Routing = Routing.Make(Log)(Arpv4)
+
+  (** IO operation errors *)
+  type error = [ Tcpip.Ip.error | `Would_fragment | `Ethif of Ethernet.error ]
+  let pp_error ppf = function
+    | #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e
+    | `Ethif e -> Ethernet.pp_error ppf e
+
+  type ipaddr = Ipaddr.V4.t
+  type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
+
+  let pp_ipaddr = Ipaddr.V4.pp
+
+  type prefix = Ipaddr.V4.Prefix.t
+
+  let pp_prefix = Ipaddr.V4.Prefix.pp
+
+  type t = {
+    ethif : Ethernet.t;
+    arp : Arpv4.t;
+    cidr: Ipaddr.V4.Prefix.t;
+    gateway: Ipaddr.V4.t option;
+    mutable cache: Fragments.Cache.t;
+  }
+
+  let write t ?(fragment = true) ?(ttl = 38) ?src dst proto ?(size = 0) headerf bufs =
+    Routing.destination_mac t.cidr t.gateway t.arp dst >>= function
+    | Error `Local ->
+      Log.warn (fun f -> f "Could not find %a on the local network" Ipaddr.V4.pp dst);
+      Lwt.return @@ Error (`No_route "no response for IP on local network")
+    | Error `Gateway when t.gateway = None ->
+      Log.warn (fun f -> f "Write to %a would require an external route, which was not provided" Ipaddr.V4.pp dst);
+      Lwt.return @@ Ok ()
+    | Error `Gateway ->
+      Log.warn (fun f -> f "Write to %a requires an external route, and the provided %a was not reachable" Ipaddr.V4.pp dst (Fmt.option Ipaddr.V4.pp) t.gateway);
+      (* when a gateway is specified the user likely expects their traffic to be passed to it *)
+      Lwt.return @@ Error (`No_route "no route to default gateway to outside world")
+    | Ok mac ->
+      (* need first to deal with fragmentation decision - find out mtu *)
+      let mtu = Ethernet.mtu t.ethif in
+      (* 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) *)
+      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 -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in
+          let id = if multiple then Randomconv.int16 Mirage_crypto_rng.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 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, rest =
+            Cstruct.fillv ~src:bufs ~dst:(Cstruct.shift payload_buf header_len)
+          in
+          leftover := Cstruct.concat rest;
+          let payload_len = header_len + len in
+          match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr buf with
+          | Ok () -> payload_len + hdr_len
+          | Error msg ->
+            Log.err (fun m -> m "failure while assembling ip frame: %s" msg) ;
+            invalid_arg msg
+        in
+        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.length 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
+    | Error s ->
+      Log.info (fun m -> m "error %s while parsing IPv4 frame %a" s Cstruct.hexdump_pp buf);
+      Lwt.return_unit
+    | Ok (packet, payload) ->
+      let of_interest ip =
+        Ipaddr.V4.(compare ip (Prefix.address t.cidr) = 0
+                   || compare ip broadcast = 0
+                   || compare ip (Prefix.broadcast t.cidr) = 0)
+      in
+      if not (of_interest packet.dst) then begin
+        Log.debug (fun m -> m "dropping IP fragment not for us or broadcast %a"
+                      Ipv4_packet.pp packet);
+        Lwt.return_unit
+      end else if Cstruct.length payload = 0 then begin
+        Log.debug (fun m -> m "dropping zero length IPv4 frame %a" Ipv4_packet.pp packet) ;
+        Lwt.return_unit
+      end else
+        let ts = Mirage_mtime.elapsed_ns () 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
+      ?(no_init = false) ~cidr ?gateway ?(fragment_cache_size = 1024 * 256) ethif arp =
+    (if no_init then
+       Lwt.return_unit
+     else
+       Arpv4.set_ips arp [Ipaddr.V4.Prefix.address cidr]) >|= fun () ->
+    let cache = Fragments.Cache.empty fragment_cache_size in
+    { ethif; arp; cidr; gateway; cache }
+
+  let disconnect _ = Lwt.return_unit
+
+  let get_ip t = [Ipaddr.V4.Prefix.address t.cidr]
+
+  let configured_ips t = [t.cidr]
+
+  let pseudoheader t ?src dst proto len =
+    let src = match src with None -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in
+    Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto len
+
+  let src t ~dst:_ = Ipaddr.V4.Prefix.address t.cidr
+
+  let mtu t ~dst:_ = Ethernet.mtu t.ethif - Ipv4_wire.sizeof_ipv4
+
+end