github/linuxkit
1
0
Fork 0
mirror of https://github.com/linuxkit/linuxkit.git synced 2025-10-31 14:09:15 +00:00
Code Issues Projects Releases Wiki Activity

Update to latest capnp & capnp-rpc

Browse Source 
Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
This commit is contained in:
Thomas Gazagnaire
2017-09-04 16:01:04 +02:00
parent e27807b733
commit 14a5b64dcc
7 changed files with 235 additions and 292 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
projects/miragesdk/src/sdk/api.ml
View File

@@ -1 +1 @@
include Proto.MakeRPC(Capnp.BytesMessage)(Capnp_rpc_lwt)
include Proto.MakeRPC(Capnp_rpc_lwt)

142
projects/miragesdk/src/sdk/conf.ml
View File

@@ -17,19 +17,15 @@ exception Undefined_field of int
let err_not_found fmt = Fmt.kstrf (fun x -> Lwt.fail_invalid_arg x) fmt
let failf fmt = Fmt.kstrf (fun x -> Lwt.fail_with x) fmt
module R = Api.Reader.Conf
module B = Api.Builder.Conf
module Callback = struct
let service f =
B.Callback.local @@ object (_: B.Callback.service)
inherit B.Callback.service
method f_impl req =
let module P = R.Callback.F_params in
let params = P.of_payload req in
let change = P.change_get params in
let open Api.Service.Conf.Callback in
local @@ object (_: service)
inherit service
method f_impl req release_param_caps =
let change = F.Params.change_get req in
release_param_caps ();
Service.return_lwt (fun () ->
f change >|= fun () ->
Ok (Service.Response.create_empty ())
@@ -37,21 +33,20 @@ module Callback = struct
end
let client t change =
let module P = B.Callback.F_params in
let req, p = Capability.Request.create P.init_pointer in
P.change_set p change;
Capability.call_for_value t R.Callback.f_method req >>= function
| Ok _ -> Lwt.return ()
| Error e -> failf "error: f(%s) -> %a" change Capnp_rpc.Error.pp e
let open Api.Client.Conf.Callback in
let req, p = Capability.Request.create F.Params.init_pointer in
F.Params.change_set p change;
Capability.call_for_value_exn t F.method_id req >|=
ignore
end
module Client (F: Flow.S) = struct
type t = R.t Capability.t
module Conf = Api.Client.Conf
let pp_error = Capnp_rpc.Error.pp
type t = Conf.t Capability.t
let connect ~switch ?tags f =
let ep = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) f in
@@ -59,18 +54,14 @@ module Client (F: Flow.S) = struct
Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return
let find t path =
let module P = B.Read_params in
let req, p = Capability.Request.create P.init_pointer in
P.path_set_list p path |> ignore;
Capability.call_for_value t R.read_method req >>= function
| Error e -> failf "error read(%a): %a" pp_path path pp_error e
| Ok r ->
let module R = R.Response in
let r = R.of_payload r in
match R.get r with
| R.Ok data -> Lwt.return (Some data)
| R.NotFound -> Lwt.return None
| R.Undefined _ -> failf "invalid return"
let open Conf.Read in
let req, p = Capability.Request.create Params.init_pointer in
Params.path_set_list p path |> ignore;
Capability.call_for_value_exn t method_id req >>= fun r ->
match Results.get r with
| Ok data -> Lwt.return (Some data)
| NotFound -> Lwt.return None
| Undefined _ -> failf "invalid return"
let get t path =
find t path >>= function
@@ -78,31 +69,24 @@ module Client (F: Flow.S) = struct
| None -> err_not_found "get %a" pp_path path
let set t path data =
let module P = B.Write_params in
let req, p = Capability.Request.create P.init_pointer in
P.path_set_list p path |> ignore;
P.data_set p data;
Capability.call_for_value t R.write_method req >>= function
| Ok _ -> Lwt.return ()
| Error e -> failf "error write(%a): %a" pp_path path pp_error e
let open Conf.Write in
let req, p = Capability.Request.create Params.init_pointer in
Params.path_set_list p path |> ignore;
Params.data_set p data;
Capability.call_for_value_exn t method_id req >|= ignore
let delete t path =
let module P = B.Delete_params in
let req, p = Capability.Request.create P.init_pointer in
P.path_set_list p path |> ignore;
Capability.call_for_value t R.delete_method req >>= function
| Ok _ -> Lwt.return ()
| Error e -> failf "error delete(%a): %a" pp_path path pp_error e
let open Conf.Delete in
let req, p = Capability.Request.create Params.init_pointer in
Params.path_set_list p path |> ignore;
Capability.call_for_value_exn t method_id req >|= ignore
let watch t path f =
let module P = B.Watch_params in
let req, p = Capability.Request.create P.init_pointer in
P.path_set_list p path |> ignore;
let callback = Capability.Request.export req (Callback.service f) in
P.callback_set p (Some callback);
Capability.call_for_value t R.watch_method req >>= function
| Ok _ -> Lwt.return ()
| Error e -> failf "error watch(%a): %a" pp_path path pp_error e
let open Conf.Watch in
let req, p = Capability.Request.create Params.init_pointer in
Params.path_set_list p path |> ignore;
Params.callback_set p (Some (Callback.service f));
Capability.call_for_value_exn t method_id req >|= ignore
end
@@ -123,7 +107,8 @@ module Server (F: Flow.S) = struct
type op = [ `Read | `Write | `Delete ]
type t = R.t Capability.t
module Conf = Api.Service.Conf
type t = Conf.t Capability.t
let infof fmt =
Fmt.kstrf (fun msg () ->
@@ -164,55 +149,54 @@ module Server (F: Flow.S) = struct
| exception Not_found -> Service.fail "%s" (not_allowed key)
let service ~switch ~routes db =
B.local @@ object (_ : B.service)
inherit B.service
method read_impl req =
let module P = R.Read_params in
let params = P.of_payload req in
let key = P.path_get_list params in
Conf.local @@ object (_ : Conf.service)
inherit Conf.service
method read_impl req release_param_caps =
let open Conf.Read in
let key = Params.path_get_list req in
release_param_caps ();
with_permission_check ~routes `Read key @@ fun () ->
Service.return_lwt (fun () ->
let module R = B.Response in
let resp, r = Service.Response.create R.init_pointer in
let resp, r = Service.Response.create Results.init_pointer in
(KV.find db key >|= function
| None -> R.not_found_set r
| Some x -> R.ok_set r x
| None -> Results.not_found_set r
| Some x -> Results.ok_set r x
) >|= fun () ->
Ok resp
)
method write_impl req =
let module P = R.Write_params in
let params = P.of_payload req in
let key = P.path_get_list params in
let value = P.data_get params in
method write_impl req release_param_caps =
let open Conf.Write in
let key = Params.path_get_list req in
let value = Params.data_get req in
release_param_caps ();
with_permission_check ~routes `Write key @@ fun () ->
Service.return_lwt (fun () ->
write db key value >|= fun () ->
Ok (Service.Response.create_empty ())
)
method delete_impl req =
let module P = R.Delete_params in
let params = P.of_payload req in
let key = P.path_get_list params in
method delete_impl req release_param_caps =
let open Conf.Delete in
let key = Params.path_get_list req in
release_param_caps ();
with_permission_check ~routes `Delete key @@ fun () ->
Service.return_lwt (fun () ->
delete db key >|= fun () ->
Ok (Service.Response.create_empty ())
)
method watch_impl req =
let module P = R.Watch_params in
let params = P.of_payload req in
let key = P.path_get_list params in
match P.callback_get params with
| None -> failwith "No watcher callback given"
method watch_impl req release_param_caps =
let open Conf.Watch in
let key = Params.path_get_list req in
let callback = Params.callback_get req in
release_param_caps ();
match callback with
| None -> Service.fail "No watcher callback given"
| Some i ->
let callback = Payload.import req i in
with_permission_check ~routes `Read key @@ fun () ->
Service.return_lwt (fun () ->
watch ~switch db key (Callback.client callback) >|= fun () ->
watch ~switch db key (Callback.client i) >|= fun () ->
Ok (Service.Response.create_empty ())
)
end

91
projects/miragesdk/src/sdk/flow.ml
View File

@@ -8,12 +8,10 @@ end
module Client (F: S) = struct
module Flow = Api.Client.Flow
type 'a io = 'a Lwt.t
module R = Api.Reader.Flow
module B = Api.Builder.Flow
type t = R.t Capability.t
type t = Flow.t Capability.t
type flow = t
type buffer = Cstruct.t
@@ -44,59 +42,57 @@ module Client (F: S) = struct
Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return
let read_result r =
let module R = R.ReadResult in
match R.get (R.of_payload r) with
let module R = Flow.Read.Results in
match R.get r with
| R.Data data -> Ok (`Data (Cstruct.of_string data))
| R.Eof -> Ok `Eof
| R.Error s -> Error (`Msg s)
| R.Undefined i -> Error (`Undefined i)
let read t =
let module P = B.Read_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value t R.read_method req >|= function
| Error e -> Error (`Capnp e)
| Ok r -> read_result r
let write_result r =
let module R = R.WriteResult in
match R.get (R.of_payload r) with
let module R = Flow.Write.Results in
match R.get r with
| R.Ok -> Ok ()
| R.Closed -> Error `Closed
| R.Error s -> Error (`Msg s)
| R.Undefined i -> Error (`Undefined i)
let read t =
let open Flow.Read in
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value t method_id req >|= function
| Error e -> Error (`Capnp e)
| Ok r -> read_result r
let write t buf =
let module P = B.Write_params in
let req, p = Capability.Request.create P.init_pointer in
P.buffer_set p (Cstruct.to_string buf);
Capability.call_for_value t R.write_method req >|= function
let open Flow.Write in
let req, p = Capability.Request.create Params.init_pointer in
Params.buffer_set p (Cstruct.to_string buf);
Capability.call_for_value t method_id req >|= function
| Error e -> Error (`Capnp e)
| Ok r -> write_result r
let writev t bufs =
let module P = B.Writev_params in
let req, p = Capability.Request.create P.init_pointer in
ignore @@ P.buffers_set_list p (List.map Cstruct.to_string bufs);
Capability.call_for_value t R.writev_method req >|= function
let open Flow.Writev in
let req, p = Capability.Request.create Params.init_pointer in
Params.buffers_set_list p (List.map Cstruct.to_string bufs) |> ignore;
Capability.call_for_value t method_id req >|= function
| Error e -> Error (`Capnp e)
| Ok r -> write_result r
let close t =
let module P = B.Close_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value t R.close_method req >|= fun _ ->
()
let open Flow.Close in
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value_exn t method_id req >|= ignore
end
module Server (F: S) (Local: S) = struct
module R = Api.Reader.Flow
module B = Api.Builder.Flow
module Flow = Api.Service.Flow
let read_result result =
let module R = B.ReadResult in
let module R = Flow.Read.Results in
let resp, r = Service.Response.create R.init_pointer in
let () = match result with
| Ok (`Data buf) -> R.data_set r (Cstruct.to_string buf)
@@ -106,7 +102,7 @@ module Server (F: S) (Local: S) = struct
Ok resp
let write_result result =
let module R = B.WriteResult in
let module R = Flow.Write.Results in
let resp, r = Service.Response.create R.init_pointer in
let () = match result with
| Ok () -> R.ok_set r
@@ -116,36 +112,37 @@ module Server (F: S) (Local: S) = struct
Ok resp
let close_result () =
let module R = B.Close_results in
let module R = Flow.Close.Results in
let resp, _ = Service.Response.create R.init_pointer in
Ok resp
let service t =
B.local @@
object (_ : B.service)
inherit B.service
Flow.local @@ object (_ : Flow.service)
inherit Flow.service
method read_impl _req =
method read_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> Local.read t >|= read_result)
method write_impl req =
let module P = R.Write_params in
let params = P.of_payload req in
let buf = P.buffer_get params |> Cstruct.of_string in
method write_impl req release_param_caps =
let open Flow.Write in
let buf = Params.buffer_get req |> Cstruct.of_string in
release_param_caps ();
Service.return_lwt (fun () -> Local.write t buf >|= write_result)
method writev_impl req =
let module P = R.Writev_params in
let params = P.of_payload req in
let bufs = P.buffers_get_list params |> List.map Cstruct.of_string in
method writev_impl req release_param_caps =
let open Flow.Writev in
let bufs = Params.buffers_get_list req |> List.map Cstruct.of_string in
release_param_caps ();
Service.return_lwt (fun () -> Local.writev t bufs >|= write_result)
method close_impl _req =
method close_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> Local.close t >|= close_result)
end
type t = R.t Capability.t
type t = Flow.t Capability.t
let listen ~switch ?tags service fd =
let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) fd in

125
projects/miragesdk/src/sdk/host.ml
View File

@@ -68,138 +68,117 @@ end
open Lwt.Infix
open Capnp_rpc_lwt
module R = Api.Reader.Host
module B = Api.Builder.Host
module Client (F: Flow.S) = struct
let pp_error = Capnp_rpc.Error.pp
module Host = Api.Client.Host
type t = R.t Capability.t
let error e = Fmt.kstrf Lwt.fail_with "%a" pp_error e
type t = Host.t Capability.t
let connect ~switch ?tags f =
let ep = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) f in
let client = Capnp_rpc_lwt.CapTP.connect ~switch ?tags ep in
Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return
let intf_result r =
let module R = R.Intf_results in
R.intf_get (R.of_payload r)
let interface t =
let module P = B.Intf_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value t R.intf_method req >>= function
| Error e -> error e
| Ok r -> Lwt.return (intf_result r)
let mac_result r =
let module R = R.Mac_results in
let mac = R.mac_get (R.of_payload r) in
Macaddr.of_string_exn mac
let open Host.Intf in
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value_exn t method_id req >|=
Host.Intf.Results.intf_get
let mac t =
let module P = B.Mac_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value t R.mac_method req >>= function
| Error e -> error e
| Ok r -> Lwt.return (mac_result r)
let open Host.Mac in
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value_exn t method_id req >|= fun r ->
Macaddr.of_string_exn (Results.mac_get r)
let dhcp_options_result r =
let module R = R.DhcpOptions_results in
let options = R.options_get_list (R.of_payload r) in
let dhcp_options t =
let open Host.DhcpOptions in
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value_exn t method_id req >|= fun r ->
let options = Results.options_get_list r in
List.fold_left (fun acc o ->
match Dhcp_wire.string_to_option_code o with
| None -> acc
| Some o -> o :: acc
) [] options
let dhcp_options t =
let module P = B.DhcpOptions_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value t R.dhcp_options_method req >>= function
| Error e -> error e
| Ok r -> Lwt.return (dhcp_options_result r)
let set_ip t ip =
let module P = B.SetIp_params in
let req, p = Capability.Request.create P.init_pointer in
P.ip_set p (Ipaddr.V4.to_string ip);
Capability.call_for_value t R.set_ip_method req >>= function
| Error e -> error e
| Ok _ -> Lwt.return ()
let open Host.SetIp in
let req, p = Capability.Request.create Params.init_pointer in
Params.ip_set p (Ipaddr.V4.to_string ip);
Capability.call_for_value_exn t method_id req >|=
ignore
let set_gateway t ip =
let module P = B.SetGateway_params in
let req, p = Capability.Request.create P.init_pointer in
P.ip_set p (Ipaddr.V4.to_string ip);
Capability.call_for_value t R.set_gateway_method req >>= function
| Error e -> error e
| Ok _r -> Lwt.return ()
let open Host.SetGateway in
let req, p = Capability.Request.create Params.init_pointer in
Params.ip_set p (Ipaddr.V4.to_string ip);
Capability.call_for_value_exn t method_id req >|=
ignore
end
module Server (F: Flow.S) (N: S) = struct
type t = B.t Capability.t
module Host = Api.Service.Host
type t = Host.t Capability.t
let mac_result result =
let module R = B.Mac_results in
let module R = Host.Mac.Results in
let resp, r = Service.Response.create R.init_pointer in
R.mac_set r (Macaddr.to_string result);
Ok resp
let intf_result result =
let module R = B.Intf_results in
let module R = Host.Intf.Results in
let resp, r = Service.Response.create R.init_pointer in
R.intf_set r result;
Ok resp
let dhcp_options_result result =
let module R = B.DhcpOptions_results in
let module R = Host.DhcpOptions.Results in
let resp, r = Service.Response.create R.init_pointer in
let result = List.map Dhcp_wire.option_code_to_string result in
let _ = R.options_set_list r result in
Ok resp
let service t =
B.local @@
object (_ : B.service)
inherit B.service
Host.local @@ object (_ : Host.service)
inherit Host.service
method intf_impl _req =
method intf_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> N.interface t >|= intf_result)
method mac_impl _req =
method mac_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> N.mac t >|= mac_result)
method dhcp_options_impl _req =
method dhcp_options_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> N.dhcp_options t >|= dhcp_options_result)
method set_ip_impl req =
let module P = R.SetIp_params in
let params = P.of_payload req in
let ip = P.ip_get params in
method set_ip_impl req release_param_caps =
let open Host.SetIp in
let ip = Params.ip_get req in
release_param_caps ();
Service.return_lwt (fun () ->
let module R = B.SetIp_results in
let resp, _ = Service.Response.create R.init_pointer in
let resp, _ = Service.Response.create Results.init_pointer in
match Ipaddr.V4.of_string ip with
| None ->Lwt.fail_invalid_arg "invalid ip"
| None -> Lwt.fail_with "invalid ip"
| Some ip -> N.set_ip t ip >|= fun () -> Ok resp
)
method set_gateway_impl req =
let module P = R.SetGateway_params in
let params = P.of_payload req in
let ip = P.ip_get params in
method set_gateway_impl req release_param_caps =
let open Host.SetGateway in
let ip = Params.ip_get req in
release_param_caps ();
Service.return_lwt (fun () ->
let module R = B.SetGateway_results in
let resp, _ = Service.Response.create R.init_pointer in
let resp, _ = Service.Response.create Results.init_pointer in
match Ipaddr.V4.of_string ip with
| None ->Lwt.fail_invalid_arg "invalid ip"
| Some ip -> N.set_ip t ip >|= fun () -> Ok resp
| None -> Lwt.fail_invalid_arg "invalid ip"
| Some ip -> N.set_gateway t ip >|= fun () -> Ok resp
)
end

2
projects/miragesdk/src/sdk/jbuild
View File

@@ -5,7 +5,7 @@
(public_name sdk)
(flags (:standard -w -53-55))
(libraries (irmin irmin-mem lwt.unix rawlink charrua-core.wire
tuntap astring mirage-flow-lwt mirage-net-flow
tuntap astring mirage-flow-lwt mirage-flow-unix mirage-net-flow
mirage-time-lwt mirage-flow-rawlink capnp capnp-rpc-lwt))))
(rule

145
projects/miragesdk/src/sdk/net.ml
View File

@@ -1,46 +1,40 @@
open Lwt.Infix
open Capnp_rpc_lwt
module B = Api.Builder.Net
module R = Api.Reader.Net
module type S = Mirage_net_lwt.S
module Callback = struct
let service f =
B.Callback.local @@ object (_: B.Callback.service)
inherit B.Callback.service
method f_impl req =
let module P = R.Callback.F_params in
let params = P.of_payload req in
let change = P.buffer_get params in
let open Api.Service.Net.Callback in
local @@ object (_: service)
inherit service
method f_impl req release_param_caps =
let change = F.Params.buffer_get req in
release_param_caps ();
Service.return_lwt (fun () ->
f (Cstruct.of_string change) >|= fun () ->
Ok (Service.Response.create_empty ())
)
end
module F = Api.Reader.Conf.Callback
let client t change =
let module P = B.Callback.F_params in
let req, p = Capability.Request.create P.init_pointer in
let open Api.Client.Net.Callback in
let req, p = Capability.Request.create F.Params.init_pointer in
let change = Cstruct.to_string change in
P.buffer_set p change;
Capability.call_for_value t R.Callback.f_method req >>= function
| Ok _ -> Lwt.return ()
| Error e ->
Fmt.kstrf Lwt.fail_with "error: f(%s) -> %a" change Capnp_rpc.Error.pp e
F.Params.buffer_set p change;
Capability.call_for_value_exn t F.method_id req >|= ignore
end
module Client (F: Flow.S) = struct
module Net = Api.Client.Net
type 'a io = 'a Lwt.t
type t = {
cap : R.t Capability.t;
cap : Net.t Capability.t;
mac : Macaddr.t;
stats: Mirage_net.stats;
}
@@ -62,49 +56,48 @@ module Client (F: Flow.S) = struct
| `Capnp e -> Fmt.pf ppf "capnp: %a" Capnp_rpc.Error.pp e
| #Mirage_device.error as e -> Mirage_device.pp_error ppf e
let result r =
let module R = R.Result in
match R.get (R.of_payload r) with
| R.Ok -> Ok ()
let result r: (unit, error) result =
let module R = Net.Write.Results in
match R.get r with
| R.Ok -> Ok ()
| R.Unimplemented -> Error `Unimplemented
| R.Disconnected -> Error `Disconnected
| R.Error s -> Error (`Msg s)
| R.Undefined i -> Error (`Undefined i)
let write t buf =
let module P = B.Write_params in
let req, p = Capability.Request.create P.init_pointer in
P.buffer_set p (Cstruct.to_string buf);
Capability.call_for_value t.cap R.write_method req >|= function
let open Net.Write in
let req, p = Capability.Request.create Params.init_pointer in
Params.buffer_set p (Cstruct.to_string buf);
Capability.call_for_value t.cap method_id req >|= function
| Error e -> Error (`Capnp e)
| Ok r ->
Mirage_net.Stats.tx t.stats (Int64.of_int @@ Cstruct.len buf);
result r
let writev t bufs =
let module P = B.Writev_params in
let req, p = Capability.Request.create P.init_pointer in
ignore @@ P.buffers_set_list p (List.map Cstruct.to_string bufs);
Capability.call_for_value t.cap R.writev_method req >|= function
let open Net.Writev in
let req, p = Capability.Request.create Params.init_pointer in
Params.buffers_set_list p (List.map Cstruct.to_string bufs) |> ignore;
Capability.call_for_value t.cap method_id req >|= function
| Error e -> Error (`Capnp e)
| Ok r ->
Mirage_net.Stats.tx t.stats (Int64.of_int @@ Cstruct.lenv bufs);
result r
let listen t f =
let module P = B.Listen_params in
let req, p = Capability.Request.create P.init_pointer in
let callback = Capability.Request.export req (Callback.service f) in
P.callback_set p (Some callback);
Capability.call_for_value t.cap R.listen_method req >|= function
let open Net.Listen in
let req, p = Capability.Request.create Params.init_pointer in
Params.callback_set p (Some (Callback.service f));
Capability.call_for_value t.cap method_id req >|= function
| Ok _ -> Ok ()
| Error e -> Error (`Capnp e)
let disconnect { cap; _ } =
let module P = B.Disconnect_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value cap R.disconnect_method req >|= fun _ ->
()
let open Net.Disconnect in
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value_exn cap method_id req >|=
ignore
let mac t = t.mac
@@ -114,16 +107,13 @@ module Client (F: Flow.S) = struct
Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return
let connect ~switch ?tags f =
let open Net.Mac in
capability ~switch ?tags f >>= fun cap ->
let module P = B.Mac_params in
let req, _ = Capability.Request.create P.init_pointer in
Capability.call_for_value cap R.mac_method req >>= function
| Error e -> Fmt.kstrf Lwt.fail_with "%a" Capnp_rpc.Error.pp e
| Ok r ->
let module R = R.Mac_results in
let mac = R.mac_get (R.of_payload r) |> Macaddr.of_string_exn in
let stats = Mirage_net.Stats.create () in
Lwt.return { cap; mac; stats }
let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value_exn cap method_id req >|= fun r ->
let mac = Results.mac_get r |> Macaddr.of_string_exn in
let stats = Mirage_net.Stats.create () in
{ cap; mac; stats }
let reset_stats_counters t = Mirage_net.Stats.reset t.stats
let get_stats_counters t = t.stats
@@ -131,8 +121,10 @@ end
module Server (F: Flow.S) (Local: Mirage_net_lwt.S) = struct
module Net = Api.Service.Net
let result x =
let module R = B.Result in
let module R = Net.Write.Results in
let resp, r = Service.Response.create R.init_pointer in
let () = match x with
| Ok () -> R.ok_set r
@@ -143,55 +135,54 @@ module Server (F: Flow.S) (Local: Mirage_net_lwt.S) = struct
Ok resp
let mac_result x =
let module R = B.Mac_results in
let module R = Net.Mac.Results in
let resp, r = Service.Response.create R.init_pointer in
R.mac_set r (Macaddr.to_string x);
Ok resp
resp
let disconnect_result () =
let module R = B.Disconnect_results in
let module R = Net.Disconnect.Results in
let resp, _ = Service.Response.create R.init_pointer in
Ok resp
let service t =
B.local @@
object (_ : B.service)
inherit B.service
Net.local @@ object (_ : Net.service)
inherit Net.service
method disconnect_impl _req =
method disconnect_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> Local.disconnect t >|= disconnect_result)
method write_impl req =
let module P = R.Write_params in
let params = P.of_payload req in
let buf = P.buffer_get params |> Cstruct.of_string in
method write_impl req release_param_caps =
let open Net.Write in
let buf = Params.buffer_get req |> Cstruct.of_string in
release_param_caps ();
Service.return_lwt (fun () -> Local.write t buf >|= result)
method writev_impl req =
let module P = R.Writev_params in
let params = P.of_payload req in
let bufs = P.buffers_get_list params |> List.map Cstruct.of_string in
method writev_impl req release_param_caps =
let open Net.Writev in
let bufs = Params.buffers_get_list req |> List.map Cstruct.of_string in
release_param_caps ();
Service.return_lwt (fun () -> Local.writev t bufs >|= result)
method listen_impl req =
let module P = R.Listen_params in
let params = P.of_payload req in
match P.callback_get params with
| None -> failwith "No watcher callback given"
method listen_impl req release_param_caps =
let open Net.Listen in
let callback = Params.callback_get req in
release_param_caps ();
match callback with
| None -> Service.fail "No watcher callback given"
| Some i ->
let callback = Payload.import req i in
Service.return_lwt (fun () ->
Local.listen t (Callback.client callback) >|= result
Local.listen t (Callback.client i) >|= result
)
method mac_impl req =
let module P = R.Mac_params in
let _params = P.of_payload req in
Service.return_lwt (fun () -> Lwt.return (mac_result (Local.mac t)))
method mac_impl _req release_param_caps =
release_param_caps ();
Service.return (mac_result (Local.mac t))
end
type t = R.t Capability.t
type t = Net.t Capability.t
let listen ~switch ?tags service fd =
let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) fd in