Skip to content

Commit

Permalink
Update the tests to MirageOS 3
Browse files Browse the repository at this point in the history 
Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
  • Loading branch information
@samoht
samoht committed Jul 31, 2017
1 parent 7ae5114 commit 5487366
Show file tree
Hide file tree
Showing 6 changed files with 222 additions and 188 deletions.
75 changes: 41 additions & 34 deletions src/hostnet_test/forwarding.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,25 +13,29 @@ let (>>*=) m f = m >>= function

module Make(Host: Sig.HOST) = struct

let run ?(timeout=60.) t =
let run ?(timeout=Duration.of_sec 60) t =
let timeout =
Host.Time.sleep timeout >>= fun () ->
Host.Time.sleep_ns timeout >>= fun () ->
Lwt.fail_with "timeout"
in
Host.Main.run @@ Lwt.pick [ timeout; t ]

module Channel = Channel.Make(Host.Sockets.Stream.Tcp)
module Channel = Mirage_channel_lwt.Make(Host.Sockets.Stream.Tcp)

module ForwardServer = struct
(** Accept connections, read the forwarding header and run a proxy *)

module Proxy =
Mirage_flow_lwt.Proxy
(Mclock)(Host.Sockets.Stream.Tcp)(Host.Sockets.Stream.Tcp)

let accept flow =
let sizeof = 1 + 2 + 4 + 2 in
let header = Cstruct.create sizeof in
Host.Sockets.Stream.Tcp.read_into flow header >>= function
| `Eof -> failwith "EOF"
| `Error e -> failwith (Host.Sockets.Stream.Tcp.error_message e)
| `Ok () ->
| Ok `Eof -> failwith "EOF"
| Error e -> Fmt.kstrf failwith "%a" Host.Sockets.Stream.Tcp.pp_error e
| Ok (`Data ()) ->
let ip_len = Cstruct.LE.get_uint16 header 1 in
let ip =
let bytes = Cstruct.(to_string @@ sub header 3 ip_len) in
Expand All @@ -44,14 +48,11 @@ module Make(Host: Sig.HOST) = struct
Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 ip, port) >>= function
| Error (`Msg x) -> failwith x
| Ok remote ->
Mclock.connect () >>= fun clock ->
Lwt.finalize (fun () ->
Mirage_flow.proxy
(module Clock)
(module Host.Sockets.Stream.Tcp) flow
(module Host.Sockets.Stream.Tcp) remote ()
>>= function
| `Error (`Msg m) -> failwith m
| `Ok (_l_stats, _r_stats) -> Lwt.return ()
Proxy.proxy clock flow remote >>= function
| Error e -> Fmt.kstrf failwith "%a" Proxy.pp_error e
| Ok (_l_stats, _r_stats) -> Lwt.return ()
) (fun () ->
Host.Sockets.Stream.Tcp.close remote
)
Expand All @@ -69,7 +70,7 @@ module Make(Host: Sig.HOST) = struct
}
end

module Forward = Forward.Make(struct
module Forward = Forward.Make(Mclock)(struct
include Host.Sockets.Stream.Tcp

open Lwt.Infix
Expand All @@ -89,7 +90,8 @@ module Make(Host: Sig.HOST) = struct
module Server = Protocol_9p.Server.Make(Log)(Host.Sockets.Stream.Tcp)(Ports)

let with_server f =
let ports = Ports.make () in
Mclock.connect () >>= fun clock ->
let ports = Ports.make clock in
Ports.set_context ports "";
Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 localhost, 0)
>>= fun server ->
Expand Down Expand Up @@ -120,11 +122,14 @@ module Make(Host: Sig.HOST) = struct

let read_http ch =
let rec loop acc =
Channel.read_line ch >>= fun bufs ->
let txt = Cstruct.(to_string (concat bufs)) in
if txt = ""
then Lwt.return acc
else loop (acc ^ txt)
Channel.read_line ch >>= function
| Ok `Eof
| Error _ -> Lwt.return acc
| Ok (`Data bufs) ->
let txt = Cstruct.(to_string (concat bufs)) in
if txt = ""
then Lwt.return acc
else loop (acc ^ txt)
in
loop ""

Expand All @@ -141,7 +146,9 @@ module Make(Host: Sig.HOST) = struct
then failwith (Printf.sprintf "unrecognised HTTP GET: [%s]" request);
let response = "HTTP/1.0 404 Not found\r\ncontent-length: 0\r\n\r\n" in
Channel.write_string ch response 0 (String.length response);
Channel.flush ch
Channel.flush ch >|= function
| Ok () -> ()
| Error e -> Fmt.kstrf failwith "%a" Channel.pp_write_error e

let create () =
Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 localhost, 0)
Expand Down Expand Up @@ -181,13 +188,13 @@ module Make(Host: Sig.HOST) = struct

type forward = {
t: t;
fid: Protocol_9p_types.Fid.t;
fid: Protocol_9p.Types.Fid.t;
ip: Ipaddr.V4.t;
port: int;
}

let create t string =
let mode = Protocol_9p_types.FileMode.make ~is_directory:true
let mode = Protocol_9p.Types.FileMode.make ~is_directory:true
~owner:[`Read; `Write; `Execute] ~group:[`Read; `Execute]
~other:[`Read; `Execute ] () in
Client.mkdir t.ninep [] string mode
Expand All @@ -196,15 +203,15 @@ module Make(Host: Sig.HOST) = struct
>>*= fun fid ->
Client.walk_from_root t.ninep fid [ string; "ctl" ]
>>*= fun _walk ->
Client.LowLevel.openfid t.ninep fid Protocol_9p_types.OpenMode.read_write
Client.LowLevel.openfid t.ninep fid Protocol_9p.Types.OpenMode.read_write
>>*= fun _open ->
let buf = Cstruct.create (String.length string) in
Cstruct.blit_from_string string 0 buf 0 (String.length string);
Client.LowLevel.write t.ninep fid 0L buf
>>*= fun _write ->
Client.LowLevel.read t.ninep fid 0L 1024l
>>*= fun read ->
let response = Cstruct.to_string read.Protocol_9p_response.Read.data in
let response = Cstruct.to_string read.Protocol_9p.Response.Read.data in
if Astring.String.is_prefix ~affix:"OK " response then begin
let line = String.sub response 3 (String.length response - 3) in
(* tcp:127.0.0.1:64500:tcp:127.0.0.1:64499 *)
Expand All @@ -229,15 +236,15 @@ module Make(Host: Sig.HOST) = struct
let ch = Channel.create flow in
let message = "GET / HTTP/1.0\r\nconnection: close\r\n\r\n" in
Channel.write_string ch message 0 (String.length message);
Channel.flush ch
>>= fun () ->
Host.Sockets.Stream.Tcp.shutdown_write flow
>>= fun () ->
read_http ch
>>= fun response ->
if not(Astring.String.is_prefix ~affix:"HTTP" response)
then failwith (Printf.sprintf "unrecognised HTTP response: [%s]" response);
Lwt.return ()
Channel.flush ch >>= function
| Error e -> Fmt.kstrf failwith "%a" Channel.pp_write_error e
| Ok () ->
Host.Sockets.Stream.Tcp.shutdown_write flow
>>= fun () ->
read_http ch
>|= fun response ->
if not(Astring.String.is_prefix ~affix:"HTTP" response)
then failwith (Printf.sprintf "unrecognised HTTP response: [%s]" response)

let test_one_forward () =
let t = LocalServer.with_server (fun server ->
Expand Down
4 changes: 2 additions & 2 deletions src/hostnet_test/jbuild
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@
(executables
((names (main_lwt main_uwt))
(libraries (
hostnet cmdliner alcotest lwt.unix logs.fmt
dns.mirage lwt.preemptive uwt.preemptive
hostnet cmdliner alcotest lwt.unix logs.fmt protocol-9p
mirage-dns lwt.preemptive uwt.preemptive mirage-clock-unix
))
(preprocess no_preprocessing)))
50 changes: 22 additions & 28 deletions src/hostnet_test/slirp_stack.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -66,48 +66,38 @@ module Make(Host: Sig.HOST) = struct
module VMNET = Vmnet.Make(Host.Sockets.Stream.Tcp)
module Config = Active_config.Make(Host.Time)(Host.Sockets.Stream.Unix)
module Vnet = Basic_backend.Make
module Slirp_stack = Slirp.Make(Config)(VMNET)(Dns_policy)(Host)(Vnet)
module Slirp_stack =
Slirp.Make(Config)(VMNET)(Dns_policy)(Mclock)(Stdlibrandom)(Host)(Vnet)

module Client = struct
module Netif = VMNET
module Ethif1 = Ethif.Make(Netif)
module Arpv41 = Arpv4.Make(Ethif1)(Clock)(Host.Time)
module Ipv41 = Ipv4.Make(Ethif1)(Arpv41)
module Arpv41 = Arpv4.Make(Ethif1)(Mclock)(Host.Time)
module Ipv41 = Static_ipv4.Make(Ethif1)(Arpv41)
module Icmpv41 = Icmpv4.Make(Ipv41)
module Udp1 = Udp.Make(Ipv41)
module Tcp1 = Tcp.Flow.Make(Ipv41)(Host.Time)(Clock)(Random)
include Tcpip_stack_direct.Make(Console_unix)(Host.Time)
(Random)(Netif)(Ethif1)(Arpv41)(Ipv41)(Icmpv41)(Udp1)(Tcp1)
module Udp1 = Udp.Make(Ipv41)(Stdlibrandom)
module Tcp1 = Tcp.Flow.Make(Ipv41)(Host.Time)(Mclock)(Stdlibrandom)
include Tcpip_stack_direct.Make(Host.Time)
(Stdlibrandom)(Netif)(Ethif1)(Arpv41)(Ipv41)(Icmpv41)(Udp1)(Tcp1)

let or_error name m =
let open Lwt.Infix in
m >>= function
| `Error _ -> Fmt.kstrf failwith "Failed to connect %s device" name
| `Ok x -> Lwt.return x

let connect (interface: VMNET.t) =
let open Lwt.Infix in
or_error "console" @@ Console_unix.connect "0"
>>= fun console ->
or_error "ethernet" @@ Ethif1.connect interface
>>= fun ethif ->
or_error "arp" @@ Arpv41.connect ethif
>>= fun arp ->
or_error "ipv4" @@ Ipv41.connect ethif arp
>>= fun ipv4 ->
or_error "icmpv4" @@ Icmpv41.connect ipv4
>>= fun icmpv4 ->
or_error "udp" @@ Udp1.connect ipv4
>>= fun udp4 ->
or_error "tcp" @@ Tcp1.connect ipv4
>>= fun tcp4 ->
Ethif1.connect interface >>= fun ethif ->
Mclock.connect () >>= fun clock ->
Arpv41.connect ethif clock >>= fun arp ->
Ipv41.connect ethif arp >>= fun ipv4 ->
Icmpv41.connect ipv4 >>= fun icmpv4 ->
Udp1.connect ipv4 >>= fun udp4 ->
Tcp1.connect ipv4 clock >>= fun tcp4 ->
let cfg = {
V1_LWT. name = "stackv4_ip";
console;
Mirage_stack_lwt.name = "stackv4_ip";
interface;
mode = `DHCP;
} in
or_error "stack" @@ connect cfg ethif arp ipv4 icmpv4 udp4 tcp4
connect cfg ethif arp ipv4 icmpv4 udp4 tcp4
>>= fun stack ->
Lwt.return stack
end
Expand Down Expand Up @@ -137,6 +127,7 @@ module Make(Host: Sig.HOST) = struct
}

let config_without_bridge =
Mclock.connect () >|= fun clock ->
{
Slirp.peer_ip;
local_ip;
Expand All @@ -150,6 +141,7 @@ module Make(Host: Sig.HOST) = struct
global_arp_table;
mtu = 1500;
host_names = [];
clock;
}

(* This is a hacky way to get a hancle to the server side of the stack. *)
Expand Down Expand Up @@ -178,7 +170,9 @@ module Make(Host: Sig.HOST) = struct
);
port

let connection = start_stack (Vnet.create ()) config_without_bridge ()
let connection =
config_without_bridge >>= fun config ->
start_stack (Vnet.create ()) config ()

let with_stack f =
connection >>= fun port ->
Expand Down
Loading

0 comments on commit 5487366

Please sign in to comment.