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