Skip to content
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
52 changes: 34 additions & 18 deletions lib/conduit_mirage.ml
Original file line number Diff line number Diff line change
Expand Up @@ -38,18 +38,20 @@ module type VCHAN_FLOW = V1_LWT.FLOW
with type error := unknown

(** All the possible connection types supported *)
module Make_flow(S:V1_LWT.TCPV4)(V:VCHAN_FLOW) = struct
module Make_flow(S4:V2_LWT.TCP)(S6:V2_LWT.TCP)(V:VCHAN_FLOW) = struct

type 'a io = 'a Lwt.t
type error = [ `Refused | `Timeout | `Unknown of string ]

type buffer = Cstruct.t

type flow =
| TCPv4 of S.flow
| TCPv4 of S4.flow
| TCPv6 of S6.flow
| Vchan of V.flow

let of_tcpv4 f = TCPv4 f
let of_tcpv6 f = TCPv6 f
let of_vchan f = Vchan f

let vchan_error t =
Expand All @@ -69,22 +71,26 @@ module Make_flow(S:V1_LWT.TCPV4)(V:VCHAN_FLOW) = struct
let read flow =
match flow with
| Vchan t -> vchan_error (V.read t)
| TCPv4 t -> stack_error (S.read t)
| TCPv4 t -> stack_error (S4.read t)
| TCPv6 t -> stack_error (S6.read t)

let write flow buf =
match flow with
| Vchan t -> vchan_error (V.write t buf)
| TCPv4 t -> stack_error (S.write t buf)
| TCPv4 t -> stack_error (S4.write t buf)
| TCPv6 t -> stack_error (S6.write t buf)

let writev flow bufv =
match flow with
| Vchan t -> vchan_error (V.writev t bufv)
| TCPv4 t -> stack_error (S.writev t bufv)
| TCPv4 t -> stack_error (S4.writev t bufv)
| TCPv6 t -> stack_error (S6.writev t bufv)

let close flow =
match flow with
| Vchan t -> V.close t
| TCPv4 t -> S.close t
| TCPv4 t -> S4.close t
| TCPv6 t -> S6.close t
end

module type ENDPOINT = sig
Expand Down Expand Up @@ -134,16 +140,16 @@ module type VCHAN_PEER = PEER
with type uuid = string
and type port = vchan_port

module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct
module Make(S:V1_LWT.NETSTACK)(V:VCHAN_PEER) = struct

module Flow = Make_flow(S.TCPV4)(V.Endpoint)
module Flow = Make_flow(S.TCPV4)(S.TCPV6)(V.Endpoint)
type +'a io = 'a Lwt.t
type ic = Flow.flow
type oc = Flow.flow
type flow = Flow.flow
type stack = S.t
type peer = V.t

type ctx = {
peer: V.t option;
stack: S.t option;
Expand All @@ -154,14 +160,14 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct
| `TCP (_ip, _port) as mode -> return mode
| `Vchan_direct (domid, port) ->
begin
match Vchan.Port.of_string port with
match Vchan.Port.of_string port with
| `Error s -> fail (Failure ("Invalid vchan port: " ^ s))
| `Ok p -> return p
end >>= fun port ->
return (`Vchan_direct (domid, port))
| `Vchan_domain_socket (uuid, port) ->
begin
match Vchan.Port.of_string port with
match Vchan.Port.of_string port with
| `Error s -> fail (Failure ("Invalid vchan port: " ^ s))
| `Ok p -> return p
end >>= fun port ->
Expand All @@ -175,14 +181,14 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct
| `TCP (_ip, port) -> return (`TCP (`Port port))
| `Vchan_direct (domid, port) ->
begin
match Vchan.Port.of_string port with
match Vchan.Port.of_string port with
| `Error s -> fail (Failure ("Invalid vchan port: " ^ s))
| `Ok p -> return p
end >>= fun port ->
return (`Vchan_direct ((`Remote_domid domid), port))
| `Vchan_domain_socket (uuid, port) ->
begin
match Vchan.Port.of_string port with
match Vchan.Port.of_string port with
| `Error s -> fail (Failure ("Invalid vchan port: " ^ s))
| `Ok p -> return p
end >>= fun port ->
Expand All @@ -208,17 +214,22 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct
endp_to_client ~ctx endp
>>= fun client ->
connect ~ctx client
end
end
| `Vchan_direct (domid, port), _ ->
Printf.printf "Conduit.connect: Vchan %d %s\n%!" domid (Vchan.Port.to_string port);
V.Endpoint.client ~domid ~port ()
>>= fun flow ->
Printf.printf "Conduit.connect: connected!\n%!";
let flow = Flow.of_vchan flow in
return (flow, flow, flow)
| `TCP (Ipaddr.V6 _ip, _port), _ ->
fail (Failure "No IPv6 support compiled into Conduit")
| `TCP (Ipaddr.V4 _ip, _port), None ->
| `TCP (Ipaddr.V6 ip, port), Some tcp ->
S.TCPV6.create_connection (S.tcpv6 tcp) (ip,port) >>= begin function
| `Error _err -> fail (Failure "connection failed")
| `Ok flow ->
let flow = Flow.of_tcpv6 flow in
return (flow, flow, flow)
end
| `TCP _, None ->
fail (Failure "No stack bound to Conduit")
| `TCP (Ipaddr.V4 ip, port), Some tcp ->
S.TCPV4.create_connection (S.tcpv4 tcp) (ip,port) >>= function
Expand Down Expand Up @@ -249,7 +260,7 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct
fn f f f
| _ -> fail (Failure "TODO")
) conns
end
end
|`TCP (`Port _port), None ->
fail (Failure "No stack bound to Conduit")
|`TCP (`Port port), Some stack ->
Expand All @@ -258,6 +269,11 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct
let f = Flow.of_tcpv4 flow in
fn f f f
);
S.listen_tcpv6 stack ~port
(fun flow ->
let f = Flow.of_tcpv6 flow in
fn f f f
);
t
|`Vchan_direct (`Remote_domid domid, port), _ ->
V.Endpoint.server ~domid ~port ()
Expand Down
8 changes: 4 additions & 4 deletions lib/conduit_mirage.mli
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@
(** Functorial connection establishment interface that is compatible with
the Mirage libraries.

Currently supports two transports:
Currently supports two transports:

- TCPv4 for remote communications using the {{:https://www.ietf.org/rfc/rfc793.txt}TCPv4} protocol
- Vchan for inter-VM communication within a single Xen host
Expand Down Expand Up @@ -54,7 +54,7 @@ module type ENDPOINT = sig
]

(** [server ~domid ~port ?read_size ?write_size] will listen on a connection for
a source [domid] and [port] combination, block until a client connects, and
a source [domid] and [port] combination, block until a client connects, and
then return a {!t} handle to read and write on the resulting connection.
The size of the shared memory buffer can be controlled by setting [read_size]
or [write_size] in bytes. *)
Expand Down Expand Up @@ -112,7 +112,7 @@ module type VCHAN_FLOW = V1_LWT.FLOW

(** Functor to construct a {!V1_LWT.FLOW} module that internally contains
all of the supported transport mechanisms, such as TCPv4 and Vchan. *)
module Make_flow(S:V1_LWT.TCPV4)(V:VCHAN_FLOW) : V1_LWT.FLOW
module Make_flow(S4:V2_LWT.TCP)(S6:V2_LWT.TCP)(V:VCHAN_FLOW) : V1_LWT.FLOW

module type S = sig

Expand Down Expand Up @@ -143,6 +143,6 @@ module type S = sig
val endp_to_server: ctx:ctx -> Conduit.endp -> server io
end

module Make(S:V1_LWT.STACKV4)(V: VCHAN_PEER) :
module Make(S:V2_LWT.STACK)(V: VCHAN_PEER) :
S with type stack = S.t
and type peer = V.t