Merge pull request mirage#267 from yomimono/higherlevel-error

let's push write errors upward.

_oasis

@@ -76,7 +76,7 @@ Library icmpv4
   Findlibname:        icmpv4
   Modules:            Icmpv4, Icmpv4_packet, Icmpv4_wire
   BuildDepends:       logs,mirage-types,cstruct,cstruct.ppx,lwt,ipaddr,result,rresult,mirage-profile,
-                      tcpip
+                      tcpip,mirage-runtime
 
 Library udp
   CompiledObject:     best
@@ -85,7 +85,7 @@ Library udp
   Findlibname:        udp
   Modules:            Udp, Udp_wire, Udp_packet
   BuildDepends:       logs,mirage-types,ipaddr,cstruct,cstruct.ppx,lwt,result,rresult,mirage-profile,
-                      tcpip
+                      tcpip,mirage-runtime
 
 Library tcp
   CompiledObject:     best
@@ -99,7 +99,7 @@ Library tcp
                       Tcp_wire, Tcp_packet
   BuildDepends:       logs,mirage-types,ipaddr,cstruct,cstruct.ppx,lwt,result,rresult,mirage-profile,
                       io-page,
-                      tcpip, duration, randomconv
+                      tcpip, duration, randomconv, mirage-runtime
 
 Library "tcpip-stack-direct"
   CompiledObject:     best
@@ -120,7 +120,8 @@ Library "icmpv4-socket"
                       ipaddr.unix,
                       cstruct.lwt,
                       io-page.unix,
-                      tcpip.icmpv4
+                      tcpip.icmpv4,
+                      mirage-runtime
 
 Library "udpv4-socket"
   CompiledObject:     best
@@ -176,7 +177,7 @@ Executable test
                       tcpip.ethif,tcpip.arpv4,tcpip.ipv4,tcpip.tcp,tcpip.udp,
                       tcpip.stack-direct,tcpip.icmpv4,
                       tcpip.udpv4-socket, tcpip.tcpv4-socket, tcpip.stack-socket, duration,
-                      mirage-stdlib-random, result
+                      mirage-stdlib-random, result, rresult
 
 Test test
   Run$:               flag(tests)

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 7379f2148e599f2ba68b634c9cc4f868)
+# DO NOT EDIT (digest: 983c963bd13f755bb0fcadf13b37f43f)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -92,6 +92,7 @@ true: annot, bin_annot
 <lib/icmp/*.ml{,i,y}>: pkg_logs
 <lib/icmp/*.ml{,i,y}>: pkg_lwt
 <lib/icmp/*.ml{,i,y}>: pkg_mirage-profile
+<lib/icmp/*.ml{,i,y}>: pkg_mirage-runtime
 <lib/icmp/*.ml{,i,y}>: pkg_mirage-types
 <lib/icmp/*.ml{,i,y}>: pkg_result
 <lib/icmp/*.ml{,i,y}>: pkg_rresult
@@ -104,6 +105,7 @@ true: annot, bin_annot
 <lib/udp/*.ml{,i,y}>: pkg_logs
 <lib/udp/*.ml{,i,y}>: pkg_lwt
 <lib/udp/*.ml{,i,y}>: pkg_mirage-profile
+<lib/udp/*.ml{,i,y}>: pkg_mirage-runtime
 <lib/udp/*.ml{,i,y}>: pkg_mirage-types
 <lib/udp/*.ml{,i,y}>: pkg_result
 <lib/udp/*.ml{,i,y}>: pkg_rresult
@@ -132,6 +134,7 @@ true: annot, bin_annot
 <lib/tcp/*.ml{,i,y}>: pkg_logs
 <lib/tcp/*.ml{,i,y}>: pkg_lwt
 <lib/tcp/*.ml{,i,y}>: pkg_mirage-profile
+<lib/tcp/*.ml{,i,y}>: pkg_mirage-runtime
 <lib/tcp/*.ml{,i,y}>: pkg_mirage-types
 <lib/tcp/*.ml{,i,y}>: pkg_randomconv
 <lib/tcp/*.ml{,i,y}>: pkg_result
@@ -152,6 +155,7 @@ true: annot, bin_annot
 <unix/*.ml{,i,y}>: pkg_cstruct.ppx
 <unix/*.ml{,i,y}>: pkg_ipaddr
 <unix/*.ml{,i,y}>: pkg_mirage-profile
+<unix/*.ml{,i,y}>: pkg_mirage-runtime
 <unix/*.ml{,i,y}>: pkg_result
 <unix/*.ml{,i,y}>: pkg_rresult
 <unix/*.ml{,i,y}>: use_icmpv4

lib/META

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 905c9921359732eaded4a9e161fc3588)
+# DO NOT EDIT (digest: afbbfd8369d6e314cda886bee0185257)
 version = "2.8.0"
 description =
 "Implementations for network-related module types from MirageOS."
@@ -50,7 +50,7 @@ package "udp" (
  description =
  "Implementations for network-related module types from MirageOS."
  requires =
- "logs mirage-types ipaddr cstruct cstruct.ppx lwt result rresult mirage-profile tcpip"
+ "logs mirage-types ipaddr cstruct cstruct.ppx lwt result rresult mirage-profile tcpip mirage-runtime"
  archive(byte) = "udp.cma"
  archive(byte, plugin) = "udp.cma"
  archive(native) = "udp.cmxa"
@@ -88,7 +88,7 @@ package "tcp" (
  description =
  "Implementations for network-related module types from MirageOS."
  requires =
- "logs mirage-types ipaddr cstruct cstruct.ppx lwt result rresult mirage-profile io-page tcpip duration randomconv"
+ "logs mirage-types ipaddr cstruct cstruct.ppx lwt result rresult mirage-profile io-page tcpip duration randomconv mirage-runtime"
  archive(byte) = "tcp.cma"
  archive(byte, plugin) = "tcp.cma"
  archive(native) = "tcp.cmxa"
@@ -150,7 +150,8 @@ package "icmpv4-socket" (
  version = "2.8.0"
  description =
  "Implementations for network-related module types from MirageOS."
- requires = "lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix tcpip.icmpv4"
+ requires =
+ "lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix tcpip.icmpv4 mirage-runtime"
  archive(byte) = "icmpv4-socket.cma"
  archive(byte, plugin) = "icmpv4-socket.cma"
  archive(native) = "icmpv4-socket.cmxa"
@@ -163,7 +164,7 @@ package "icmpv4" (
  description =
  "Implementations for network-related module types from MirageOS."
  requires =
- "logs mirage-types cstruct cstruct.ppx lwt ipaddr result rresult mirage-profile tcpip"
+ "logs mirage-types cstruct cstruct.ppx lwt ipaddr result rresult mirage-profile tcpip mirage-runtime"
  archive(byte) = "icmpv4.cma"
  archive(byte, plugin) = "icmpv4.cma"
  archive(native) = "icmpv4.cmxa"

lib/arpv4/arpv4.ml

@@ -43,6 +43,9 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
   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)
+
   let arp_timeout = Duration.of_sec 60 (* age entries out of cache after this many seconds *)
   let probe_repeat_delay = Duration.of_ms 1500 (* per rfc5227, 2s >= probe_repeat_delay >= 1s *)
   let probe_num = 3 (* how many probes to send before giving up *)
@@ -72,7 +75,7 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
       let key = Ipaddr.V4.to_string ip in
       match entry with
        | Pending _ -> acc ^ "\n" ^ key ^ " -> " ^ "Pending"
-       | Confirmed (time, mac) -> Printf.sprintf "%s\n%s -> Confirmed (%s) (expires %Lu)\n%!" 
+       | Confirmed (time, mac) -> Printf.sprintf "%s\n%s -> Confirmed (%s) (expires %Lu)\n%!"
                                     acc key (Macaddr.to_string mac) time
     in
     Lwt.return (Hashtbl.fold print t.cache "")
@@ -105,7 +108,8 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = st
         destination;
         ethertype = Ethif_wire.ARP;
       }) in
-    Ethif.writev t.ethif [ethif_packet ; payload]
+    Ethif.writev t.ethif [ethif_packet ; payload] >>= fun e ->
+      Lwt.return @@ Rresult.R.ignore_error ~use:(report_ethif_error "write") e
 
   (* Input handler for an ARP packet *)
   let input t frame =

lib/ethif/ethif.ml

@@ -28,11 +28,7 @@ module Make(Netif : V1_LWT.NETWORK) = struct
   type macaddr = Macaddr.t
   type netif = Netif.t
 
-  type error = [
-    | `Unknown of string
-    | `Unimplemented
-    | `Disconnected
-  ]
+  type error = V1.Network.error
 
   type t = {
     netif: Netif.t;
@@ -56,26 +52,25 @@ module Make(Netif : V1_LWT.NETWORK) = struct
         | IPv6 -> ipv6 payload
       end
     | Ok _ -> Lwt.return_unit
-    | Error s -> Log.debug (fun f -> f "Dropping Ethernet frame: %s" s);
+    | Error s ->
+      Log.debug (fun f -> f "Dropping Ethernet frame: %s" s);
       Lwt.return_unit
 
-  (* XXX the error handling should be removed, and passed to the layer above *)
   let write t frame =
     MProf.Trace.label "ethif.write";
     Netif.write t.netif frame >|= function
-    | Ok () -> ()
+    | Ok () -> Ok ()
     | Error e ->
       Log.warn (fun f -> f "netif write errored %a" Mirage_pp.pp_network_error e) ;
-      ()
+      Error e
 
-  (* XXX the error handling should be removed, and passed to the layer above *)
   let writev t bufs =
     MProf.Trace.label "ethif.writev";
     Netif.writev t.netif bufs >|= function
-    | Ok () -> ()
+    | Ok () -> Ok ()
     | Error e ->
       Log.warn (fun f -> f "netif writev errored %a" Mirage_pp.pp_network_error e) ;
-      ()
+      Error e
 
   let connect netif =
     MProf.Trace.label "ethif.connect";

lib/ethif/ethif_packet.ml

@@ -6,6 +6,8 @@ type t = {
   ethertype : Ethif_wire.ethertype;
 }
 
+type error = string
+
 let pp fmt t =
   Format.fprintf fmt "%s -> %s: %s" (Macaddr.to_string t.source)
     (Macaddr.to_string t.destination) (Ethif_wire.ethertype_to_string t.ethertype)
@@ -14,8 +16,6 @@ let equal p q = (p = q)
 
 module Unmarshal = struct
 
-  type error = string
-
   let of_cstruct frame =
     if Cstruct.len frame >= sizeof_ethernet then
       match get_ethernet_ethertype frame |> int_to_ethertype with
@@ -34,8 +34,6 @@ end
 module Marshal = struct
   open Rresult
 
-  type error = string
-
   let check_len buf =
     if sizeof_ethernet > Cstruct.len buf then
       Result.Error "Not enough space for an Ethernet header"

lib/ethif/ethif_packet.mli

@@ -4,17 +4,15 @@ type t = {
   ethertype : Ethif_wire.ethertype;
 }
 
+type error = string
+
 val pp : Format.formatter -> t -> unit
 val equal : t -> t -> bool
 
 module Unmarshal : sig
-  type error = string
-
   val of_cstruct : Cstruct.t -> ((t * Cstruct.t), error) Result.result
 end
 module Marshal : sig
-  type error = string
-
   (** [into_cstruct t buf] writes a 14-byte ethernet header representing
       [t.ethertype], [t.src_mac], and [t.dst_mac] to [buf] at offset 0.
       Return Result.Ok () on success and Result.Error error on failure.

lib/icmp/icmpv4.ml

@@ -1,3 +1,5 @@
+open Lwt.Infix
+
 let src = Logs.Src.create "icmpv4" ~doc:"Mirage ICMPv4"
 module Log = (val Logs.src_log src : Logs.LOG)
 
@@ -11,22 +13,18 @@ module Make(IP : V1_LWT.IPV4) = struct
     echo_reply : bool;
   }
 
-  type error = [ `Routing | `Unknown ]
+  type error = V1.Icmp.error
 
   let connect ip =
     let t = { ip; echo_reply = true } in
     Lwt.return t
 
   let disconnect _ = Lwt.return_unit
 
-  let pp_error formatter = function
-    | `Routing -> Format.fprintf formatter "%s" "routing"
-    | `Unknown -> Format.fprintf formatter "%s" "unknown!"
-
-  let writev t ~dst bufs = 
+  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
+    IP.writev t.ip frame bufs >|= Mirage_pp.reduce
 
   let write t ~dst buf = writev t ~dst [buf]
 
@@ -60,7 +58,12 @@ module Make(IP : V1_LWT.IPV4) = struct
 		       ty   = Icmpv4_wire.Echo_reply;
 		       subheader = Id_and_seq (id, seq);
 		     } in
-          writev t ~dst:src [ Marshal.make_cstruct icmp ~payload; payload ]
+          writev t ~dst:src [ Marshal.make_cstruct icmp ~payload; payload ] >|= function
+            (* this handler will change when input gets a richer type that can return error *)
+            | Ok () -> ()
+            | Error e ->
+              Log.warn (fun f -> f "Unable to send ICMP echo-reply: %a" Mirage_pp.pp_icmp_error e);
+              ()
         end else Lwt.return_unit
       | ty, _ ->
         Log.info (fun f -> f "ICMP unknown ty %s from %a" (ty_to_string ty) Ipaddr.V4.pp_hum src);

lib/ipv4/static_ipv4.ml

@@ -24,10 +24,7 @@ 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 = [
-    | `Unknown of string (** an undiagnosed error *)
-    | `Unimplemented     (** operation not yet implemented in the code *)
-  ]
+  type error = V1.Ip.error
 
   type ethif = Ethif.t
   type 'a io = 'a Lwt.t
@@ -57,7 +54,11 @@ module Make(Ethif: V1_LWT.ETHIF) (Arpv4 : V1_LWT.ARP) = struct
             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)
+    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
 
   let write t frame buf =
     writev t frame [buf]

lib/ipv6/ipv6.ml

@@ -43,7 +43,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
       let now = C.elapsed_ns t.clock in
       let ctx, bufs = Ndpv6.tick ~now t.ctx in
       t.ctx <- ctx;
-      Lwt_list.iter_s (E.writev t.ethif) bufs >>= fun () ->
+      Lwt_list.iter_s (fun buf -> E.writev t.ethif buf >>= fun _ -> Lwt.return_unit) bufs (* MCP: replace with propagation *) >>= fun () ->
       T.sleep_ns (Duration.of_sec 1) >>= loop
     in
     loop ()
@@ -59,7 +59,14 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
     in
     let ctx, bufs = Ndpv6.send ~now t.ctx dst frame bufs in
     t.ctx <- ctx;
-    Lwt_list.iter_s (E.writev t.ethif) bufs
+    let fail_any progress buf =
+      let id = function | Ok () -> Ok () | Error e -> Error e in
+      match progress with
+      | Ok () -> E.writev t.ethif buf >|= id
+      | Error e -> Lwt.return @@ Error e
+    in
+    (* MCP - it's not totally clear to me that this the right behavior for writev. *)
+    Lwt_list.fold_left_s fail_any (Ok ()) bufs
 
   let write t frame buf =
     writev t frame [buf]
@@ -72,7 +79,8 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
         | `Udp (src, dst, buf) -> udp ~src ~dst buf
         | `Default (proto, src, dst, buf) -> default ~proto ~src ~dst buf
       ) actions >>= fun () ->
-    Lwt_list.iter_s (E.writev t.ethif) bufs
+    (* MCP: replace below w/proper error propagation *)
+    Lwt_list.iter_s (fun buf -> E.writev t.ethif buf >>= fun _ -> Lwt.return_unit) bufs
 
   let disconnect _ = (* TODO *)
     Lwt.return_unit
@@ -85,7 +93,8 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
     let now = C.elapsed_ns t.clock in
     let ctx, bufs = Ndpv6.add_ip ~now t.ctx ip in
     t.ctx <- ctx;
-    Lwt_list.iter_s (E.writev t.ethif) bufs
+    (* MCP: replace the below *)
+    Lwt_list.iter_s (fun buf -> E.writev t.ethif buf >>= fun _ -> Lwt.return_unit) bufs
 
   let get_ip t =
     Ndpv6.get_ip t.ctx
@@ -133,7 +142,8 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
     let now = C.elapsed_ns clock in
     let ctx, bufs = Ndpv6.local ~now (E.mac ethif) in
     let t = {ctx; clock; ethif} in
-    Lwt_list.iter_s (E.writev t.ethif) bufs >>= fun () ->
+    (* MCP: replace this error swallowing with proper propagation *)
+    Lwt_list.iter_s (fun buf -> E.writev t.ethif buf >>= fun _ -> Lwt.return_unit) bufs >>= fun () ->
     (ip, set_ip t) >>=? fun () ->
     (netmask, Lwt_list.iter_s (set_ip_netmask t)) >>=? fun () ->
     (gateways, set_ip_gateways t) >>=? fun () ->