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..eb84f120d 100644 --- a/examples/config.ml +++ b/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 ] diff --git a/examples/services.ml b/examples/services.ml index 30550c8f3..ac8830e60 100644 --- a/examples/services.ml +++ b/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