mirror of
https://github.com/linuxkit/linuxkit.git
synced 2025-07-19 17:26:28 +00:00
Update to latest capnp & capnp-rpc
Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
This commit is contained in:
Thomas Gazagnaire
parent
e27807b733
commit
14a5b64dcc
@ -18,7 +18,7 @@ RUN which capnp
|
||||
### SDK
|
||||
|
||||
#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/capnpc /usr/local/bin/
|
||||
@ -31,22 +31,17 @@ RUN sudo mkdir -p /src
|
||||
USER opam
|
||||
WORKDIR /src
|
||||
|
||||
RUN git -C /home/opam/opam-repository fetch origin && \
|
||||
git -C /home/opam/opam-repository reset 092a9a66 --hard && \
|
||||
opam update -u
|
||||
|
||||
# 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'
|
||||
RUN git -C /home/opam/opam-repository fetch && \
|
||||
git -C /home/opam/opam-repository reset ac26509c --hard && \
|
||||
opam update
|
||||
|
||||
COPY sdk.opam /src
|
||||
RUN sudo chown opam -R /src
|
||||
RUN opam pin add sdk.local /src -n
|
||||
|
||||
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
|
||||
|
||||
@ -60,9 +55,6 @@ RUN opam update sdk && opam install sdk -t
|
||||
FROM sdk as dhcp-client
|
||||
|
||||
# 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
|
||||
RUN sudo chown opam -R /src
|
||||
|
||||
@ -1 +1 @@
|
||||
include Proto.MakeRPC(Capnp.BytesMessage)(Capnp_rpc_lwt)
|
||||
include Proto.MakeRPC(Capnp_rpc_lwt)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user