Merge pull request #291 from hannesm/fix-example

move to MirageOS3: pretty print errors, fix discard (to react properl…

.merlin

@@ -4,6 +4,7 @@ PKG mirage-vnetif pcap-format mirage-console-unix logs mirage-net-lwt
 PKG duration mirage-runtime rresult randomconv mirage-clock-unix
 PKG mirage-protocols mirage-protocols-lwt mirage-device
 PKG mirage-stack mirage-stack-lwt
+PKG mirage-types-lwt mirage
 
 B _build/**
 S lib/

examples/config.ml

@@ -1,28 +1,10 @@
 open Mirage
 
-let main = foreign "Services.Main" (console @-> stackv4 @-> job)
+let main = foreign "Services.Main" (stackv4 @-> job)
 
-let net =
-  try match Sys.getenv "NET" with
-    | "direct" -> `Direct
-    | "socket" -> `Socket
-    | _        -> `Direct
-  with Not_found -> `Direct
-
-let dhcp =
-  try match Sys.getenv "ADDR" with
-    | "dhcp"   -> `Dhcp
-    | "static" -> `Static
-    | _ -> `Dhcp
-  with Not_found -> `Dhcp
-
-let stack console =
-  match net, dhcp with
-  | `Direct, `Dhcp   -> direct_stackv4_with_dhcp console tap0
-  | `Direct, `Static -> direct_stackv4_with_default_ipv4 console tap0
-  | `Socket, _       -> socket_stackv4 console [Ipaddr.V4.any]
+let stack = generic_stackv4 default_network
 
 let () =
   register "services" [
-    main $ default_console $ stack default_console
+    main $ stack
   ]

examples/services.ml

@@ -1,12 +1,14 @@
-open Lwt
-open Mirage_types_lwt
-
-module Main (C: Mirage_types_lwt.CONSOLE) (S: Mirage_types_lwt.STACKV4) = struct
-  let report_and_close c flow message =
-    C.log c message;
+open Lwt.Infix
+
+module Main (S: Mirage_types_lwt.STACKV4) = struct
+  let report_and_close flow pp e message =
+    let ip, port = S.TCPV4.dst flow in
+    Logs.warn
+      (fun m -> m "closing connection from %a:%d due to error %a while %s"
+          Ipaddr.V4.pp_hum ip port pp e message);
     S.TCPV4.close flow
 
-  let rec chargen c flow how_many start_at =
+  let rec chargen flow how_many start_at =
     let charpool =
       "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ "
     in
@@ -18,51 +20,37 @@ module Main (C: Mirage_types_lwt.CONSOLE) (S: Mirage_types_lwt.STACKV4) = struct
     in
 
     S.TCPV4.write flow (make_chars how_many start_at) >>= function
-    | `Ok () ->
-      chargen c flow how_many ((start_at + 1) mod (String.length charpool))
-    | `Eof ->
-      report_and_close c flow "Chargen connection closing normally."
-    | `Error _ ->
-      report_and_close c flow "Chargen connection read error; closing."
+    | Ok () ->
+      chargen flow how_many ((start_at + 1) mod (String.length charpool))
+    | Error e -> report_and_close flow S.TCPV4.pp_write_error e "writing in Chargen"
 
-  let rec discard c flow =
+  let rec discard flow =
     S.TCPV4.read flow >>= fun result -> (
     match result with
-    | `Eof -> report_and_close c flow "Discard connection closing normally."
-    | `Error _ -> report_and_close c flow "Discard connection read error;
-      closing."
-    | _ -> discard c flow
+    | Error e -> report_and_close flow S.TCPV4.pp_error e "reading in Discard"
+    | Ok `Eof -> report_and_close flow Fmt.string "end of file" "reading in Discard"
+    | Ok (`Data _) -> discard flow
   )
 
 
-  let rec echo c flow =
-    S.TCPV4.read flow >>= fun result -> (
-    match result with
-    | `Eof -> report_and_close c flow "Echo connection closure initiated."
-    | `Error e ->
-      let message =
-        match e with
-        | `Timeout -> "Echo connection timed out; closing.\n"
-        | `Refused -> "Echo connection refused; closing.\n"
-        | `Unknown s -> (Printf.sprintf "Echo connection error: %s\n" s)
-      in
-      report_and_close c flow message
-    | `Ok buf ->
+  let rec echo flow =
+    S.TCPV4.read flow >>= function
+    | Error e -> report_and_close flow S.TCPV4.pp_error e "reading in Echo"
+    | Ok `Eof -> report_and_close flow Fmt.string "end of file" "reading in Echo"
+    | Ok (`Data buf) ->
       S.TCPV4.write flow buf >>= function
-      | `Ok () -> echo c flow
-      | `Eof -> report_and_close c flow "Echo connection closure initated."
-      | `Error _ -> report_and_close c flow "Echo connection error during writing; closing."
-  )
+      | Ok () -> echo flow
+      | Error e -> report_and_close flow S.TCPV4.pp_write_error e "writing in Echo"
 
-  let start c s =
+  let start s =
     (* RFC 862 - read payloads and repeat them back *)
-    S.listen_tcpv4 s ~port:7 (echo c);
+    S.listen_tcpv4 s ~port:7 echo;
 
     (* RFC 863 - discard all incoming data and never write a payload *)
-    S.listen_tcpv4 s ~port:9 (discard c);
+    S.listen_tcpv4 s ~port:9 discard;
 
     (* RFC 864 - write data without regard for input *)
-    S.listen_tcpv4 s ~port:19 (fun flow -> chargen c flow 75 0);
+    S.listen_tcpv4 s ~port:19 (fun flow -> chargen flow 75 0);
 
     S.listen s