From 7f97c422c905e4db731a6466ba390c2909aa3d36 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 1 Feb 2017 12:46:05 +0000 Subject: [PATCH 1/2] move to MirageOS3: pretty print errors, fix discard (to react properly on reading Eof) --- .merlin | 1 + examples/config.ml | 22 ++------------------- examples/services.ml | 46 ++++++++++++++++++-------------------------- 3 files changed, 22 insertions(+), 47 deletions(-) diff --git a/.merlin b/.merlin index 5bd7a0ec2..8154d02df 100644 --- a/.merlin +++ b/.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/ diff --git a/examples/config.ml b/examples/config.ml index bff422cac..ac9ab3e3a 100644 --- a/examples/config.ml +++ b/examples/config.ml @@ -2,27 +2,9 @@ open Mirage let main = foreign "Services.Main" (console @-> 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 $ default_console $ stack ] diff --git a/examples/services.ml b/examples/services.ml index 30550c8f3..4223dc6bc 100644 --- a/examples/services.ml +++ b/examples/services.ml @@ -2,8 +2,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; + let report_and_close c flow pp e message = + let msg = + Format.fprintf Format.str_formatter + "closing connection due to error %a while %s" + pp e message; + Format.flush_str_formatter () + in + C.log c msg >>= fun () -> S.TCPV4.close flow let rec chargen c flow how_many start_at = @@ -18,41 +24,27 @@ 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 () -> + | 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." + | Error e -> report_and_close c flow S.TCPV4.pp_write_error e "writing in Chargen" let rec discard c 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 c flow S.TCPV4.pp_error e "reading in Discard" + | Ok `Eof -> report_and_close c flow Fmt.string "end of file" "reading in Discard" + | Ok (`Data _) -> discard c 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 -> + S.TCPV4.read flow >>= function + | Error e -> report_and_close c flow S.TCPV4.pp_error e "reading in Echo" + | Ok `Eof -> report_and_close c 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 c flow + | Error e -> report_and_close c flow S.TCPV4.pp_write_error e "writing in Echo" let start c s = (* RFC 862 - read payloads and repeat them back *) From 01b5e7a4233b4d09fc550fb88bc380f4cbe6c3ef Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 1 Feb 2017 13:01:51 +0000 Subject: [PATCH 2/2] example: use logs, not use console --- examples/config.ml | 4 ++-- examples/services.ml | 52 ++++++++++++++++++++------------------------ 2 files changed, 26 insertions(+), 30 deletions(-) diff --git a/examples/config.ml b/examples/config.ml index ac9ab3e3a..eb84f120d 100644 --- a/examples/config.ml +++ b/examples/config.ml @@ -1,10 +1,10 @@ open Mirage -let main = foreign "Services.Main" (console @-> stackv4 @-> job) +let main = foreign "Services.Main" (stackv4 @-> job) let stack = generic_stackv4 default_network let () = register "services" [ - main $ default_console $ stack + main $ stack ] diff --git a/examples/services.ml b/examples/services.ml index 4223dc6bc..ac8830e60 100644 --- a/examples/services.ml +++ b/examples/services.ml @@ -1,18 +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 pp e message = - let msg = - Format.fprintf Format.str_formatter - "closing connection due to error %a while %s" - pp e message; - Format.flush_str_formatter () - in - C.log c msg >>= fun () -> +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 @@ -25,36 +21,36 @@ module Main (C: Mirage_types_lwt.CONSOLE) (S: Mirage_types_lwt.STACKV4) = struct S.TCPV4.write flow (make_chars how_many start_at) >>= function | Ok () -> - chargen c flow how_many ((start_at + 1) mod (String.length charpool)) - | Error e -> report_and_close c flow S.TCPV4.pp_write_error e "writing in Chargen" + 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 - | Error e -> report_and_close c flow S.TCPV4.pp_error e "reading in Discard" - | Ok `Eof -> report_and_close c flow Fmt.string "end of file" "reading in Discard" - | Ok (`Data _) -> 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 = + let rec echo flow = S.TCPV4.read flow >>= function - | Error e -> report_and_close c flow S.TCPV4.pp_error e "reading in Echo" - | Ok `Eof -> report_and_close c flow Fmt.string "end of file" "reading in Echo" + | 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 - | Error e -> report_and_close c flow S.TCPV4.pp_write_error e "writing in Echo" + | 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