github/linuxkit
1
0
Fork 0
mirror of https://github.com/linuxkit/linuxkit.git synced 2025-07-22 02:21:34 +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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
projects/miragesdk/src/Dockerfile
View File

@ -18,7 +18,7 @@ RUN which capnp
### SDK ### SDK
#FROM ocaml/opam@sha256:b42566186327141d715c212da3057942bd4cfa5503a87733d366835fa2ddf98d #FROM ocaml/opam@sha256:b42566186327141d715c212da3057942bd4cfa5503a87733d366835fa2ddf98d
FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 as sdk FROM ocaml/opam:alpine-3.5_ocaml-4.05.0 as sdk
COPY --from=capnp /usr/local/bin/capnp /usr/local/bin/ COPY --from=capnp /usr/local/bin/capnp /usr/local/bin/
COPY --from=capnp /usr/local/bin/capnpc /usr/local/bin/ COPY --from=capnp /usr/local/bin/capnpc /usr/local/bin/
@ -31,22 +31,17 @@ RUN sudo mkdir -p /src
USER opam USER opam
WORKDIR /src WORKDIR /src
RUN git -C /home/opam/opam-repository fetch origin && \ RUN git -C /home/opam/opam-repository fetch && \
git -C /home/opam/opam-repository reset 092a9a66 --hard && \ git -C /home/opam/opam-repository reset ac26509c --hard && \
opam update -u opam update
# capnp
RUN opam pin add -n mirage-flow.dev --dev
RUN opam pin add -n capnp.dev 'https://github.com/talex5/capnp-ocaml.git#interfaces2'
RUN opam pin add -n capnp-rpc.dev 'https://github.com/mirage/capnp-rpc.git'
RUN opam pin add -n capnp-rpc-lwt.dev 'https://github.com/mirage/capnp-rpc.git'
COPY sdk.opam /src COPY sdk.opam /src
RUN sudo chown opam -R /src RUN sudo chown opam -R /src
RUN opam pin add sdk.local /src -n RUN opam pin add sdk.local /src -n
RUN opam depext -y alcotest sdk RUN opam depext -y alcotest sdk
RUN opam install alcotest && opam install --deps sdk -t RUN opam install alcotest mtime
RUN opam install --deps sdk
RUN opam list RUN opam list
@ -60,9 +55,6 @@ RUN opam update sdk && opam install sdk -t
FROM sdk as dhcp-client FROM sdk as dhcp-client
# charrua # charrua
RUN opam pin add -n charrua-client.dev https://github.com/mirage/charrua-core.git
RUN opam pin add -n charrua-client-lwt.dev https://github.com/samoht/charrua-core.git#fix-build-and-tests
RUN opam pin add -n charrua-client-mirage.dev https://github.com/samoht/charrua-core.git#fix-build-and-tests
COPY dhcp-client.opam /src COPY dhcp-client.opam /src
RUN sudo chown opam -R /src RUN sudo chown opam -R /src

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

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

@ -8,12 +8,10 @@ end
module Client (F: S) = struct module Client (F: S) = struct
module Flow = Api.Client.Flow
type 'a io = 'a Lwt.t type 'a io = 'a Lwt.t
type t = Flow.t Capability.t
module R = Api.Reader.Flow
module B = Api.Builder.Flow
type t = R.t Capability.t
type flow = t type flow = t
type buffer = Cstruct.t type buffer = Cstruct.t
@ -44,59 +42,57 @@ module Client (F: S) = struct
Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return
let read_result r = let read_result r =
let module R = R.ReadResult in let module R = Flow.Read.Results in
match R.get (R.of_payload r) with match R.get r with
| R.Data data -> Ok (`Data (Cstruct.of_string data)) | R.Data data -> Ok (`Data (Cstruct.of_string data))
| R.Eof -> Ok `Eof | R.Eof -> Ok `Eof
| R.Error s -> Error (`Msg s) | R.Error s -> Error (`Msg s)
| R.Undefined i -> Error (`Undefined i) | 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 write_result r =
let module R = R.WriteResult in let module R = Flow.Write.Results in
match R.get (R.of_payload r) with match R.get r with
| R.Ok -> Ok () | R.Ok -> Ok ()
| R.Closed -> Error `Closed | R.Closed -> Error `Closed
| R.Error s -> Error (`Msg s) | R.Error s -> Error (`Msg s)
| R.Undefined i -> Error (`Undefined i) | 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 write t buf =
let module P = B.Write_params in let open Flow.Write in
let req, p = Capability.Request.create P.init_pointer in let req, p = Capability.Request.create Params.init_pointer in
P.buffer_set p (Cstruct.to_string buf); Params.buffer_set p (Cstruct.to_string buf);
Capability.call_for_value t R.write_method req >|= function Capability.call_for_value t method_id req >|= function
| Error e -> Error (`Capnp e) | Error e -> Error (`Capnp e)
| Ok r -> write_result r | Ok r -> write_result r
let writev t bufs = let writev t bufs =
let module P = B.Writev_params in let open Flow.Writev in
let req, p = Capability.Request.create P.init_pointer in let req, p = Capability.Request.create Params.init_pointer in
ignore @@ P.buffers_set_list p (List.map Cstruct.to_string bufs); Params.buffers_set_list p (List.map Cstruct.to_string bufs) |> ignore;
Capability.call_for_value t R.writev_method req >|= function Capability.call_for_value t method_id req >|= function
| Error e -> Error (`Capnp e) | Error e -> Error (`Capnp e)
| Ok r -> write_result r | Ok r -> write_result r
let close t = let close t =
let module P = B.Close_params in let open Flow.Close in
let req, _ = Capability.Request.create P.init_pointer in let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value t R.close_method req >|= fun _ -> Capability.call_for_value_exn t method_id req >|= ignore
()
end end
module Server (F: S) (Local: S) = struct module Server (F: S) (Local: S) = struct
module R = Api.Reader.Flow module Flow = Api.Service.Flow
module B = Api.Builder.Flow
let read_result result = 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 resp, r = Service.Response.create R.init_pointer in
let () = match result with let () = match result with
| Ok (`Data buf) -> R.data_set r (Cstruct.to_string buf) | Ok (`Data buf) -> R.data_set r (Cstruct.to_string buf)
@ -106,7 +102,7 @@ module Server (F: S) (Local: S) = struct
Ok resp Ok resp
let write_result result = 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 resp, r = Service.Response.create R.init_pointer in
let () = match result with let () = match result with
| Ok () -> R.ok_set r | Ok () -> R.ok_set r
@ -116,36 +112,37 @@ module Server (F: S) (Local: S) = struct
Ok resp Ok resp
let close_result () = 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 let resp, _ = Service.Response.create R.init_pointer in
Ok resp Ok resp
let service t = let service t =
B.local @@ Flow.local @@ object (_ : Flow.service)
object (_ : B.service) inherit Flow.service
inherit B.service
method read_impl _req = method read_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> Local.read t >|= read_result) Service.return_lwt (fun () -> Local.read t >|= read_result)
method write_impl req = method write_impl req release_param_caps =
let module P = R.Write_params in let open Flow.Write in
let params = P.of_payload req in let buf = Params.buffer_get req |> Cstruct.of_string in
let buf = P.buffer_get params |> Cstruct.of_string in release_param_caps ();
Service.return_lwt (fun () -> Local.write t buf >|= write_result) Service.return_lwt (fun () -> Local.write t buf >|= write_result)
method writev_impl req = method writev_impl req release_param_caps =
let module P = R.Writev_params in let open Flow.Writev in
let params = P.of_payload req in let bufs = Params.buffers_get_list req |> List.map Cstruct.of_string in
let bufs = P.buffers_get_list params |> List.map Cstruct.of_string in release_param_caps ();
Service.return_lwt (fun () -> Local.writev t bufs >|= write_result) 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) Service.return_lwt (fun () -> Local.close t >|= close_result)
end end
type t = R.t Capability.t type t = Flow.t Capability.t
let listen ~switch ?tags service fd = let listen ~switch ?tags service fd =
let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) fd in 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 Lwt.Infix
open Capnp_rpc_lwt open Capnp_rpc_lwt
module R = Api.Reader.Host
module B = Api.Builder.Host
module Client (F: Flow.S) = struct module Client (F: Flow.S) = struct
let pp_error = Capnp_rpc.Error.pp module Host = Api.Client.Host
type t = R.t Capability.t type t = Host.t Capability.t
let error e = Fmt.kstrf Lwt.fail_with "%a" pp_error e
let connect ~switch ?tags f = let connect ~switch ?tags f =
let ep = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) f in let ep = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module F) f in
let client = Capnp_rpc_lwt.CapTP.connect ~switch ?tags ep in let client = Capnp_rpc_lwt.CapTP.connect ~switch ?tags ep in
Capnp_rpc_lwt.CapTP.bootstrap client |> Lwt.return 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 interface t =
let module P = B.Intf_params in let open Host.Intf in
let req, _ = Capability.Request.create P.init_pointer in let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value t R.intf_method req >>= function Capability.call_for_value_exn t method_id req >|=
| Error e -> error e Host.Intf.Results.intf_get
| 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 mac t = let mac t =
let module P = B.Mac_params in let open Host.Mac in
let req, _ = Capability.Request.create P.init_pointer in let req, _ = Capability.Request.create Params.init_pointer in
Capability.call_for_value t R.mac_method req >>= function Capability.call_for_value_exn t method_id req >|= fun r ->
| Error e -> error e Macaddr.of_string_exn (Results.mac_get r)
| Ok r -> Lwt.return (mac_result r)
let dhcp_options_result r = let dhcp_options t =
let module R = R.DhcpOptions_results in let open Host.DhcpOptions in
let options = R.options_get_list (R.of_payload r) 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 -> List.fold_left (fun acc o ->
match Dhcp_wire.string_to_option_code o with match Dhcp_wire.string_to_option_code o with
| None -> acc | None -> acc
| Some o -> o :: acc | Some o -> o :: acc
) [] options ) [] 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 set_ip t ip =
let module P = B.SetIp_params in let open Host.SetIp in
let req, p = Capability.Request.create P.init_pointer in let req, p = Capability.Request.create Params.init_pointer in
P.ip_set p (Ipaddr.V4.to_string ip); Params.ip_set p (Ipaddr.V4.to_string ip);
Capability.call_for_value t R.set_ip_method req >>= function Capability.call_for_value_exn t method_id req >|=
| Error e -> error e ignore
| Ok _ -> Lwt.return ()
let set_gateway t ip = let set_gateway t ip =
let module P = B.SetGateway_params in let open Host.SetGateway in
let req, p = Capability.Request.create P.init_pointer in let req, p = Capability.Request.create Params.init_pointer in
P.ip_set p (Ipaddr.V4.to_string ip); Params.ip_set p (Ipaddr.V4.to_string ip);
Capability.call_for_value t R.set_gateway_method req >>= function Capability.call_for_value_exn t method_id req >|=
| Error e -> error e ignore
| Ok _r -> Lwt.return ()
end end
module Server (F: Flow.S) (N: S) = struct 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 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 let resp, r = Service.Response.create R.init_pointer in
R.mac_set r (Macaddr.to_string result); R.mac_set r (Macaddr.to_string result);
Ok resp Ok resp
let intf_result result = 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 let resp, r = Service.Response.create R.init_pointer in
R.intf_set r result; R.intf_set r result;
Ok resp Ok resp
let dhcp_options_result result = 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 resp, r = Service.Response.create R.init_pointer in
let result = List.map Dhcp_wire.option_code_to_string result in let result = List.map Dhcp_wire.option_code_to_string result in
let _ = R.options_set_list r result in let _ = R.options_set_list r result in
Ok resp Ok resp
let service t = let service t =
B.local @@ Host.local @@ object (_ : Host.service)
object (_ : B.service) inherit Host.service
inherit B.service
method intf_impl _req = method intf_impl _req release_param_caps =
release_param_caps ();
Service.return_lwt (fun () -> N.interface t >|= intf_result) 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) 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) Service.return_lwt (fun () -> N.dhcp_options t >|= dhcp_options_result)
method set_ip_impl req = method set_ip_impl req release_param_caps =
let module P = R.SetIp_params in let open Host.SetIp in
let params = P.of_payload req in let ip = Params.ip_get req in
let ip = P.ip_get params in release_param_caps ();
Service.return_lwt (fun () -> Service.return_lwt (fun () ->
let module R = B.SetIp_results in let resp, _ = Service.Response.create Results.init_pointer in
let resp, _ = Service.Response.create R.init_pointer in
match Ipaddr.V4.of_string ip with 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 | Some ip -> N.set_ip t ip >|= fun () -> Ok resp
) )
method set_gateway_impl req = method set_gateway_impl req release_param_caps =
let module P = R.SetGateway_params in let open Host.SetGateway in
let params = P.of_payload req in let ip = Params.ip_get req in
let ip = P.ip_get params in release_param_caps ();
Service.return_lwt (fun () -> Service.return_lwt (fun () ->
let module R = B.SetGateway_results in let resp, _ = Service.Response.create Results.init_pointer in
let resp, _ = Service.Response.create R.init_pointer in
match Ipaddr.V4.of_string ip with match Ipaddr.V4.of_string ip with
| None ->Lwt.fail_invalid_arg "invalid ip" | None -> Lwt.fail_invalid_arg "invalid ip"
| Some ip -> N.set_ip t ip >|= fun () -> Ok resp | Some ip -> N.set_gateway t ip >|= fun () -> Ok resp
) )
end end

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

@ -5,7 +5,7 @@
(public_name sdk) (public_name sdk)
(flags (:standard -w -53-55)) (flags (:standard -w -53-55))
(libraries (irmin irmin-mem lwt.unix rawlink charrua-core.wire (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)))) mirage-time-lwt mirage-flow-rawlink capnp capnp-rpc-lwt))))
(rule (rule

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

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