Merge pull request #269 from yomimono/arp-result-types

resultify arp; kill ipv4 routing exception; tcp ignores route failures

lib/arpv4/arpv4.ml

@@ -22,10 +22,16 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = struct
 
-  type result = [ `Ok of Macaddr.t | `Timeout ]
+  type 'a io = 'a Lwt.t
+  type buffer = Cstruct.t
+  type ipaddr = Ipaddr.V4.t
+  type macaddr = Macaddr.t
+  type ethif = Ethif.t
+  type repr = string
+  type error = [ `Timeout ]
 
   type entry =
-    | Pending of result Lwt.t * result Lwt.u
+    | Pending of (macaddr, error) result Lwt.t * (macaddr, error) result Lwt.u
     | Confirmed of int64 * Macaddr.t
 
   type t = {
@@ -35,14 +41,6 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
     mutable bound_ips: Ipaddr.V4.t list;
   }
 
-  type 'a io = 'a Lwt.t
-  type buffer = Cstruct.t
-  type ipaddr = Ipaddr.V4.t
-  type macaddr = Macaddr.t
-  type ethif = Ethif.t
-  type repr = string
-  type error
-
   let report_ethif_error s e =
     Logs.debug (fun f -> f "error on underlying ethernet interface when attempting to %s : %a" s Mirage_pp.pp_ethif_error e)
 
@@ -94,7 +92,7 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
         match Hashtbl.find t.cache ip with
         | Pending (_, w) ->
           Hashtbl.replace t.cache ip (Confirmed (expire, mac));
-          Lwt.wakeup w (`Ok mac)
+          Lwt.wakeup w (Ok mac)
         | Confirmed _ ->
           Hashtbl.replace t.cache ip (Confirmed (expire, mac))
       with
@@ -182,18 +180,18 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
   let query t ip =
     try match Hashtbl.find t.cache ip with
       | Pending (t, _) -> t
-      | Confirmed (_, mac) -> Lwt.return (`Ok mac)
+      | Confirmed (_, mac) -> Lwt.return (Ok mac)
     with
     | Not_found ->
       let response, waker = MProf.Trace.named_wait "ARP response" in
       Hashtbl.add t.cache ip (Pending (response, waker));
       let rec retry n () =
         (* First request, so send a query packet *)
         output_probe t ip >>= fun () ->
-        Lwt.choose [ (response >>= fun _ -> Lwt.return `Ok);
-                     (Time.sleep_ns probe_repeat_delay >>= fun () -> Lwt.return `Timeout) ] >>= function
-        | `Ok -> Lwt.return_unit
-        | `Timeout ->
+        Lwt.choose [ response ;
+                     (Time.sleep_ns probe_repeat_delay >>= fun () -> Lwt.return (Error `Timeout)) ] >>= function
+        | Ok mac -> Lwt.return_unit
+        | Error `Timeout ->
           if n < probe_num then begin
             let n = n+1 in
             Log.info (fun f -> f "ARP: retrying %a (n=%d)" Ipaddr.V4.pp_hum ip n);
@@ -202,7 +200,7 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
             Hashtbl.remove t.cache ip;
             Log.info (fun f -> f "ARP: giving up on resolution of %a after %d attempts"
                                Ipaddr.V4.pp_hum ip n);
-            Lwt.wakeup waker `Timeout;
+            Lwt.wakeup waker (Error `Timeout);
             Lwt.return_unit
           end
       in

lib/icmp/icmpv4.ml

@@ -24,7 +24,11 @@ module Make(IP : V1_LWT.IPV4) = struct
   let writev t ~dst bufs : (unit, error) result Lwt.t = 
     let frame, header_len = IP.allocate_frame t.ip ~dst ~proto:`ICMP in
     let frame = Cstruct.set_len frame header_len in
-    IP.writev t.ip frame bufs >|= Mirage_pp.reduce
+    IP.writev t.ip frame bufs >|= function
+    | Ok () as ok -> ok
+    | Error `No_route -> Error (`Routing (Format.asprintf "no route to %a" Ipaddr.V4.pp_hum dst))
+    | Error `Disconnected | Error `Unimplemented as e -> Mirage_pp.reduce e
+    | Error (`Msg _) as s -> s
 
   let write t ~dst buf = writev t ~dst [buf]
 

lib/ipv4/routing.ml

@@ -10,33 +10,33 @@ let mac_of_multicast ip =
   Bytes.set macb 5 (Bytes.get ipb 3);
   Macaddr.of_bytes_exn macb
 
-exception No_route_to_destination_address of Ipaddr.V4.t
+type routing_error = [ `Local | `Gateway ]
 
 module Make(Log : Logs.LOG) (A : V1_LWT.ARP) = struct
   open Lwt.Infix
 
   let destination_mac network gateway arp = function
     |ip when ip = Ipaddr.V4.broadcast || ip = Ipaddr.V4.any -> (* Broadcast *)
-      Lwt.return Macaddr.broadcast
+      Lwt.return @@ Ok Macaddr.broadcast
     |ip when Ipaddr.V4.is_multicast ip ->
-      Lwt.return (mac_of_multicast ip)
+      Lwt.return @@ Ok (mac_of_multicast ip)
     |ip when Ipaddr.V4.Prefix.mem ip network -> (* Local *)
       A.query arp ip >>= begin function
-        | `Ok mac -> Lwt.return mac
-        | `Timeout ->
+        | Ok mac -> Lwt.return (Ok mac)
+        | Error `Timeout ->
           Log.info (fun f -> f "IP.output: could not determine link-layer address for local network (%a) ip %a" Ipaddr.V4.Prefix.pp_hum network Ipaddr.V4.pp_hum ip);
-          Lwt.fail (No_route_to_destination_address ip)
+          Lwt.return @@ Error `Local
       end
     |ip -> (* Gateway *)
       match gateway with
       | None ->
           Log.info (fun f -> f "IP.output: no route to %a (no default gateway is configured)" Ipaddr.V4.pp_hum ip);
-          Lwt.fail (No_route_to_destination_address ip)
+          Lwt.return (Error `Gateway)
       | Some gateway ->
         A.query arp gateway >>= function
-          | `Ok mac -> Lwt.return mac
-          | `Timeout ->
+          | Ok mac -> Lwt.return (Ok mac)
+          | Error `Timeout ->
             Log.info (fun f -> f "IP.output: could not send to %a: failed to contact gateway %a"
                          Ipaddr.V4.pp_hum ip Ipaddr.V4.pp_hum gateway);
-            Lwt.fail (No_route_to_destination_address ip)
+            Lwt.return (Error `Gateway)
 end

lib/ipv4/static_ipv4.ml

@@ -22,7 +22,6 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 module Make(Ethif: V1_LWT.ETHIF) (Arpv4 : V1_LWT.ARP) = struct
   module Routing = Routing.Make(Log)(Arpv4)
-  exception No_route_to_destination_address of Ipaddr.V4.t
   (** IO operation errors *)
   type error = V1.Ip.error
 
@@ -50,15 +49,30 @@ module Make(Ethif: V1_LWT.ETHIF) (Arpv4 : V1_LWT.ARP) = struct
     let v4_frame = Cstruct.shift frame Ethif_wire.sizeof_ethernet in
     let dst = Ipaddr.V4.of_int32 (Ipv4_wire.get_ipv4_dst v4_frame) in
     (* Something of a layer violation here, but ARP is awkward *)
-    Routing.destination_mac t.network t.gateway t.arp dst >|=
-            Macaddr.to_bytes >>= fun dmac ->
-    let tlen = Cstruct.len frame + Cstruct.lenv bufs - Ethif_wire.sizeof_ethernet in
-    adjust_output_header ~dmac ~tlen frame;
-    Ethif.writev t.ethif (frame :: bufs) >|= function
-    | Ok () -> Ok ()
-    | Error e ->
-      Log.warn (fun f -> f "ethif write errored %a" Mirage_pp.pp_ethif_error e);
-      Error e
+    Routing.destination_mac t.network t.gateway t.arp dst >>= function
+    | Error `Local ->
+      Log.warn (fun f -> f "Could not find %a on the local network" Ipaddr.V4.pp_hum dst);
+      Lwt.return @@ Error `No_route
+    | 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_hum 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_hum dst (Fmt.option Ipaddr.V4.pp_hum) t.gateway);
+      (* when a gateway is specified the user likely expects their traffic to be passed to it *)
+      Lwt.return @@ Error `No_route
+    | Ok mac ->
+      let dmac = Macaddr.to_bytes mac in
+      let tlen = Cstruct.len frame + Cstruct.lenv bufs - Ethif_wire.sizeof_ethernet in
+      adjust_output_header ~dmac ~tlen frame;
+      Ethif.writev t.ethif (frame :: bufs) >>= function
+      | Ok () as ok -> Lwt.return ok
+      | Error `Unimplemented ->
+        Lwt.fail (Invalid_argument "Unimplemented code path when trying to write to ethernet device")
+      | Error `Disconnected ->
+        Lwt.fail (Invalid_argument "Tried to write to a disconnected Ethernet interface")
+      | Error (`Msg s) ->
+        Log.warn (fun f -> f "ethif write errored: %s" s);
+        Lwt.return @@ Error (`Msg s) 
 
   let write t frame buf =
     writev t frame [buf]

lib/ipv4/static_ipv4.mli

@@ -16,7 +16,6 @@
 
 module Make (N:V1_LWT.ETHIF) (A: V1_LWT.ARP) : sig
   include V1_LWT.IPV4 with type ethif = N.t
-  exception No_route_to_destination_address of Ipaddr.V4.t
   val connect :
     ?ip:Ipaddr.V4.t ->
     ?network:Ipaddr.V4.Prefix.t ->

lib/ipv6/ipv6.ml

@@ -60,9 +60,18 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
     let ctx, bufs = Ndpv6.send ~now t.ctx dst frame bufs in
     t.ctx <- ctx;
     let fail_any progress buf =
-      let id = function | Ok () -> Ok () | Error e -> Error e in
+      let squeal = function
+      | Ok () as ok -> Lwt.return ok
+      | Error `Unimplemented ->
+        Lwt.fail (Invalid_argument "Unimplemented code path when trying to write to ethernet device")
+      | Error `Disconnected ->
+        Lwt.fail (Invalid_argument "Tried to write to a disconnected Ethernet interface")
+      | Error (`Msg s) ->
+        Log.warn (fun f -> f "ethif write errored: %s" s);
+        Lwt.return @@ Error (`Msg s)
+      in
       match progress with
-      | Ok () -> E.writev t.ethif buf >|= id
+      | Ok () -> E.writev t.ethif buf >>= squeal
       | Error e -> Lwt.return @@ Error e
     in
     (* MCP - it's not totally clear to me that this the right behavior for writev. *)

lib/tcp/pcb.ml

@@ -579,12 +579,17 @@ struct
           Lwt.wakeup wakener (Error `Timeout);
           Lwt.return_unit
         ) else (
-          Tx.send_syn t id ~tx_isn ~options ~window >|= Mirage_pp.reduce >>= function
+          Tx.send_syn t id ~tx_isn ~options ~window >>= function
           | Ok () -> connecttimer t id tx_isn options window (count + 1)
+          | Error `No_route ->
+            (* normal mechanism for recovery is fine *)
+            connecttimer t id tx_isn options window (count + 1)
           | Error (`Msg s) ->
             (* TODO: possibly the more sensible thing to do is give up *)
             Log.warn (fun f -> f "Error sending initial SYN in TCP connection: %s" s);
             connecttimer t id tx_isn options window (count + 1)
+          | Error `Unimplemented -> Lwt.fail (Invalid_argument "Unimplemented code path when sending SYN")
+          | Error `Disconnected -> Lwt.fail (Invalid_argument "Tried to send SYN, but underlying interface was disconnected")
         )
       else Lwt.return_unit
 
@@ -606,13 +611,15 @@ struct
     );
     Hashtbl.add t.connects id (wakener, tx_isn);
     Stats.incr_connect ();
-    Tx.send_syn t id ~tx_isn ~options ~window >|= Mirage_pp.reduce >>= function
-    | Ok () ->
+    Tx.send_syn t id ~tx_isn ~options ~window >>= function
+    | Ok () | Error `No_route (* keep trying *) ->
       Lwt.async (fun () -> connecttimer t id tx_isn options window 0);
       th
     | Error (`Msg s) ->
       Log.warn (fun f -> f "Failure sending initial SYN in outgoing connection: %s" s);
       Lwt.return @@ Error (`Msg s)
+    | Error `Unimplemented -> Lwt.fail (Invalid_argument "Unimplemented code path when sending SYN")
+    | Error `Disconnected -> Lwt.fail (Invalid_argument "Tried to send SYN, but underlying interface was disconnected")
 
   (* Construct the main TCP thread *)
   let create ip clock =

lib/tcp/wire.ml

@@ -13,7 +13,7 @@
  * 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 "Wire" ~doc:"Mirage TCP Wire module"
 module Log = (val Logs.src_log src : Logs.LOG)
@@ -66,6 +66,9 @@ module Make (Ip:V1_LWT.IP) = struct
     | Result.Ok len ->
       let frame = Cstruct.set_len frame (header_len + len) in
       MProf.Counter.increase count_tcp_to_ip (Cstruct.len payload + (if syn then 1 else 0));
-      Ip.write ip frame payload
+      Ip.write ip frame payload >|= function
+      | Error `No_route (* swallow this error so normal recovery mechanisms can be used *)
+      | Ok () -> Ok ()
+      | Error e -> Error e
 
 end

lib/udp/udp.ml

@@ -61,7 +61,14 @@ module Make(Ip: V1_LWT.IP) = struct
     let udp_header = Udp_packet.({ src_port; dst_port; }) in
     let udp_buf = Udp_packet.Marshal.make_cstruct udp_header ~pseudoheader:ph
             ~payload:(Cstruct.concat bufs) in
-    Ip.writev t.ip frame (udp_buf :: bufs) >|= Mirage_pp.reduce
+    Ip.writev t.ip frame (udp_buf :: bufs) >|= function
+    | Ok () as ok -> ok
+    | Error `Disconnected | Error `Unimplemented as e -> Mirage_pp.reduce e
+    | Error (`Msg _) as s -> s
+    | Error `No_route ->
+      let msg = Format.asprintf "failed to send packet to %a: no route" Ipaddr.pp_hum (Ip.to_uipaddr dst) in
+      Log.warn (fun f -> f "%s" msg);
+      Error (`Msg msg)
 
   let write ?src_port ~dst ~dst_port t buf =
     writev ?src_port ~dst ~dst_port t [buf]

lib_test/static_arp.ml

@@ -4,11 +4,10 @@ module Make(E : V1_LWT.ETHIF)(Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = struct
   module A = Arpv4.Make(E)(Clock)(Time)
   (* generally repurpose A, but substitute input and query, and add functions
      for adding/deleting entries *)
-  type error = A.error
+  type error = V1.Arp.error
   type 'a io = 'a Lwt.t
   type buffer = Cstruct.t
   type macaddr = Macaddr.t
-  type result = A.result
   type ipaddr = Ipaddr.V4.t
   type repr = string
 
@@ -40,8 +39,8 @@ module Make(E : V1_LWT.ETHIF)(Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = struct
 
   let query t ip =
     match Hashtbl.mem t.table ip with
-    | false -> Lwt.return `Timeout
-    | true -> Lwt.return (`Ok (Hashtbl.find t.table ip))
+    | false -> Lwt.return @@ Error `Timeout
+    | true -> Lwt.return (Ok (Hashtbl.find t.table ip))
 
   let input t buffer =
     (* disregard responses, but reply to queries *)

lib_test/test_arp.ml

@@ -164,12 +164,12 @@ let three_arp () =
 
 let query_or_die arp ip expected_mac = 
   A.query arp ip >>= function
-  | `Timeout ->
+  | Error `Timeout ->
     let pp_ip = Ipaddr.V4.pp_hum in
     A.to_repr arp >>= fun repr ->
     Logs.warn (fun f -> f "Timeout querying %a. Table contents: %a" pp_ip ip A.pp repr);
     fail "ARP query failed when success was mandatory";
-  | `Ok mac -> 
+  | Ok mac -> 
     Alcotest.(check macaddr) "mismatch for expected query value" expected_mac mac;
     Lwt.return_unit
 
@@ -195,8 +195,8 @@ let not_in_cache ~listen probe arp ip =
     single_check listen probe;
     Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
     A.query arp ip >>= function
-    | `Ok mac -> fail @@ "entry in cache when it shouldn't be " ^ (Macaddr.to_string mac)
-    | `Timeout -> Lwt.return_unit
+    | Ok mac -> fail @@ "entry in cache when it shouldn't be " ^ (Macaddr.to_string mac)
+    | Error `Timeout -> Lwt.return_unit
   ]
 
 let set_ip_sends_garp () =
@@ -303,8 +303,8 @@ let input_resolves_wait () =
 let unreachable_times_out () =
   get_arp () >>= fun speak ->
   A.query speak.arp first_ip >>= function
-  | `Ok mac -> fail @@ "query claimed success when impossible for " ^ (Macaddr.to_string mac)
-  | `Timeout -> Lwt.return_unit
+  | Ok mac -> fail @@ "query claimed success when impossible for " ^ (Macaddr.to_string mac)
+  | Error `Timeout -> Lwt.return_unit
 
 let input_replaces_old () =
   three_arp () >>= fun (listen, claimant_1, claimant_2) ->
@@ -360,8 +360,8 @@ let query_retries () =
   in
   let ask () = 
     A.query speak.arp first_ip >>= function
-    | `Timeout -> fail "Received `Timeout before >1 query";
-    | `Ok mac -> fail(Printf.sprintf"got result from query for %s, erroneously" (Macaddr.to_string mac));
+    | Error `Timeout -> fail "Received error before >1 query";
+    | Ok mac -> fail(Printf.sprintf"got result from query for %s, erroneously" (Macaddr.to_string mac));
   in
   Lwt.pick [
     (V.listen listen.netif listener >|= fun _ -> ());