diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 1c094e798..108466441 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -22,7 +22,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Use OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v3 diff --git a/CHANGES.md b/CHANGES.md index ba9c0b9ff..499c28e73 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,29 @@ +### v2.x + +- Rename `Capnp_rpc_lwt` to `Capnp_rpc` (which is now `Capnp_rpc_proto`). + The new `Capnp_rpc` now provides `Error`, `Exception` and `Debug` aliases + to the same modules in `Capnp_rpc_proto`, so that `Capnp_rpc_proto` doesn't + need to be used directly. + +- Add `Capnp_rpc.Std` with some common module aliases, to reduce the need + to `open Capnp_rpc` (which is rather large). + +- Convert API from Lwt to Eio. + +To update to the new API: + +1. Use [lwt_eio][] during the migration to allow using Eio and Lwt together in your application. +2. Replace `open Capnp_rpc_lwt` with `open Capnp_rpc.Std`. +3. Replace all other uses of `Capnp_rpc_lwt` with just `Capnp_rpc`. +4. In `dune` and `opam` files, replace `capnp-rpc-lwt` with `capnp-rpc`. +5. Some modules are in `Capnp_rpc` but not the `Capnp_rpc.Std` subset. + Those should now be fully qualified (e.g. replace `Persistence` with + `Capnp_rpc.Persistence`). +6. Replace `Service.return_lwt` with `Lwt_eio.run_lwt`. +7. Once all Lwt code is gone, `lwt_eio` can be removed. + +[lwt_eio]: https://github.com/ocaml-multicore/lwt_eio + ### v1.2.3 - Update to cmdliner 1.1.0 (@MisterDA #249). diff --git a/Makefile b/Makefile index 1f7fe3eda..45ff0416b 100644 --- a/Makefile +++ b/Makefile @@ -2,11 +2,6 @@ default: test build-fuzz -all: - dune build @install test/test.exe test-lwt/test_lwt.exe test-bin/calc.exe - rm -rf _build/_tests - dune runtest --no-buffer -j 1 - build-fuzz: dune build fuzz/fuzz.exe @@ -19,7 +14,5 @@ clean: test: rm -rf _build/_tests - dune build test/test.exe test-lwt/test_lwt.exe test-bin/calc.exe test-bin/echo/echo_bench.exe @install - #./_build/default/test/test.bc test core -ev 36 - #./_build/default/test-lwt/test.bc test lwt -ev 3 + dune build test test-bin @install dune build @runtest --no-buffer -j 1 diff --git a/README.md b/README.md index fb7b8da0e..a6c9ab7be 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # OCaml Cap'n Proto RPC library Copyright 2017 Docker, Inc. -Copyright 2019 Thomas Leonard. +Copyright 2024 Thomas Leonard. See [LICENSE.md](LICENSE.md) for details. [API documentation][api] @@ -71,10 +71,10 @@ This library should be used with the [capnp-ocaml][] schema compiler, which gene RPC Level 2 is complete, with encryption and authentication using TLS and support for persistence. The library has unit tests and AFL fuzz tests that cover most of the core logic. -It is used as the RPC system in [ocaml-ci][]. +It is used as the RPC system in [ocaml-ci][] and [ocluster][]. The default network provided supports TCP and Unix-domain sockets, both with or without TLS. -For two-party networking, you can provide any bi-directional byte stream (satisfying the Mirage flow signature) +For two-party networking, you can provide any bi-directional byte stream (satisfying the `Eio.Flow.two_way` signature) to the library to create a connection. You can also define your own network types. @@ -84,30 +84,23 @@ Until that is implemented, Carol can ask Bob for a persistent reference (sturdy ## Installing -To install, you will need a platform with the capnproto package available (e.g. Debian >= 9). Then: +To install, you will need a platform with the capnproto package available (e.g. Debian >= 9). Then (using opam 2.1 or later): opam install capnp-rpc-unix -(note: if you are using opam < 2.1, direct install is not possible, so do the following): - - opam depext -i capnp-rpc-unix - ## Structure of the library -The code is split into several packages: +**Note:** This README documents the newer (unreleased) Eio API. For the 1.x Lwt API, see an older version of the README. The main change is that `Capnp_rpc_lwt` is now just `Capnp_rpc`. See the [CHANGES.md](./CHANGES.md) file for help migrating to 2.0. -- `capnp-rpc` contains the logic of the [Cap'n Proto RPC Protocol][], but does not depend on any particular serialisation. - The tests in the `test` directory test the logic using a simple representation where messages are OCaml data-structures - (defined in `capnp-rpc/message_types.ml`). +The code is split into several packages: -- `capnp-rpc-lwt` instantiates the `capnp-rpc` functor using the Cap'n Proto serialisation for messages and Lwt for concurrency. +- `capnp-rpc` allows you to define and use services. - `capnp-rpc-net` adds networking support, including TLS. - `capnp-rpc-unix` adds helper functions for parsing command-line arguments and setting up connections over Unix sockets. - The tests in `test-lwt` test this by sending Cap'n Proto messages over a Unix-domain socket. -**Libraries** that consume or provide Cap'n Proto services should normally depend only on `capnp-rpc-lwt`, +**Libraries** that consume or provide Cap'n Proto services should normally depend only on `capnp-rpc`, since they shouldn't care whether the services they use are local or accessed over some kind of network. **Applications** will normally want to use `capnp-rpc-net` and, in most cases, `capnp-rpc-unix`. @@ -172,10 +165,9 @@ For the server, you should inherit from the generated `Api.Service.Echo.service` ```ocaml -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std let local = let module Echo = Api.Service.Echo in @@ -208,7 +200,7 @@ There's a bit of ugly boilerplate here, but it's quite simple: should always free them anyway. - `Service.Response.create Results.init_pointer` creates a new response message, using `Ping.Results.init_pointer` to initialise the payload contents. - `response` is the complete message to be sent back, and `results` is the data part of it. -- `Service.return` returns the results immediately (like `Lwt.return`). +- `Service.return` returns the results immediately (rather than returning a promise). The client implementation is similar, but uses `Api.Client` instead of `Api.Service`. Here, we have a *builder* for the parameters and a *reader* for the results. @@ -222,7 +214,7 @@ let ping t msg = let open Echo.Ping in let request, params = Capability.Request.create Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get ``` `Capability.call_for_value_exn` sends the request message to the service and waits for the response to arrive. @@ -236,19 +228,17 @@ With the boilerplate out of the way, we can now write a `main.ml` to test it: ```ocaml -open Lwt.Infix +open Eio.Std let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let () = - Lwt_main.run begin - let service = Echo.local in - Echo.ping service "foo" >>= fun reply -> - Fmt.pr "Got reply %S@." reply; - Lwt.return_unit - end + Eio_main.run @@ fun _ -> + let service = Echo.local in + let reply = Echo.ping service "foo" in + traceln "Got reply %S" reply ```

@@ -261,8 +251,7 @@ Here's a suitable `dune` file to compile the schema file and then the generated ``` (executable (name main) - (libraries lwt.unix capnp-rpc-lwt logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc logs.fmt)) (rule (targets echo_api.ml echo_api.mli) @@ -281,14 +270,12 @@ The service is now usable: ```bash -$ opam install capnp-rpc-lwt +$ opam install capnp-rpc ``` -(note: or `$ opam depext -i capnp-rpc-lwt` for opam < 2.1) - ```bash $ dune exec ./main.exe -Got reply "echo:foo" ++Got reply "echo:foo" ``` This isn't very exciting, so let's add some capabilities to the protocol... @@ -326,33 +313,31 @@ The new `heartbeat_impl` method looks like this: match callback with | None -> Service.fail "No callback parameter!" | Some callback -> - Service.return_lwt @@ fun () -> - Capability.with_ref callback (notify ~msg) + Capability.with_ref callback (notify ~delay msg) ``` Note that all parameters in Cap'n Proto are optional, so we have to check for `callback` not being set (data parameters such as `msg` get a default value from the schema, which is `""` for strings if not set explicitly). -`Service.return_lwt fn` runs `fn ()` and replies to the `heartbeat` call when it finishes. -Here, the whole of the rest of the method is the argument to `return_lwt`, which is a common pattern. +You'll need to add a `~delay` argument to `local` too, to configure the time between messages. `Capability.with_ref x f` calls `f x` and then releases `x` (capabilities are ref-counted). -`notify callback msg` just sends a few messages to `callback` in a loop: +`notify ~delay msg callback` just sends a few messages to `callback` in a loop: ```ocaml -let (>>!=) = Lwt_result.bind (* Return errors *) - -let notify callback ~msg = +let notify ~delay msg callback = let rec loop = function | 0 -> - Lwt.return @@ Ok (Service.Response.create_empty ()) + Service.return_empty () | i -> - Callback.log callback msg >>!= fun () -> - Lwt_unix.sleep 1.0 >>= fun () -> - loop (i - 1) + match Callback.log callback msg with + | Error (`Capnp e) -> Service.error e + | Ok () -> + Eio.Time.Timeout.sleep delay; + loop (i - 1) in loop 3 ``` @@ -379,24 +364,27 @@ In `main.ml`, we can now wrap a regular OCaml function as the callback: ```ocaml -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std + +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg let run_client service = Capability.with_ref (Echo.Callback.local callback_fn) @@ fun callback -> Echo.heartbeat service "foo" callback let () = - Lwt_main.run begin - let service = Echo.local in - run_client service - end + Eio_main.run @@ fun env -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + let service = Echo.local ~delay in + run_client service ``` Step 1: The client creates the callback: @@ -422,12 +410,12 @@ Exercise: implement `Callback.local fn` (hint: it's similar to the original `pin And testing it should give (three times, at one second intervals): - + ```sh $ dune exec -- ./main.exe -Callback got "foo" -Callback got "foo" -Callback got "foo" ++Callback got "foo" ++Callback got "foo" ++Callback got "foo" ``` Note that the client gives the echo service permission to call its callback service by sending a message containing the callback to the service. @@ -446,15 +434,17 @@ Here's the new `main.ml` (the top half is the same as before): ```ocaml -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std + +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg let run_client service = Capability.with_ref (Echo.Callback.local callback_fn) @@ fun callback -> @@ -463,37 +453,40 @@ let run_client service = let secret_key = `Ephemeral let listen_address = `TCP ("127.0.0.1", 7000) -let start_server () = +let start_server ~sw ~delay net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in - let restore = Capnp_rpc_net.Restorer.single service_id Echo.local in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> + let restore = Capnp_rpc_net.Restorer.single service_id (Echo.local ~delay) in + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in Capnp_rpc_unix.Vat.sturdy_uri vat service_id let () = - Lwt_main.run begin - start_server () >>= fun uri -> - Fmt.pr "Connecting to echo service at: %a@." Uri.pp_hum uri; - let client_vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in - Sturdy_ref.with_cap_exn sr run_client - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + let uri = start_server ~sw ~delay env#net in + traceln "Connecting to echo service at: %a" Uri.pp_hum uri; + let client_vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in + Sturdy_ref.with_cap_exn sr run_client ```

-You'll need to edit your `dune` file to add a dependency on `capnp-rpc-unix` in the `(libraries ...` line and also: +You'll need to edit your `dune` file to add a dependencies +on `capnp-rpc-unix` and `mirage-crypto-rng-eio` in the `(libraries ...` line and also: ```sh -$ opam depext -i capnp-rpc-unix +$ opam install capnp-rpc-unix mirage-crypto-rng-eio ``` Running this will give something like: - + ```sh $ dune exec ./main.exe Connecting to echo service at: capnp://sha-256:3Tj5y5Q2qpqN3Sbh0GRPxgORZw98_NtrU2nLI0-Tn6g@127.0.0.1:7000/eBIndzZyoVDxaJdZ8uh_xBx5V1lfXWTJCDX-qEkgNZ4 @@ -548,10 +541,11 @@ In `start_server`: and the name. This means that the ID will be stable as long as the server's key doesn't change. The name used ("main" here) isn't important - it just needs to be unique. -- `let restore = Restorer.single service_id Echo.local` configures a simple "restorer" that - answers requests for `service_id` with our `Echo.local` service. +- `let restore = Capnp_rpc_net.Restorer.single service_id (Echo.local ~delay)` + configures a simple "restorer" that answers requests for `service_id` with + our `Echo.local` service. -- `Capnp_rpc_unix.serve config ~restore` creates the service vat using the +- `Capnp_rpc_unix.serve ~sw ~net ~restore config` creates the service vat using the previous configuration items and starts it listening for incoming connections. - `Capnp_rpc_unix.Vat.sturdy_uri vat service_id` returns a "capnp://" URI for @@ -575,8 +569,7 @@ Edit the `dune` file to build a client and server: ``` (executables (names client server) - (libraries lwt.unix capnp-rpc-lwt logs.fmt capnp-rpc-unix) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc logs.fmt capnp-rpc-unix mirage-crypto-rng-eio)) (rule (targets echo_api.ml echo_api.mli) @@ -588,9 +581,11 @@ Here's a suitable `server.ml`: ```ocaml -open Lwt.Infix +open Eio.Std open Capnp_rpc_net +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 + let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) @@ -598,16 +593,18 @@ let () = let cap_file = "echo.cap" let serve config = - Lwt_main.run begin - let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in - let restore = Restorer.single service_id Echo.local in - Capnp_rpc_unix.serve config ~restore >>= fun vat -> - match Capnp_rpc_unix.Cap_file.save_service vat service_id cap_file with - | Error `Msg m -> failwith m - | Ok () -> - Fmt.pr "Server running. Connect using %S.@." cap_file; - fst @@ Lwt.wait () (* Wait forever *) - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + Switch.run @@ fun sw -> + let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in + let restore = Restorer.single service_id (Echo.local ~delay) in + let vat = Capnp_rpc_unix.serve ~sw ~net:env#net ~restore config in + match Capnp_rpc_unix.Cap_file.save_service vat service_id cap_file with + | Error `Msg m -> failwith m + | Ok () -> + traceln "Server running. Connect using %S." cap_file; + Fiber.await_cancel () open Cmdliner @@ -627,25 +624,27 @@ And here's the corresponding `client.ml`: ```ocaml -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg let run_client service = Capability.with_ref (Echo.Callback.local callback_fn) @@ fun callback -> Echo.heartbeat service "foo" callback let connect uri = - Lwt_main.run begin - let client_vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in - Capnp_rpc_unix.with_cap_exn sr run_client - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let client_vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in + Capnp_rpc_unix.with_cap_exn sr run_client open Cmdliner @@ -756,7 +755,7 @@ We can test it as follows: ```ocaml let run_client service = let logger = Echo.get_logger service in - Echo.Callback.log logger "Message from client" >|= function + match Echo.Callback.log logger "Message from client" with | Ok () -> () | Error (`Capnp err) -> Fmt.epr "Server's logger failed: %a" Capnp_rpc.Error.pp err @@ -771,8 +770,8 @@ This should print (in the server's output) something like: ```sh $ dune exec ./main.exe -[client] Connecting to echo service... -[server] Received "Message from client" ++[client] Connecting to echo service... ++[server] Received "Message from client" ``` In this case, we didn't wait for the `getLogger` call to return before using the logger. @@ -840,32 +839,35 @@ let make_service ~config ~services name = Restorer.Table.add services id service; name, id -let start_server () = +let start_server ~sw net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in let services = Restorer.Table.create make_sturdy in let restore = Restorer.of_table services in let services = List.map (make_service ~config ~services) ["alice"; "bob"] in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in services |> List.iter (fun (name, id) -> let cap_file = name ^ ".cap" in Capnp_rpc_unix.Cap_file.save_service vat id cap_file |> or_fail; Printf.printf "[server] saved %S\n%!" cap_file ) -let run_client cap_file msg = - let vat = Capnp_rpc_unix.client_only_vat () in +let run_client ~net cap_file msg = + Switch.run @@ fun sw -> + let vat = Capnp_rpc_unix.client_only_vat ~sw net in let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in Printf.printf "[client] loaded %S\n%!" cap_file; Sturdy_ref.with_cap_exn sr @@ fun cap -> Logger.log cap msg let () = - Lwt_main.run begin - start_server () >>= fun () -> - run_client "./alice.cap" "Message from Alice" >>= fun () -> - run_client "./bob.cap" "Message from Bob" - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let net = env#net in + start_server ~sw net; + run_client ~net "./alice.cap" "Message from Alice"; + run_client ~net "./bob.cap" "Message from Bob" ``` @@ -903,17 +905,19 @@ We can use the new API like this: ```ocaml let () = - Lwt_main.run begin - start_server () >>= fun root_uri -> - let vat = Capnp_rpc_unix.client_only_vat () in - let root_sr = Capnp_rpc_unix.Vat.import vat root_uri |> or_fail in - Sturdy_ref.with_cap_exn root_sr @@ fun root -> - Logger.log root "Message from Admin" >>= fun () -> - Capability.with_ref (Logger.sub root "alice") @@ fun for_alice -> - Capability.with_ref (Logger.sub root "bob") @@ fun for_bob -> - Logger.log for_alice "Message from Alice" >>= fun () -> - Logger.log for_bob "Message from Bob" - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let net = env#net in + let root_uri = start_server ~sw net in + let vat = Capnp_rpc_unix.client_only_vat ~sw net in + let root_sr = Capnp_rpc_unix.Vat.import vat root_uri |> or_fail in + Sturdy_ref.with_cap_exn root_sr @@ fun root -> + Logger.log root "Message from Admin"; + Capability.with_ref (Logger.sub root "alice") @@ fun for_alice -> + Capability.with_ref (Logger.sub root "bob") @@ fun for_bob -> + Logger.log for_alice "Message from Alice"; + Logger.log for_bob "Message from Bob" ``` @@ -938,13 +942,11 @@ the admin can request the sturdy ref like this: ```ocaml - (* The admin creates a logger for Alice and saves it: *) - Capability.with_ref (Logger.sub root "alice") (fun for_alice -> - Persistence.save_exn for_alice >|= fun uri -> - Capnp_rpc_unix.Cap_file.save_uri uri "alice.cap" |> or_fail - ) >>= fun () -> - (* Alice uses it: *) - run_client "alice.cap" + (* The admin creates a logger for Alice and saves it: *) + let uri = Capability.with_ref (Logger.sub root "alice") Capnp_rpc.Persistence.save_exn in + Capnp_rpc_unix.Cap_file.save_uri uri "alice.cap" |> or_fail; + (* Alice uses it: *) + run_client ~net "alice.cap" ``` If successful, the client can use this sturdy ref to connect directly to the logger in future: @@ -965,7 +967,7 @@ The simplest way to do this is to wrap the `Callback.local` call with `Persisten ```ocaml let rec local ~services sr label = let module Logger = Api.Service.Logger in - Persistence.with_sturdy_ref sr Logger.local @@ object + Capnp_rpc.Persistence.with_sturdy_ref sr Logger.local @@ object ``` Then pass the `services` and `sr` arguments when creating the logger: @@ -1002,7 +1004,7 @@ Here's the interface for a `Db` module that loads and saves loggers: ```ocaml -open Capnp_rpc_lwt +open Capnp_rpc.Std open Capnp_rpc_net include Restorer.LOADER @@ -1010,7 +1012,7 @@ include Restorer.LOADER type loader = [`Logger_beacebd78653e9af] Sturdy_ref.t -> label:string -> Restorer.resolution (** A function to create a new in-memory logger with the given label and sturdy-ref. *) -val create : make_sturdy:(Restorer.Id.t -> Uri.t) -> string -> t * loader Lwt.u +val create : make_sturdy:(Restorer.Id.t -> Uri.t) -> _ Eio.Path.t -> t * loader Eio.Promise.u (** [create ~make_sturdy dir] is a database that persists services in [dir] and a resolver to let you set the loader (we're not ready to set the loader when we create the database). *) @@ -1043,8 +1045,8 @@ We can use this with `File_store` to implement `Db`: ```ocaml -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std open Capnp_rpc_net module File_store = Capnp_rpc_unix.File_store @@ -1054,7 +1056,7 @@ type loader = [`Logger_beacebd78653e9af] Sturdy_ref.t -> label:string -> Restore type t = { store : Store.Reader.SavedService.struct_t File_store.t; - loader : loader Lwt.t; + loader : loader Promise.t; make_sturdy : Restorer.Id.t -> Uri.t; } @@ -1077,17 +1079,18 @@ let save_new t ~label = let load t sr digest = match File_store.load t.store ~digest with - | None -> Lwt.return Restorer.unknown_service_id + | None -> Restorer.unknown_service_id | Some saved_service -> let logger = Store.Reader.SavedService.logger_get saved_service in let label = Store.Reader.SavedLogger.label_get logger in - let sr = Capnp_rpc_lwt.Sturdy_ref.cast sr in - t.loader >|= fun loader -> + let sr = Capnp_rpc.Sturdy_ref.cast sr in + let loader = Promise.await t.loader in loader sr ~label let create ~make_sturdy dir = - let loader, set_loader = Lwt.wait () in - if not (Sys.file_exists dir) then Unix.mkdir dir 0o755; + let loader, set_loader = Promise.create () in + if not (Eio.Path.is_directory dir) then + Eio.Path.mkdir dir ~perm:0o755; let store = File_store.create dir in {store; loader; make_sturdy}, set_loader ``` @@ -1100,33 +1103,35 @@ The main `start_server` function then uses `Db` to create the table: ```ocaml let serve config = - Lwt_main.run begin - (* Create the on-disk store *) - let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in - let db, set_loader = Db.create ~make_sturdy "./store" in - (* Create the restorer *) - let services = Restorer.Table.of_loader (module Db) db in - let restore = Restorer.of_table services in - (* Add the root service *) - let persist_new ~label = - let id = Db.save_new db ~label in - Capnp_rpc_net.Restorer.restore restore id - in - let root_id = Capnp_rpc_unix.Vat_config.derived_id config "root" in - let root = - let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services root_id in - Logger.local ~persist_new sr "root" - in - Restorer.Table.add services root_id root; - (* Tell the database how to restore saved loggers *) - Lwt.wakeup set_loader (fun sr ~label -> Restorer.grant @@ Logger.local ~persist_new sr label); - (* Run the server *) - Capnp_rpc_unix.serve config ~restore >>= fun _vat -> - let uri = Capnp_rpc_unix.Vat_config.sturdy_uri config root_id in - Capnp_rpc_unix.Cap_file.save_uri uri "admin.cap" |> or_fail; - print_endline "Wrote admin.cap"; - fst @@ Lwt.wait () (* Wait forever *) - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + (* Create the on-disk store *) + let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in + let db, set_loader = Db.create ~make_sturdy (env#cwd / "store") in + (* Create the restorer *) + let services = Restorer.Table.of_loader ~sw (module Db) db in + Switch.on_release sw (fun () -> Restorer.Table.clear services); + let restore = Restorer.of_table services in + (* Add the root service *) + let persist_new ~label = + let id = Db.save_new db ~label in + Capnp_rpc_net.Restorer.restore restore id + in + let root_id = Capnp_rpc_unix.Vat_config.derived_id config "root" in + let root = + let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services root_id in + Logger.local ~persist_new sr "root" + in + Restorer.Table.add services root_id root; + (* Tell the database how to restore saved loggers *) + Promise.resolve set_loader (fun sr ~label -> Restorer.grant @@ Logger.local ~persist_new sr label); + (* Run the server *) + let _vat = Capnp_rpc_unix.serve ~sw ~net:env#net ~restore config in + let uri = Capnp_rpc_unix.Vat_config.sturdy_uri config root_id in + Capnp_rpc_unix.Cap_file.save_uri uri "admin.cap" |> or_fail; + print_endline "Wrote admin.cap"; + Fiber.await_cancel () ``` The server implementation of the `sub` method gets the label from the parameters @@ -1139,14 +1144,13 @@ and uses `persist_new` to save the new logger to the database: let sub_label = Params.label_get params in release_param_caps (); let label = Printf.sprintf "%s/%s" label sub_label in - Service.return_lwt @@ fun () -> - persist_new ~label >|= function - | Error e -> Error (`Capnp (`Exception e)) + match persist_new ~label with + | Error e -> Service.error (`Exception e) | Ok logger -> let response, results = Service.Response.create Results.init_pointer in Results.logger_set results (Some logger); Capability.dec_ref logger; - Ok response + Service.return response ``` @@ -1175,7 +1179,7 @@ You should find that the loggers now persist even if the service is restarted. ## Further reading -* [`capnp_rpc_lwt.mli`](capnp-rpc-lwt/capnp_rpc_lwt.mli) and [`s.ml`](capnp-rpc-lwt/s.ml) describe the OCaml API. +* [`capnp_rpc.mli`](capnp-rpc/capnp_rpc.mli) and [`s.ml`](capnp-rpc/s.ml) describe the OCaml API. * [Cap'n Proto schema file format][schema] shows how to build more complex structures, and the "Evolving Your Protocol" section explains how to change the schema without breaking backwards compatibility. * is a good place to ask questions (tag them as "capnp"). * [The capnp-ocaml site][capnp-ocaml] explains how to read and build more complex types using the OCaml interface. @@ -1260,12 +1264,12 @@ The solution here is to construct `Frontend` with a *promise* for the sturdy ref ```ocaml -let run_frontend backend_uri = - let backend_promise, resolver = Lwt.wait () in +let run_frontend ~sw ~net backend_uri = + let backend_promise, resolver = Promise.create () in let frontend = Frontend.make backend_promise in let restore = Restorer.single id frontend in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> - Lwt.wakeup resolver (Capnp_rpc_unix.Vat.import_exn vat backend_uri) + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in + Promise.resolve resolver (Capnp_rpc_unix.Vat.import_exn vat backend_uri) ``` ### How can I release other resources when my service is released? @@ -1396,7 +1400,7 @@ like regular OCaml method calls, but also over the network to remote objects. The network is made up of communicating "vats" of objects. You can think of a Unix process as a single vat. The vats are peers - there is no difference between a "client" and a "server" at the protocol level. -However, some vats may not be listening for incoming network connections, and you might like to think of such vats as clients. +However, some vats may not be listening for incoming network connections, and you might like to think of such vats as clients. When a connection is established between two vats, each can choose to ask the other for access to some service. Services are usually identified by a long random secret (a "Swiss number") so that only authorised clients can get access to them. @@ -1421,7 +1425,6 @@ To build: git clone https://github.com/mirage/capnp-rpc.git cd capnp-rpc opam pin add -ny . - opam depext -t capnp-rpc-unix capnp-rpc-mirage opam install --deps-only -t . make test @@ -1429,7 +1432,7 @@ If you have trouble building, you can use the Dockerfile shown in the CI logs (c ### Testing -Running `make test` will run through the tests in `test-lwt/test.ml`, which run some in-process examples. +Running `make test` will run through the tests in the `test` directory, which run some in-process examples. The calculator example can also be run across two Unix processes. @@ -1457,7 +1460,8 @@ In that case, the client URL would be `capnp://insecure@/tmp/calc.socket`. ### Fuzzing -Running `make fuzz` will run the AFL fuzz tester. You will need to use a version of the OCaml compiler with AFL support (e.g. `opam sw 4.04.0+afl`). +Running `make fuzz` will run the AFL fuzz tester. You will need to use a version of the OCaml compiler with AFL support +(e.g. `opam switch create 5.2-afl ocaml-variants.5.2.0+options ocaml-option-afl`). The fuzzing code is in the `fuzz` directory. The tests set up some vats in a single process and then have them perform operations based on input from the fuzzer. @@ -1490,6 +1494,7 @@ We should also test with some malicious vats (that don't follow the protocol cor [pycapnp]: http://jparyani.github.io/pycapnp/ [Persistence API]: https://github.com/capnproto/capnproto/blob/master/c%2B%2B/src/capnp/persistent.capnp [ocaml-ci]: https://github.com/ocurrent/ocaml-ci +[ocluster]: https://github.com/ocurrent/ocluster [api]: https://mirage.github.io/capnp-rpc/ [NETWORK]: https://mirage.github.io/capnp-rpc/capnp-rpc-net/Capnp_rpc_net/S/module-type-NETWORK/index.html [calc_direct.ml]: ./test-bin/calc_direct.ml diff --git a/capnp-rpc-lwt.opam b/capnp-rpc-lwt.opam index 6fd88eee7..0cc4893c5 100644 --- a/capnp-rpc-lwt.opam +++ b/capnp-rpc-lwt.opam @@ -2,8 +2,7 @@ opam-version: "2.0" synopsis: "Cap'n Proto is a capability-based RPC system with bindings for many languages" description: """ -This package provides a version of the Cap'n Proto RPC system using the Cap'n -Proto serialisation format and Lwt for concurrency.""" +This deprecated package provides Lwt shims around capnp-rpc, to ease the transition.""" maintainer: "Thomas Leonard " authors: "Thomas Leonard " license: "Apache-2.0" @@ -11,17 +10,10 @@ homepage: "https://github.com/mirage/capnp-rpc" bug-reports: "https://github.com/mirage/capnp-rpc/issues" doc: "https://mirage.github.io/capnp-rpc/" depends: [ - "ocaml" {>= "4.08.0"} - "conf-capnproto" {build} + "ocaml" {>= "5.1"} "capnp" {>= "3.4.0"} - "capnp-rpc" {= version} - "stdint" {>= "0.6.0"} - "lwt" {>= "5.6.1"} - "astring" - "fmt" {>= "0.8.7"} - "logs" - "asetmap" - "uri" {>= "1.6.0"} + "capnp-rpc" {>= version} + "lwt_eio" {>= "0.5.1"} "dune" {>= "3.0"} ] build: [ diff --git a/capnp-rpc-lwt/capability.ml b/capnp-rpc-lwt/capability.ml index 1492cc0a8..ed7980bdb 100644 --- a/capnp-rpc-lwt/capability.ml +++ b/capnp-rpc-lwt/capability.ml @@ -1,108 +1,26 @@ -open Lwt.Infix -open Capnp_core - -module Log = Capnp_rpc.Debug.Log -module StructStorage = Capnp.BytesMessage.StructStorage - -type 'a t = Core_types.cap -type 'a capability_t = 'a t -type ('t, 'a, 'b) method_t = ('t, 'a, 'b) Capnp.RPC.MethodID.t - -module Request = Request +include Capnp_rpc.Capability -let inc_ref = Core_types.inc_ref -let dec_ref = Core_types.dec_ref +open Lwt.Infix let with_ref t fn = Lwt.finalize (fun () -> fn t) (fun () -> dec_ref t; Lwt.return_unit) -let pp f x = x#pp f - -let broken = Core_types.broken_cap -let when_broken = Core_types.when_broken -let when_released (x:Core_types.cap) f = x#when_released f -let problem x = x#problem - -let wait_until_settled (x : _ t) = - let result, set_result = Lwt.wait () in - let rec aux x = - if x#blocker = None then ( - Lwt.wakeup set_result () - ) else ( - x#when_more_resolved (fun x -> - Core_types.dec_ref x; - aux x - ) - ) - in - aux x; - result - let await_settled t = - wait_until_settled t >|= fun () -> - match problem t with - | None -> Ok () - | Some ex -> Error ex + Lwt_eio.run_eio @@ fun () -> await_settled t let await_settled_exn t = - wait_until_settled t >|= fun () -> - match problem t with - | None -> () - | Some e -> Fmt.failwith "%a" Capnp_rpc.Exception.pp e + Lwt_eio.run_eio @@ fun () -> await_settled_exn t -let equal a b = - match a#blocker, b#blocker with - | None, None -> - let a = a#shortest in - let b = b#shortest in - begin match a#problem, b#problem with - | None, None -> Ok (a = b) - | Some a, Some b -> Ok (a = b) - | _ -> Ok false - end - | _ -> Error `Unsettled - -let call (target : 't capability_t) (m : ('t, 'a, 'b) method_t) (req : 'a Request.t) = - Log.debug (fun f -> f "Calling %a" Capnp.RPC.MethodID.pp m); - let msg = Request.finish m req in - let results, resolver = Local_struct_promise.make () in - target#call resolver msg; - results - -let call_and_wait cap (m : ('t, 'a, 'b StructStorage.reader_t) method_t) req = - let p, r = Lwt.task () in - let result = call cap m req in - let finish = lazy (Core_types.dec_ref result) in - Lwt.on_cancel p (fun () -> Lazy.force finish); - result#when_resolved (function - | Error e -> Lwt.wakeup r (Error (`Capnp e)) - | Ok resp -> - Lazy.force finish; - let payload = Msg.Response.readable resp in - let release_response_caps () = Core_types.Response_payload.release resp in - let contents = Schema.Reader.Payload.content_get payload |> Schema.Reader.of_pointer in - Lwt.wakeup r @@ Ok (contents, release_response_caps) - ); - p +let call_and_wait cap m req = + Lwt_eio.run_eio @@ fun () -> call_and_wait cap m req let call_for_value cap m req = - call_and_wait cap m req >|= function - | Error _ as response -> response - | Ok (response, release_response_caps) -> - release_response_caps (); - Ok response + Lwt_eio.run_eio @@ fun () -> call_for_value cap m req let call_for_value_exn cap m req = - call_for_value cap m req >>= function - | Ok x -> Lwt.return x - | Error (`Capnp e) -> - Log.debug (fun f -> f "Error calling %t(%a): %a" - cap#pp - Capnp.RPC.MethodID.pp m - Capnp_rpc.Error.pp e); - Fmt.failwith "%a: %a" Capnp.RPC.MethodID.pp m Capnp_rpc.Error.pp e + Lwt_eio.run_eio @@ fun () -> call_for_value_exn cap m req let call_for_unit cap m req = call_for_value cap m req >|= function @@ -110,19 +28,3 @@ let call_for_unit cap m req = | Error _ as e -> e let call_for_unit_exn cap m req = call_for_value_exn cap m req >|= ignore - -let call_for_caps cap m req fn = - let q = call cap m req in - match fn q with - | r -> Core_types.dec_ref q; r - | exception ex -> Core_types.dec_ref q; raise ex - -type 'a resolver = Cap_proxy.resolver_cap - -let promise () = - let cap = Cap_proxy.local_promise () in - (cap :> Core_types.cap), (cap :> 'a resolver) - -let resolve_ok r x = r#resolve x - -let resolve_exn r ex = r#resolve (Core_types.broken_cap ex) diff --git a/capnp-rpc-lwt/capnp_core.ml b/capnp-rpc-lwt/capnp_core.ml deleted file mode 100644 index e859526e1..000000000 --- a/capnp-rpc-lwt/capnp_core.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Lwt.Infix - -module Capnp_content = struct - include Msg - - let ref_leak_detected fn = - Lwt.async (fun () -> - Lwt.pause () >|= fun () -> - fn () - ) -end - -module Core_types = Capnp_rpc.Core_types(Capnp_content) - -module Local_struct_promise = Capnp_rpc.Local_struct_promise.Make(Core_types) -module Cap_proxy = Capnp_rpc.Cap_proxy.Make(Core_types) - -module type ENDPOINT = Capnp_rpc.Message_types.ENDPOINT with - module Core_types = Core_types - -class type sturdy_ref = object - method connect : (Core_types.cap, Capnp_rpc.Exception.t) result Lwt.t - method to_uri_with_secrets : Uri.t -end diff --git a/capnp-rpc-lwt/capnp_rpc_lwt.ml b/capnp-rpc-lwt/capnp_rpc_lwt.ml index c1da39223..a42ca692b 100644 --- a/capnp-rpc-lwt/capnp_rpc_lwt.ml +++ b/capnp-rpc-lwt/capnp_rpc_lwt.ml @@ -1,74 +1,16 @@ -open Capnp_core - -include Capnp.Message.BytesMessage - -module Log = Capnp_rpc.Debug.Log -module RO_array = Capnp_rpc.RO_array - module Capability = Capability - -module StructRef = struct - type 'a t = Core_types.struct_ref - - let inc_ref = Core_types.inc_ref - let dec_ref = Core_types.dec_ref -end - module Sturdy_ref = Sturdy_ref - -module Untyped = struct - let struct_field t i = - (* todo: would be better to have a separate type for this *) - object (_ : Core_types.struct_ref) - method cap path = t#cap (Xform.Field i :: path) - method when_resolved _ = failwith "Can't use when_resolved on a sub-struct" - method response = failwith "Can't use response on a sub-struct" - method update_rc = failwith "Can't use rec-counts on a sub-struct" - method sealed_dispatch _ = None - method pp f = Fmt.pf f "pointer %d in %t" i t#pp - method blocker = failwith "struct_field: blocker" - method check_invariants = () - end - - let capability_field t f = t#cap [Xform.Field f] - - let local = Service.local - - type abstract_method_t = Service.abstract_method_t - - let abstract_method x req release = - x (StructStorage.cast_reader req) release - - let get_cap a i = - Core_types.Attachments.cap (Stdint.Uint32.to_int i) (Msg.unwrap_attachments a) - - let add_cap a cap = - Core_types.Attachments.add_cap (Msg.unwrap_attachments a) cap |> Stdint.Uint32.of_int - - let clear_cap a i = - Core_types.Attachments.clear_cap (Msg.unwrap_attachments a) (Stdint.Uint32.to_int i) - - let unknown_interface ~interface_id _req release_params = - release_params (); - Core_types.fail ~ty:`Unimplemented "Unknown interface %a" Stdint.Uint64.printer interface_id - - let unknown_method ~interface_id ~method_id _req release_params = - release_params (); - Core_types.fail ~ty:`Unimplemented "Unknown method %a.%d" Stdint.Uint64.printer interface_id method_id - - class type generic_service = Service.generic -end - module Service = Service +module Persistence = Persistence +open Capnp_rpc +module Segment = Segment +module Message = Message +module Slice = Slice +module StructStorage = StructStorage +module ListStorage = ListStorage +module Object = Object +module StructRef = StructRef +module Untyped = Untyped module Private = Private - -module Cast = struct - let cap_of_raw x = x - let cap_to_raw x = x - - let sturdy_of_raw x = x - let sturdy_to_raw x = x -end - -module Persistence = Persistence +module Cast = Cast diff --git a/capnp-rpc-lwt/capnp_rpc_lwt.mli b/capnp-rpc-lwt/capnp_rpc_lwt.mli index cce83768b..5d30a59e6 100644 --- a/capnp-rpc-lwt/capnp_rpc_lwt.mli +++ b/capnp-rpc-lwt/capnp_rpc_lwt.mli @@ -2,7 +2,12 @@ open Capnp.RPC -include (module type of Capnp.BytesMessage) +module Segment = Capnp_rpc.Segment +module Message = Capnp_rpc.Message +module Slice = Capnp_rpc.Slice +module StructStorage = Capnp_rpc.StructStorage +module ListStorage = Capnp_rpc.ListStorage +module Object = Capnp_rpc.Object module StructRef : sig (** A promise for a response structure. @@ -10,7 +15,7 @@ module StructRef : sig a promise for a capability inside the promise, and then pipeline messages to that promise without waiting for the response struct to arrive. *) - type 'a t + type 'a t = 'a Capnp_rpc.StructRef.t (** An ['a t] is a reference to a response message (that may not have arrived yet) with content type ['a]. *) @@ -30,7 +35,7 @@ module Capability : sig You can invoke methods on a capability even while it is still only a promise. *) - type +'a t + type +'a t = 'a Capnp_rpc.Capability.t (** An ['a t] is a capability reference to a service of type ['a]. *) val broken : Capnp_rpc.Exception.t -> 'a t @@ -59,7 +64,7 @@ module Capability : sig (** [await_settled t] resolves once [t] is a "settled" (non-promise) reference. If [t] is a near, far or broken reference, this returns immediately. If it is currently a local or remote promise, it waits until it isn't. - [wait_until_settled] takes ownership of [t] until it returns (you must not + [until_settled] takes ownership of [t] until it returns (you must not [dec_ref] it before then). @return [Ok ()] on success, or [Error _] if [t] failed. @since 1.2 *) @@ -68,9 +73,6 @@ module Capability : sig (** Like [await_settled], but raises an exception on error. @since 1.2 *) - val wait_until_settled : 'a t -> unit Lwt.t - [@@deprecated "Use await_settled instead."] - val equal : 'a t -> 'a t -> (bool, [`Unsettled]) result (** [equal a b] indicates whether [a] and [b] designate the same settled service. Returns [Error `Unsettled] if [a] or [b] is still a promise (and they therefore @@ -95,7 +97,7 @@ module Capability : sig when you send a message, but you might need it if you decide to abort. *) end - val call : 't t -> ('t, 'a, 'b) MethodID.t -> 'a Request.t -> 'b StructRef.t + val call : 't t -> ('t, 'a, 'b StructStorage.reader_t) MethodID.t -> 'a Request.t -> 'b StructRef.t (** [call target m req] invokes [target#m req] and returns a promise for the result. Messages may be sent to the capabilities that will be in the result before the result arrives - they will be pipelined to the service @@ -174,7 +176,7 @@ module Capability : sig end module Sturdy_ref : sig - type +'a t + type +'a t = 'a Capnp_rpc.Sturdy_ref.t (** An off-line (persistent) capability reference. A sturdy ref contains all the information necessary to get a live reference to a service: @@ -271,44 +273,9 @@ end (**/**) -module Untyped : sig - (** This module is only for use by the code generated by the capnp-ocaml - schema compiler. The generated code provides type-safe wrappers for - everything here. *) - - type abstract_method_t - - val abstract_method : ('a StructStorage.reader_t, 'b) Service.method_t -> abstract_method_t - - val struct_field : 'a StructRef.t -> int -> 'b StructRef.t - - val capability_field : 'a StructRef.t -> int -> 'b Capability.t - - class type generic_service = object - method dispatch : interface_id:Uint64.t -> method_id:int -> abstract_method_t - method release : unit - method pp : Format.formatter -> unit - end - - val local : #generic_service -> 'a Capability.t - - val get_cap : Capnp.MessageSig.attachments -> Uint32.t -> _ Capability.t - val add_cap : Capnp.MessageSig.attachments -> _ Capability.t -> Uint32.t - val clear_cap : Capnp.MessageSig.attachments -> Uint32.t -> unit - - val unknown_interface : interface_id:Uint64.t -> abstract_method_t - val unknown_method : interface_id:Uint64.t -> method_id:int -> abstract_method_t -end - -module Private = Private - -module Cast : sig - val cap_of_raw : Capnp_core.Core_types.cap -> 'a Capability.t - val cap_to_raw : 'a Capability.t -> Capnp_core.Core_types.cap - - val sturdy_of_raw : Capnp_core.sturdy_ref -> 'a Sturdy_ref.t - val sturdy_to_raw : 'a Sturdy_ref.t -> Capnp_core.sturdy_ref -end +module Untyped = Capnp_rpc.Untyped +module Private = Capnp_rpc.Private +module Cast = Capnp_rpc.Cast (**/**) diff --git a/capnp-rpc-lwt/dune b/capnp-rpc-lwt/dune index bf31965e4..b07dfc1e0 100644 --- a/capnp-rpc-lwt/dune +++ b/capnp-rpc-lwt/dune @@ -1,16 +1,4 @@ (library (name capnp_rpc_lwt) (public_name capnp-rpc-lwt) - (ocamlc_flags :standard -w -55-53) - (ocamlopt_flags :standard -w -55-53) - (libraries astring capnp capnp-rpc fmt logs lwt uri)) - -(rule - (targets rpc_schema.ml rpc_schema.mli) - (deps rpc_schema.capnp) - (action (run capnp compile -o %{bin:capnpc-ocaml} %{deps}))) - -(rule - (targets persistent.ml persistent.mli) - (deps persistent.capnp) - (action (run capnp compile -o %{bin:capnpc-ocaml} %{deps}))) + (libraries capnp-rpc lwt_eio)) diff --git a/capnp-rpc-lwt/persistence.ml b/capnp-rpc-lwt/persistence.ml index f01b50e60..ee0643be3 100644 --- a/capnp-rpc-lwt/persistence.ml +++ b/capnp-rpc-lwt/persistence.ml @@ -1,54 +1,20 @@ open Lwt.Infix -module Api = Persistent.Make(Capnp.BytesMessage) - class type ['a] persistent = object method save : ('a Sturdy_ref.t, Capnp_rpc.Exception.t) result Lwt.t end -let with_persistence - (persistent:'b #persistent) - (_:(#Service.generic as 'a) -> 'b Capability.t) - (impl : 'a) = - (* We ignore the second argument. It's just to force the user to prove that [impl] - really does have type ['a]. *) - let dispatch_persistent method_id _params release_params = - if method_id = Capnp.RPC.MethodID.method_id Api.Client.Persistent.Save.method_id then ( - let open Api.Service.Persistent.Save in - release_params (); - Service.return_lwt @@ fun () -> - persistent#save >|= function - | Error e -> Error (`Capnp (`Exception e)) - | Ok sr -> - let resp, results = Service.Response.create Results.init_pointer in - Sturdy_ref.builder Results.sturdy_ref_get results sr; - Ok resp - ) else ( - release_params (); - Service.fail ~ty:`Unimplemented "Unknown persistence method %d" method_id - ) - in - let wrapper = object (_ : #Service.generic) - method release = impl#release - method pp = impl#pp - method dispatch ~interface_id ~method_id = - if interface_id = Api.Service.Persistent.interface_id then dispatch_persistent method_id - else impl#dispatch ~interface_id ~method_id +let with_persistence persistent ty obj = + let wrapped = object + method save = Lwt_eio.run_lwt (fun () -> persistent#save) end in - Service.local wrapper + Capnp_rpc.Persistence.with_persistence wrapped ty obj -let with_sturdy_ref sr local impl = - let persistent = object - method save = Lwt.return (Ok sr) - end in - with_persistence persistent local impl +let with_sturdy_ref = Capnp_rpc.Persistence.with_sturdy_ref let save cap = - let open Api.Client.Persistent.Save in - let request = Capability.Request.create_no_args () in - Capability.call_for_value cap method_id request >|= function - | Error _ as e -> e - | Ok response -> Ok (Sturdy_ref.reader Results.sturdy_ref_get response) + Lwt_eio.run_eio @@ fun () -> + Capnp_rpc.Persistence.save cap let save_exn cap = save cap >>= function diff --git a/capnp-rpc-lwt/service.ml b/capnp-rpc-lwt/service.ml index 1bb0ddcdf..202dfb191 100644 --- a/capnp-rpc-lwt/service.ml +++ b/capnp-rpc-lwt/service.ml @@ -1,86 +1,15 @@ -open Capnp_core open Lwt.Infix -module Log = Capnp_rpc.Debug.Log - -module Response = Response -module RO_array = Capnp_rpc.RO_array - -type abstract_response_promise = Core_types.struct_ref - -type abstract - -type abstract_method_t = - abstract Schema.reader_t -> (unit -> unit) -> abstract_response_promise - -type 'a response_promise = abstract_response_promise -type ('a, 'b) method_t = 'a -> (unit -> unit) -> Core_types.struct_ref - -let pp_method = Capnp.RPC.Registry.pp_method - -class type generic = object - method dispatch : interface_id:Stdint.Uint64.t -> method_id:int -> abstract_method_t - method release : unit - method pp : Format.formatter -> unit -end - -let local (s:#generic) = - object (_ : Core_types.cap) - inherit Core_types.service as super - - method! pp f = Fmt.pf f "%t(%t)" s#pp super#pp_refcount - - method! private release = - super#release; - s#release - - method call results msg = - let open Schema.Reader in - let call = Msg.Request.readable msg in - let interface_id = Call.interface_id_get call in - let method_id = Call.method_id_get call in - Log.debug (fun f -> f "Invoking local method %a" pp_method (interface_id, method_id)); - let p = Call.params_get call in - let m : abstract_method_t = s#dispatch ~interface_id ~method_id in - let release_params () = Core_types.Request_payload.release msg in - let contents : abstract Schema.reader_t = - Payload.content_get p |> Schema.ReaderOps.deref_opt_struct_pointer |> Schema.ReaderOps.cast_struct in - match m contents release_params with - | r -> results#resolve r - | exception ex -> - release_params (); - Log.warn (fun f -> f "Uncaught exception handling %a: %a" pp_method (interface_id, method_id) Fmt.exn ex); - Core_types.resolve_payload results - (Error (Capnp_rpc.Error.exn "Internal error from %a" pp_method (interface_id, method_id))) - end - -(* The simple case for returning a message (rather than another value). *) -let return resp = - Core_types.return @@ Response.finish resp - -let return_empty () = - return @@ Response.create_empty () +include Capnp_rpc.Service (* A convenient way to implement a simple blocking local function, where pipelining is not supported (messages sent to the result promise will be queued up at this host until it returns). *) let return_lwt fn = - let result, resolver = Local_struct_promise.make () in - Lwt.async (fun () -> - Lwt.catch (fun () -> - fn () >|= function - | Ok resp -> Core_types.resolve_ok resolver @@ Response.finish resp; - | Error (`Capnp e) -> Core_types.resolve_payload resolver (Error e) - ) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception: %a" Fmt.exn ex); - Core_types.resolve_exn resolver @@ Capnp_rpc.Exception.v "Internal error"; - Lwt.return_unit - ); - ); - result - -let fail = Core_types.fail + Lwt_eio.run_lwt @@ fun () -> + fn () >|= function + | Ok resp -> return resp + | Error (`Capnp e) -> error e let fail_lwt ?ty fmt = fmt |> Fmt.kstr @@ fun msg -> diff --git a/capnp-rpc-lwt/sturdy_ref.ml b/capnp-rpc-lwt/sturdy_ref.ml index cc2a70b1d..c68199e29 100644 --- a/capnp-rpc-lwt/sturdy_ref.ml +++ b/capnp-rpc-lwt/sturdy_ref.ml @@ -1,22 +1,18 @@ +include Capnp_rpc.Sturdy_ref + open Lwt.Infix -class type [+'a] t = Capnp_core.sturdy_ref +type 'a t = 'a Capnp_rpc.Sturdy_ref.t -let connect t = t#connect +let connect t = + Lwt_eio.run_eio @@ fun () -> + connect t let connect_exn t = connect t >>= function | Ok x -> Lwt.return x | Error e -> Lwt.fail_with (Fmt.to_to_string Capnp_rpc.Exception.pp e) -let reader fn s = - fn s |> Schema.ReaderOps.string_of_pointer |> Uri.of_string - -let builder fn (s : 'a Capnp.BytesMessage.StructStorage.builder_t) (sr : 'a t) = - sr#to_uri_with_secrets |> Uri.to_string |> Schema.BuilderOps.write_string (fn s) - -let cast t = t - let with_cap t f = connect t >>= function | Ok x -> Capability.with_ref x f diff --git a/capnp-rpc-net.opam b/capnp-rpc-net.opam index 6062d723c..209e88d2e 100644 --- a/capnp-rpc-net.opam +++ b/capnp-rpc-net.opam @@ -13,24 +13,20 @@ doc: "https://mirage.github.io/capnp-rpc/" depends: [ "ocaml" {>= "4.08.0"} "conf-capnproto" {build} - "capnp" {>= "3.4.0"} + "capnp" {>= "3.6.0"} "capnp-rpc" {= version} - "capnp-rpc-lwt" {= version} "astring" "fmt" {>= "0.8.7"} "logs" - "asetmap" "cstruct" {>= "6.0.0"} - "mirage-flow" {>= "4.0.2"} - "tls" {>= "1.0.2"} + "tls-eio" {>= "1.0.2"} "base64" {>= "3.0.0"} "uri" {>= "1.6.0"} "ptime" "prometheus" {>= "0.5"} "asn1-combinators" {>= "0.2.0"} "x509" {>= "1.0.3"} - "tls-mirage" - "dune" {>= "3.0"} + "dune" {>= "3.16"} "mirage-crypto" {>= "1.1.0"} "mirage-crypto-rng" {>= "1.1.0"} ] diff --git a/capnp-rpc-net/auth.ml b/capnp-rpc-net/auth.ml index 59e7dcbc9..d01b6a34e 100644 --- a/capnp-rpc-net/auth.ml +++ b/capnp-rpc-net/auth.ml @@ -1,5 +1,3 @@ -open Asetmap - module Log = Capnp_rpc.Debug.Log let default_rsa_key_bits = 2048 diff --git a/capnp-rpc-net/auth.mli b/capnp-rpc-net/auth.mli index 59f820771..3d4b2adbe 100644 --- a/capnp-rpc-net/auth.mli +++ b/capnp-rpc-net/auth.mli @@ -1,5 +1,3 @@ -open Asetmap - (** Vat-level authentication and encryption. Unless your network provides a secure mechanism for establishing connections @@ -55,9 +53,8 @@ module Secret_key : sig val generate : unit -> t (** [generate ()] is a fresh secret key. - You must call the relevant entropy initialization function - (e.g. {!Mirage_crypto_rng_lwt.initialize}) before using this, or it - will raise an error if you forget. *) + You must use e.g. {!Mirage_crypto_rng_eio.run} to set a source of + randomness before using this (it will raise an error if you forget). *) val digest : ?hash:hash -> t -> Digest.t (** [digest ~hash t] is the digest of [t]'s public key, using [hash]. *) diff --git a/capnp-rpc-net/capTP_capnp.ml b/capnp-rpc-net/capTP_capnp.ml index e879ea63b..cd73c2798 100644 --- a/capnp-rpc-net/capTP_capnp.ml +++ b/capnp-rpc-net/capTP_capnp.ml @@ -1,201 +1,122 @@ -open Capnp_rpc_lwt -open Lwt.Infix - -module Metrics = struct - open Prometheus - - let namespace = "capnp" - - let subsystem = "net" - - let connections = - let help = "Number of live capnp-rpc connections" in - Gauge.v ~help ~namespace ~subsystem "connections" - - let messages_inbound_received_total = - let help = "Total number of messages received" in - Counter.v ~help ~namespace ~subsystem "messages_inbound_received_total" - - let messages_outbound_enqueued_total = - let help = "Total number of messages enqueued to be transmitted" in - Counter.v ~help ~namespace ~subsystem "messages_outbound_enqueued_total" - - let messages_outbound_sent_total = - let help = "Total number of messages transmitted" in - Counter.v ~help ~namespace ~subsystem "messages_outbound_sent_total" - - let messages_outbound_dropped_total = - let help = "Total number of messages lost due to disconnections" in - Counter.v ~help ~namespace ~subsystem "messages_outbound_dropped_total" -end +open Eio.Std module Log = Capnp_rpc.Debug.Log -module Builder = Private.Schema.Builder -module Reader = Private.Schema.Reader +module Builder = Capnp_rpc.Private.Schema.Builder +module Reader = Capnp_rpc.Private.Schema.Reader -module Table_types = Capnp_rpc.Message_types.Table_types ( ) +module Table_types = Capnp_rpc_proto.Message_types.Table_types ( ) module Make (Network : S.NETWORK) = struct - module Endpoint_types = Capnp_rpc.Message_types.Endpoint(Private.Capnp_core.Core_types)(Network.Types)(Table_types) - module Conn = Capnp_rpc.CapTP.Make(Endpoint_types) + module Endpoint_types = Capnp_rpc_proto.Message_types.Endpoint(Capnp_rpc.Private.Capnp_core.Core_types)(Network.Types)(Table_types) + module Conn = Capnp_rpc_proto.CapTP.Make(Endpoint_types) module Parse = Parse.Make(Endpoint_types)(Network) module Serialise = Serialise.Make(Endpoint_types) type t = { endpoint : Endpoint.t; conn : Conn.t; - xmit_queue : Capnp.Message.rw Capnp.BytesMessage.Message.t Queue.t; mutable disconnecting : bool; } - let bootstrap t id = Conn.bootstrap t.conn id |> Cast.cap_of_raw - - let async_tagged label fn = - Lwt.async - (fun () -> - Lwt.catch fn - (fun ex -> - Log.warn (fun f -> f "Uncaught async exception in %S: %a" label Fmt.exn ex); - Lwt.return_unit - ) - ) + let bootstrap t id = Conn.bootstrap t.conn id |> Capnp_rpc.Cast.cap_of_raw let pp_msg f call = let open Reader in - let call = Private.Msg.Request.readable call in + let call = Capnp_rpc.Private.Msg.Request.readable call in let interface_id = Call.interface_id_get call in let method_id = Call.method_id_get call in Capnp.RPC.Registry.pp_method f (interface_id, method_id) let tags t = Conn.tags t.conn - let drop_queue q = - Prometheus.Counter.inc Metrics.messages_outbound_dropped_total (float_of_int (Queue.length q)); - Queue.clear q - - (* [flush ~xmit_queue endpoint] writes each message in the queue until it is empty. - Invariant: - Whenever Lwt blocks or switches threads, a flush thread is running iff the - queue is non-empty. *) - let rec flush ~xmit_queue endpoint = - (* We keep the item on the queue until it is transmitted, as the queue state - tells us whether there is a [flush] currently running. *) - let next = Queue.peek xmit_queue in - Endpoint.send endpoint next >>= function - | Error `Closed -> - Endpoint.disconnect endpoint >|= fun () -> (* We'll read a close soon *) - drop_queue xmit_queue - | Error e -> - Log.warn (fun f -> f "Error sending messages: %a (will shutdown connection)" Endpoint.pp_error e); - Endpoint.disconnect endpoint >|= fun () -> - drop_queue xmit_queue - | Ok () -> - Prometheus.Counter.inc_one Metrics.messages_outbound_sent_total; - ignore (Queue.pop xmit_queue); - if not (Queue.is_empty xmit_queue) then - flush ~xmit_queue endpoint - else (* queue is empty and flush thread is done *) - Lwt.return_unit - - (* Enqueue [message] in [xmit_queue] and ensure the flush thread is running. *) - let queue_send ~xmit_queue endpoint message = - Log.debug (fun f -> - let module M = Capnp_rpc_lwt.Private.Schema.MessageWrapper.Message in - f "queue_send: %d/%d allocated bytes in %d segs" - (M.total_size message) - (M.total_alloc_size message) - (M.num_segments message)); - let was_idle = Queue.is_empty xmit_queue in - Queue.add message xmit_queue; - Prometheus.Counter.inc_one Metrics.messages_outbound_enqueued_total; - if was_idle then async_tagged "Message sender thread" (fun () -> flush ~xmit_queue endpoint) - let return_not_implemented t x = Log.debug (fun f -> f ~tags:(tags t) "Returning Unimplemented"); let open Builder in let m = Message.init_root () in let _ : Builder.Message.t = Message.unimplemented_set_reader m x in - queue_send ~xmit_queue:t.xmit_queue t.endpoint (Message.to_message m) - - let listen t = - let rec loop () = - Endpoint.recv t.endpoint >>= function - | Error e -> Lwt.return e - | Ok msg -> - let open Reader.Message in - let msg = of_message msg in - Prometheus.Counter.inc_one Metrics.messages_inbound_received_total; - match Parse.message msg with - | #Endpoint_types.In.t as msg -> - Log.debug (fun f -> - let tags = Endpoint_types.In.with_qid_tag (Conn.tags t.conn) msg in - f ~tags "<- %a" (Endpoint_types.In.pp_recv pp_msg) msg); - begin match msg with - | `Abort _ -> - t.disconnecting <- true; - Conn.handle_msg t.conn msg; - Endpoint.disconnect t.endpoint >>= fun () -> - Lwt.return `Aborted - | _ -> - Conn.handle_msg t.conn msg; - loop () - end - | `Unimplemented x as msg -> - Log.info (fun f -> - let tags = Endpoint_types.Out.with_qid_tag (Conn.tags t.conn) x in - f ~tags "<- Unimplemented(%a)" (Endpoint_types.Out.pp_recv pp_msg) x); - Conn.handle_msg t.conn msg; - loop () - | `Not_implemented -> - Log.info (fun f -> f "<- unsupported message type"); - return_not_implemented t msg; - loop () - in - loop () + Endpoint.send t.endpoint (Message.to_message m) + + let rec listen t = + match Endpoint.recv ~tags:(tags t) t.endpoint with + | Error e -> e + | Ok msg -> + let open Reader.Message in + let msg = of_message msg in + match Parse.message msg with + | #Endpoint_types.In.t as msg -> + Log.debug (fun f -> + let tags = Endpoint_types.In.with_qid_tag (Conn.tags t.conn) msg in + f ~tags "<- %a" (Endpoint_types.In.pp_recv pp_msg) msg); + begin match msg with + | `Abort _ -> + t.disconnecting <- true; + Conn.handle_msg t.conn msg; + Endpoint.disconnect t.endpoint; + Conn.disconnect t.conn (Capnp_rpc_proto.Exception.v "Received Abort from peer"); + `Aborted + | _ -> + Conn.handle_msg t.conn msg; + listen t + end + | `Unimplemented x as msg -> + Log.info (fun f -> + let tags = Endpoint_types.Out.with_qid_tag (Conn.tags t.conn) x in + f ~tags "<- Unimplemented(%a)" (Endpoint_types.Out.pp_recv pp_msg) x); + Conn.handle_msg t.conn msg; + listen t + | `Not_implemented -> + Log.info (fun f -> f "<- unsupported message type"); + return_not_implemented t msg; + listen t + + let send_abort t ex = + Endpoint.send t.endpoint (Serialise.message (`Abort ex)) let disconnect t ex = if not t.disconnecting then ( t.disconnecting <- true; - queue_send ~xmit_queue:t.xmit_queue t.endpoint (Serialise.message (`Abort ex)); - Endpoint.disconnect t.endpoint >|= fun () -> + send_abort t ex; Conn.disconnect t.conn ex - ) else ( - Lwt.return_unit ) let disconnecting t = t.disconnecting - let connect ~restore ?(tags=Logs.Tag.empty) endpoint = - let xmit_queue = Queue.create () in - let queue_send msg = queue_send ~xmit_queue endpoint (Serialise.message msg) in + let connect ~sw ~restore ?(tags=Logs.Tag.empty) endpoint = + let queue_send msg = Endpoint.send endpoint (Serialise.message msg) in let restore = Restorer.fn restore in - let conn = Conn.create ~restore ~tags ~queue_send in - let t = { + let fork = Fiber.fork ~sw in + let conn = Conn.create ~restore ~tags ~fork ~queue_send in + { conn; endpoint; - xmit_queue; disconnecting = false; - } in - Prometheus.Gauge.inc_one Metrics.connections; - Lwt.async (fun () -> - Lwt.catch - (fun () -> - listen t >|= fun (`Closed | `Aborted) -> () - ) - (fun ex -> - Log.warn (fun f -> - f ~tags "Uncaught exception handling CapTP connection: %a (dropping connection)" Fmt.exn ex - ); - queue_send @@ `Abort (Capnp_rpc.Exception.v ~ty:`Failed (Printexc.to_string ex)); - Lwt.return_unit - ) - >>= fun () -> - Log.info (fun f -> f ~tags "Connection closed"); - Prometheus.Gauge.dec_one Metrics.connections; + } + + let listen t = + let tags = Conn.tags t.conn in + begin + match listen t with + | `Closed | `Aborted -> () + | exception Eio.Cancel.Cancelled ex -> + Log.debug (fun f -> f ~tags "Cancelled: %a" Fmt.exn ex) + | exception ex -> + Log.warn (fun f -> + f ~tags "Uncaught exception handling CapTP connection: %a (dropping connection)" Fmt.exn ex + ); + send_abort t (Capnp_rpc.Exception.v ~ty:`Failed (Printexc.to_string ex)) + end; + Eio.Cancel.protect (fun () -> disconnect t (Capnp_rpc.Exception.v ~ty:`Disconnected "Connection closed") ); - t + Fiber.check () + + let run t = + (* When [run_writer] finishes it shuts down the socket, causing [listen] to read end-of-stream. + When [listen] finishes, calling [shutdown_send] causes [run_writer] to return. *) + Fiber.both + (fun () -> Endpoint.run_writer ~tags:(tags t) t.endpoint) + (fun () -> listen t; Endpoint.shutdown_send t.endpoint) let dump f t = Conn.dump f t.conn end diff --git a/capnp-rpc-net/capTP_capnp.mli b/capnp-rpc-net/capTP_capnp.mli index ec3b3914c..b6551ec3c 100644 --- a/capnp-rpc-net/capTP_capnp.mli +++ b/capnp-rpc-net/capTP_capnp.mli @@ -1,20 +1,25 @@ (** Provides the RPC layer on top of some network. *) -module Make (N : S.NETWORK) : sig +module Make : S.NETWORK -> sig type t (** A Cap'n Proto RPC protocol handler. *) - val connect : restore:Restorer.t -> ?tags:Logs.Tag.set -> Endpoint.t -> t - (** [connect ~restore ~switch endpoint] is fresh CapTP protocol handler that sends and + val connect : sw:Eio.Switch.t -> restore:Restorer.t -> ?tags:Logs.Tag.set -> Endpoint.t -> t + (** [connect ~sw ~restore ~switch endpoint] is fresh CapTP protocol handler that sends and receives messages using [endpoint]. [restore] is used to respond to "Bootstrap" messages. - If the connection fails then [endpoint] will be disconnected. *) + If the connection fails then [endpoint] will be disconnected. + You must call {!listen} to run the loop handling messages. + @param sw Used to run methods and to run the transmit thread. *) - val bootstrap : t -> string -> 'a Capnp_rpc_lwt.Capability.t + val run : t -> unit + (** [run t] reads and handles incoming messages until the connection is finished. *) + + val bootstrap : t -> string -> 'a Capnp_rpc.Capability.t (** [bootstrap t object_id] is the peer's bootstrap object [object_id], if any. Use [object_id = ""] for the main, public object. *) - val disconnect : t -> Capnp_rpc.Exception.t -> unit Lwt.t + val disconnect : t -> Capnp_rpc.Exception.t -> unit (** [disconnect t reason] releases all resources used by the connection. *) val disconnecting : t -> bool diff --git a/capnp-rpc-net/capnp_rpc_net.ml b/capnp-rpc-net/capnp_rpc_net.ml index 21a1045da..f11cf8929 100644 --- a/capnp-rpc-net/capnp_rpc_net.ml +++ b/capnp-rpc-net/capnp_rpc_net.ml @@ -1,4 +1,4 @@ -open Capnp_rpc_lwt +open Capnp_rpc.Std module S = S @@ -11,16 +11,13 @@ module type VAT_NETWORK = S.VAT_NETWORK with type service_id := Restorer.Id.t and type 'a sturdy_ref := 'a Sturdy_ref.t -module Networking (N : S.NETWORK) (F : Mirage_flow.S) = struct - type flow = F.flow - +module Networking (N : S.NETWORK) = struct module Network = N - module Vat = Vat.Make (N) (F) + module Vat = Vat.Make (N) module CapTP = Vat.CapTP end module Capnp_address = Capnp_address -module Persistence = Persistence module Two_party_network = Two_party_network module Auth = Auth module Tls_wrapper = Tls_wrapper diff --git a/capnp-rpc-net/capnp_rpc_net.mli b/capnp-rpc-net/capnp_rpc_net.mli index 5ad7a3f3a..f4cec9b40 100644 --- a/capnp-rpc-net/capnp_rpc_net.mli +++ b/capnp-rpc-net/capnp_rpc_net.mli @@ -1,9 +1,9 @@ -(** This package adds networking support, including TLS. It contains code common - to capnp-rpc-unix and capnp-rpc-mirage. Libraries should not need to link against - this package (just use capnp-rpc-lwt instead), since they generally shouldn't - care whether services are local or remote. *) +(** This package adds networking support, including TLS. + Libraries should not need to link against this package (just use capnp-rpc + instead), since they generally shouldn't care whether services are local or + remote. *) -open Capnp_rpc_lwt +open Capnp_rpc.Std module S = S @@ -90,7 +90,7 @@ module Restorer : sig (** [make_sturdy t id] converts an ID to a full URI, by adding the hosting vat's address and fingerprint. *) - val load : t -> 'a Sturdy_ref.t -> string -> resolution Lwt.t + val load : t -> 'a Sturdy_ref.t -> string -> resolution (** [load t sr digest] is called to restore the service with key [digest]. [sr] is a sturdy ref that refers to the service, which the service might want to hand out to clients. @@ -109,9 +109,10 @@ module Restorer : sig [make_sturdy id] converts an ID to a full URI, by adding the hosting vat's address and fingerprint. *) - val of_loader : (module LOADER with type t = 'loader) -> 'loader -> t - (** [of_loader (module Loader) l] is a new caching table that uses - [Loader.load l sr (Loader.hash id)] to restore services that aren't in the cache. *) + val of_loader : sw:Eio.Switch.t -> (module LOADER with type t = 'loader) -> 'loader -> t + (** [of_loader ~sw (module Loader) l] is a new caching table that uses + [Loader.load l sr (Loader.hash id)] to restore services that aren't in the cache. + The load function runs in a new fiber in [sw]. *) val add : t -> Id.t -> 'a Capability.t -> unit (** [add t id cap] adds a mapping to [t]. @@ -130,7 +131,7 @@ module Restorer : sig val of_table : Table.t -> t - val restore : t -> Id.t -> ('a Capability.t, Capnp_rpc.Exception.t) result Lwt.t + val restore : t -> Id.t -> ('a Capability.t, Capnp_rpc.Exception.t) result (** [restore t id] restores [id] using [t]. You don't normally need to call this directly, as the Vat will do it automatically. *) end @@ -141,8 +142,7 @@ module type VAT_NETWORK = S.VAT_NETWORK with type service_id := Restorer.Id.t and type 'a sturdy_ref := 'a Sturdy_ref.t -module Networking (N : S.NETWORK) (Flow : Mirage_flow.S) : VAT_NETWORK with - module Network = N and - type flow = Flow.flow +module Networking (N : S.NETWORK) : VAT_NETWORK with + module Network = N module Capnp_address = Capnp_address diff --git a/capnp-rpc-net/dune b/capnp-rpc-net/dune index 6789c63f2..77afc8b4d 100644 --- a/capnp-rpc-net/dune +++ b/capnp-rpc-net/dune @@ -1,5 +1,5 @@ (library (name capnp_rpc_net) (public_name capnp-rpc-net) - (libraries astring capnp capnp-rpc-lwt fmt logs mirage-flow mirage-crypto mirage-crypto-rng - tls-mirage base64 uri ptime prometheus)) + (libraries astring capnp capnp-rpc fmt logs mirage-crypto-rng + tls-eio base64 uri ptime prometheus)) diff --git a/capnp-rpc-net/endpoint.ml b/capnp-rpc-net/endpoint.ml index 1ae0e03de..deb9263ca 100644 --- a/capnp-rpc-net/endpoint.ml +++ b/capnp-rpc-net/endpoint.ml @@ -1,4 +1,26 @@ -open Lwt.Infix +open Eio.Std + +module Metrics = struct + open Prometheus + + let namespace = "capnp" + + let subsystem = "net" + + let connections = + let help = "Number of live capnp-rpc connections" in + Gauge.v ~help ~namespace ~subsystem "connections" + + let messages_inbound_received_total = + let help = "Total number of messages received" in + Counter.v ~help ~namespace ~subsystem "messages_inbound_received_total" + + let messages_outbound_enqueued_total = + let help = "Total number of messages enqueued to be transmitted" in + Counter.v ~help ~namespace ~subsystem "messages_outbound_enqueued_total" +end + +module Write = Eio.Buf_write let src = Logs.Src.create "endpoint" ~doc:"Send and receive Cap'n'Proto messages" module Log = (val Logs.src_log src: Logs.LOG) @@ -7,21 +29,24 @@ let compression = `None let record_sent_messages = false -type flow = Flow : (module Mirage_flow.S with type flow = 'a) * 'a -> flow +type flow = Eio.Flow.two_way_ty r type t = { flow : flow; + writer : Write.t; decoder : Capnp.Codecs.FramedStream.t; - switch : Lwt_switch.t; peer_id : Auth.Digest.t; + recv_buf : Cstruct.t; } let peer_id t = t.peer_id -let of_flow (type flow) ~switch ~peer_id (module F : Mirage_flow.S with type flow = flow) (flow:flow) = - let generic_flow = Flow ((module F), flow) in +let of_flow ~peer_id flow = let decoder = Capnp.Codecs.FramedStream.empty compression in - { flow = generic_flow; decoder; switch; peer_id } + let flow = (flow :> flow) in + let writer = Write.create 4096 in + let recv_buf = Cstruct.create 4096 in + { flow; writer; decoder; peer_id; recv_buf } let dump_msg = let next = ref 0 in @@ -34,37 +59,76 @@ let dump_msg = close_out ch let send t msg = - let (Flow ((module F), flow)) = t.flow in - let data = Capnp.Codecs.serialize ~compression msg in - if record_sent_messages then dump_msg data; - F.write flow (Cstruct.of_string data) >|= function - | Ok () - | Error `Closed as e -> e - | Error e -> Error (`Msg (Fmt.to_to_string F.pp_write_error e)) - -let rec recv t = - let (Flow ((module F), flow)) = t.flow in + Log.debug (fun f -> + let module M = Capnp_rpc.Private.Schema.MessageWrapper.Message in + f "queue_send: %d/%d allocated bytes in %d segs" + (M.total_size msg) + (M.total_alloc_size msg) + (M.num_segments msg)); + Capnp.Codecs.serialize_iter_copyless ~compression msg ~f:(fun x len -> Write.string t.writer x ~len); + Prometheus.Counter.inc_one Metrics.messages_outbound_enqueued_total; + if record_sent_messages then dump_msg (Capnp.Codecs.serialize ~compression msg) + +let rec recv ~tags t = match Capnp.Codecs.FramedStream.get_next_frame t.decoder with - | _ when not (Lwt_switch.is_on t.switch) -> Lwt.return @@ Error `Closed - | Ok msg -> Lwt.return (Ok (Capnp.BytesMessage.Message.readonly msg)) + | Ok msg -> + Prometheus.Counter.inc_one Metrics.messages_inbound_received_total; + (* We often want to send multiple response messages while processing a batch of requests, + so pause the writer to collect them. We'll unpause on the next [single_read]. *) + Write.pause t.writer; + Ok (Capnp.BytesMessage.Message.readonly msg) | Error Capnp.Codecs.FramingError.Unsupported -> failwith "Unsupported Cap'n'Proto frame received" | Error Capnp.Codecs.FramingError.Incomplete -> - Log.debug (fun f -> f "Incomplete; waiting for more data..."); - F.read flow >>= function - | Ok (`Data data) -> - Log.debug (fun f -> f "Read %d bytes" (Cstruct.length data)); - Capnp.Codecs.FramedStream.add_fragment t.decoder (Cstruct.to_string data); - recv t - | Ok `Eof -> - Log.info (fun f -> f "Connection closed"); - Lwt_switch.turn_off t.switch >|= fun () -> + Log.debug (fun f -> f ~tags "Incomplete; waiting for more data..."); + (* We probably scheduled one or more application fibers to run while handling the last + batch of messages. Give them a chance to run now while the writer is paused, because + they might want to send more messages immediately. *) + Fiber.yield (); + Write.unpause t.writer; + match Eio.Flow.single_read t.flow t.recv_buf with + | got -> + Log.debug (fun f -> f ~tags "Read %d bytes" got); + Capnp.Codecs.FramedStream.add_fragment t.decoder (Cstruct.to_string t.recv_buf ~len:got); + recv ~tags t + | exception End_of_file -> + Log.info (fun f -> f ~tags "Received end-of-stream"); + Error `Closed + | exception (Eio.Io (Eio.Net.E Connection_reset _, _) as ex) -> + Log.info (fun f -> f ~tags "Receive failed: %a" Eio.Exn.pp ex); Error `Closed - | Error ex when Lwt_switch.is_on t.switch -> Capnp_rpc.Debug.failf "recv: %a" F.pp_error ex - | Error _ -> Lwt.return (Error `Closed) let disconnect t = - Lwt_switch.turn_off t.switch + try + Eio.Flow.shutdown t.flow `All + with Eio.Io (Eio.Net.E Connection_reset _, _) -> + (* TCP connection already shut down, so TLS shutdown failed. Ignore. *) + () + +let shutdown_send t = + Write.unpause t.writer; + Write.close t.writer + +let rec run_writer ~tags t = + match Write.await_batch t.writer with + | exception End_of_file -> () (* Due to [shutdown_send] closing it. *) + | bufs -> + match Eio.Flow.single_write t.flow bufs with + | n -> Write.shift t.writer n; run_writer ~tags t + | exception (Eio.Io (Eio.Net.E Connection_reset _, _) as ex) -> + Log.info (fun f -> f ~tags "Send failed: %a" Eio.Exn.pp ex) + | exception ex -> + Eio.Fiber.check (); + Log.warn (fun f -> f ~tags "Error sending messages: %a (will shutdown connection)" Fmt.exn ex) -let pp_error f = function - | `Closed -> Fmt.string f "Connection closed" - | `Msg m -> Fmt.string f m +let run_writer ~tags t = + let cleanup () = + Prometheus.Gauge.dec_one Metrics.connections; + disconnect t (* The listen fiber will read end-of-stream soon *) + in + Prometheus.Gauge.inc_one Metrics.connections; + match run_writer ~tags t with + | () -> cleanup () + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + cleanup (); + Printexc.raise_with_backtrace ex bt diff --git a/capnp-rpc-net/endpoint.mli b/capnp-rpc-net/endpoint.mli index 1fe0b9e01..6878cfd61 100644 --- a/capnp-rpc-net/endpoint.mli +++ b/capnp-rpc-net/endpoint.mli @@ -6,27 +6,27 @@ val src : Logs.src type t (** A wrapper for a byte-stream (flow). *) -val send : t -> 'a Capnp.BytesMessage.Message.t -> (unit, [`Closed | `Msg of string]) result Lwt.t -(** [send t msg] transmits [msg]. *) - -val recv : t -> (Capnp.Message.ro Capnp.BytesMessage.Message.t, [> `Closed]) result Lwt.t -(** [recv t] reads the next message from the remote peer. - It returns [Error `Closed] if the connection to the peer is lost - (this will also happen if the switch is turned off). *) - -val of_flow : switch:Lwt_switch.t -> peer_id:Auth.Digest.t -> - (module Mirage_flow.S with type flow = 'flow) -> 'flow -> t -(** [of_flow ~switch ~peer_id (module F) flow] sends and receives on [flow]. - The caller should arrange for [flow] to be closed when the switch is turned off. - If the flow is closed, the switch will be turned off. - If the flow returns an error when the switch is off, the endpoint will return [`Closed] - instead of the underlying error. *) +val send : t -> 'a Capnp.BytesMessage.Message.t -> unit +(** [send t msg] enqueues [msg]. *) -val peer_id : t -> Auth.Digest.t -(** [peer_id t] is the fingerprint of the peer's public key, - or [Auth.Digest.insecure] TLS isn't being used. *) +val run_writer : tags:Logs.Tag.set -> t -> unit +(** [run_writer ~tags t] runs a loop that transmits batches of messages from [t]. + It returns when the flow is closed. *) + +val recv : tags:Logs.Tag.set -> t -> (Capnp.Message.ro Capnp.BytesMessage.Message.t, [> `Closed]) result +(** [recv ~tags t] reads the next message from the remote peer. + It returns [Error `Closed] if the connection to the peer is lost. *) -val disconnect : t -> unit Lwt.t -(** [disconnect t] turns off [t]'s switch. *) +val of_flow : peer_id:Auth.Digest.t -> _ Eio.Flow.two_way -> t +(** [of_flow ~peer_id flow] sends and receives on [flow]. *) -val pp_error : [< `Closed | `Msg of string] Fmt.t +val peer_id : t -> Auth.Digest.t +(** [peer_id t] is the fingerprint of the peer's public key, + or [Auth.Digest.insecure] if TLS isn't being used. *) + +val shutdown_send : t -> unit +(** [shutdown_send t] closes the writer, causing [run_writer] to return once + all buffered data has been written. *) + +val disconnect : t -> unit +(** [disconnect t] shuts down the underlying flow. *) diff --git a/capnp-rpc-net/parse.ml b/capnp-rpc-net/parse.ml index c369ef5af..fb9204fbd 100644 --- a/capnp-rpc-net/parse.ml +++ b/capnp-rpc-net/parse.ml @@ -1,23 +1,21 @@ -open Capnp_rpc_lwt - -module EmbargoId = Capnp_rpc.Message_types.EmbargoId -module RO_array = Capnp_rpc.RO_array -module Reader = Private.Schema.Reader +module EmbargoId = Capnp_rpc_proto.Message_types.EmbargoId +module RO_array = Capnp_rpc_proto.RO_array +module Reader = Capnp_rpc.Private.Schema.Reader module Log = Capnp_rpc.Debug.Log (* A parser for the basic messages (excluding Unimplemented, which has a more complicated type). *) module Make_basic - (Core_types : Capnp_rpc.S.CORE_TYPES) + (Core_types : Capnp_rpc_proto.S.CORE_TYPES) (Network : S.NETWORK) - (T : Capnp_rpc.Message_types.TABLE_TYPES) = struct - module Message_types = Capnp_rpc.Message_types.Make(Core_types)(Network.Types)(T) + (T : Capnp_rpc_proto.Message_types.TABLE_TYPES) = struct + module Message_types = Capnp_rpc_proto.Message_types.Make(Core_types)(Network.Types)(T) open Message_types let parse_xform x = let open Reader.PromisedAnswer.Op in match get x with | Noop -> [] - | GetPointerField y -> [Private.Xform.Field y] + | GetPointerField y -> [Capnp_rpc.Private.Xform.Field y] | Undefined _ -> failwith "Unknown transform type" let parse_promised_answer pa = @@ -65,7 +63,7 @@ module Make_basic match Return.get return with | Return.Results results -> let descs = parse_descs (Payload.cap_table_get_list results |> RO_array.of_list) in - `Results (Private.Msg.Response.of_reader return, descs) + `Results (Capnp_rpc.Private.Msg.Response.of_reader return, descs) | Return.Exception ex -> `Exception (parse_exn ex) | Return.Canceled -> `Cancelled | Return.ResultsSentElsewhere -> `ResultsSentElsewhere @@ -97,7 +95,7 @@ module Make_basic let descs = parse_descs (Payload.cap_table_get_list p |> RO_array.of_list) in (* Get target *) let target = parse_target (Call.target_get call) in - let msg = Private.Msg.Request.of_reader call in + let msg = Capnp_rpc.Private.Msg.Request.of_reader call in let results_to = let r = Call.send_results_to_get call in let open Call.SendResultsTo in @@ -105,14 +103,14 @@ module Make_basic | Caller -> `Caller | Yourself -> `Yourself | ThirdParty _ -> failwith "TODO: parse_call: ThirdParty" - | Undefined x -> Capnp_rpc.Debug.failf "Unknown SendResultsTo type %d" x + | Undefined x -> Fmt.failwith "Unknown SendResultsTo type %d" x in `Call (aid, target, msg, descs, results_to) let parse_bootstrap boot = let open Reader in let qid = Bootstrap.question_id_get boot |> AnswerId.of_uint32 in - let object_id = Bootstrap.deprecated_object_id_get boot |> Private.Schema.ReaderOps.string_of_pointer in + let object_id = Bootstrap.deprecated_object_id_get boot |> Capnp_rpc.Private.Schema.ReaderOps.string_of_pointer in `Bootstrap (qid, object_id) let parse_disembargo x = @@ -124,7 +122,7 @@ module Make_basic | Disembargo.Context.ReceiverLoopback embargo_id -> `Disembargo_reply (target, EmbargoId.of_uint32 embargo_id) | Disembargo.Context.Accept | Disembargo.Context.Provide _ -> failwith "TODO: handle_disembargo: 3rd-party" - | Disembargo.Context.Undefined x -> Capnp_rpc.Debug.failf "Unknown Disembargo type %d" x + | Disembargo.Context.Undefined x -> Fmt.failwith "Unknown Disembargo type %d" x let parse_resolve x = let open Reader in @@ -132,7 +130,7 @@ module Make_basic match Resolve.get x with | Resolve.Cap d -> Ok (parse_desc d) | Resolve.Exception e -> Error (parse_exn e) - | Resolve.Undefined x -> Capnp_rpc.Debug.failf "Resolved to Undefined(%d)!" x + | Resolve.Undefined x -> Fmt.failwith "Resolved to Undefined(%d)!" x in let import_id = Resolve.promise_id_get x |> ImportId.of_uint32 in `Resolve (import_id, new_target) @@ -167,11 +165,11 @@ module Make_basic end module Make - (EP : Private.Capnp_core.ENDPOINT) + (EP : Capnp_rpc.Private.Capnp_core.ENDPOINT) (Network : S.NETWORK with module Types = EP.Network_types) = struct module Parse_in = Make_basic(EP.Core_types)(Network)(EP.Table) - module Parse_out = Make_basic(EP.Core_types)(Network)(Capnp_rpc.Message_types.Flip(EP.Table)) + module Parse_out = Make_basic(EP.Core_types)(Network)(Capnp_rpc_proto.Message_types.Flip(EP.Table)) let message msg = match Parse_in.parse_msg msg with diff --git a/capnp-rpc-net/parse.mli b/capnp-rpc-net/parse.mli index ba0751546..87753eabe 100644 --- a/capnp-rpc-net/parse.mli +++ b/capnp-rpc-net/parse.mli @@ -1,7 +1,7 @@ (** Parsing of Cap'n Proto RPC messages received from a remote peer. *) -open Capnp_rpc_lwt.Private +open Capnp_rpc.Private -module Make (EP : Capnp_core.ENDPOINT) (Network : S.NETWORK with module Types = EP.Network_types) : sig +module Make (EP : Capnp_core.ENDPOINT) : S.NETWORK with module Types = EP.Network_types -> sig val message : Schema.Reader.Message.t -> [ EP.In.t diff --git a/capnp-rpc-net/restorer.ml b/capnp-rpc-net/restorer.ml index c77bcaaca..bdc920fad 100644 --- a/capnp-rpc-net/restorer.ml +++ b/capnp-rpc-net/restorer.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc module Core_types = Private.Capnp_core.Core_types module Log = Capnp_rpc.Debug.Log @@ -33,10 +33,10 @@ module type LOADER = sig type t val hash : t -> Auth.hash val make_sturdy : t -> Id.t -> Uri.t - val load : t -> 'a Sturdy_ref.t -> string -> resolution Lwt.t + val load : t -> 'a Sturdy_ref.t -> string -> resolution end -type t = Id.t -> resolution Lwt.t +type t = Id.t -> resolution let grant x : resolution = Ok (Cast.cap_to_raw x) let reject ex = Error ex @@ -45,21 +45,19 @@ let unknown_service_id = reject (Capnp_rpc.Exception.v "Unknown persistent servi let fn (r:t) = fun k object_id -> - Lwt.async (fun () -> - Lwt.try_bind - (fun () -> r object_id) - (fun r -> k r; Lwt.return_unit) - (fun ex -> - Log.err (fun f -> f "Uncaught exception restoring object: %a" Fmt.exn ex); - k (reject (Capnp_rpc.Exception.v "Internal error restoring object")); - Lwt.return_unit - ) - ) - -let restore (f:t) x = f x |> Lwt_result.map Cast.cap_of_raw + match r object_id with + | r -> k r + | exception (Eio.Cancel.Cancelled _ as ex) -> + k (reject Capnp_rpc.Exception.cancelled); + raise ex + | exception ex -> + Log.err (fun f -> f "Uncaught exception restoring object: %a" Fmt.exn ex); + k (reject (Capnp_rpc.Exception.v "Internal error restoring object")) + +let restore (f:t) x = f x |> Result.map Cast.cap_of_raw let none : t = fun _ -> - Lwt.return @@ Error (Capnp_rpc.Exception.v "This vat has no restorer") + Error (Capnp_rpc.Exception.v "This vat has no restorer") let single id cap = let cap = Cast.cap_to_raw cap in @@ -69,20 +67,20 @@ let single id cap = let requested_id = Digestif.SHA256.digest_string requested_id |> Digestif.SHA256.to_raw_string in if String.equal id requested_id then ( Core_types.inc_ref cap; - Lwt.return (Ok cap) - ) else Lwt.return unknown_service_id + Ok cap + ) else unknown_service_id module Table = struct type digest = string type entry = - | Cached of resolution Lwt.t + | Cached of resolution Promise.or_exn | Manual of Core_types.cap (* We hold a ref on the cap *) type t = { hash : Digestif.hash'; cache : (digest, entry) Hashtbl.t; - load : Id.t -> digest -> resolution Lwt.t; + load : Id.t -> digest -> resolution Promise.or_exn; make_sturdy : Id.t -> Uri.t; } @@ -91,7 +89,7 @@ module Table = struct let create make_sturdy = let hash = `SHA256 in let cache = Hashtbl.create 53 in - let load _ _ = Lwt.return unknown_service_id in + let load _ _ = Promise.create_resolved (Ok unknown_service_id) in { hash; cache; load; make_sturdy } let hash t id = @@ -102,43 +100,44 @@ module Table = struct match Hashtbl.find t.cache digest with | Manual cap -> Core_types.inc_ref cap; - Lwt.return @@ Ok cap + Ok cap | Cached res -> - begin res >>= function - | Error _ as e -> Lwt.return e + begin match Promise.await_exn res with + | Error _ as e -> e | Ok cap -> Core_types.inc_ref cap; - Lwt.pause () >|= fun () -> + Fiber.yield (); Ok cap end | exception Not_found -> let cap = t.load id digest in Hashtbl.add t.cache digest (Cached cap); - Lwt.try_bind - (fun () -> cap) - (fun result -> - begin match result with - | Error _ -> Hashtbl.remove t.cache digest - | Ok cap -> cap#when_released (fun () -> Hashtbl.remove t.cache digest) - end; - (* Ensure all [inc_ref]s are done before handing over to the user. *) - Lwt.pause () >|= fun () -> - result - ) - (fun ex -> - Hashtbl.remove t.cache digest; - Lwt.fail ex - ) - - let of_loader (type l) (module L : LOADER with type t = l) loader = + match Promise.await_exn cap with + | exception ex -> + Hashtbl.remove t.cache digest; + raise ex + | result -> + begin match result with + | Error _ -> Hashtbl.remove t.cache digest + | Ok cap -> + cap#when_released (fun () -> Hashtbl.remove t.cache digest); + (* Ensure all [inc_ref]s are done before handing over to the user. *) + try Fiber.yield () + with ex -> Core_types.dec_ref cap; raise ex + end; + result + + let of_loader (type l) ~sw (module L : LOADER with type t = l) loader = let hash = (L.hash loader :> Digestif.hash') in let cache = Hashtbl.create 53 in let rec load id digest = - let sr : Private.Capnp_core.sturdy_ref = object - method connect = resolve t id - method to_uri_with_secrets = L.make_sturdy loader id - end in - L.load loader (Cast.sturdy_of_raw sr) digest + Fiber.fork_promise ~sw (fun () -> + let sr : Private.Capnp_core.sturdy_ref = object + method connect = resolve t id + method to_uri_with_secrets = L.make_sturdy loader id + end in + L.load loader (Cast.sturdy_of_raw sr) digest + ) and t = { hash; cache; load; make_sturdy = L.make_sturdy loader } in t diff --git a/capnp-rpc-net/s.ml b/capnp-rpc-net/s.ml index 261ec0df6..3271fa021 100644 --- a/capnp-rpc-net/s.ml +++ b/capnp-rpc-net/s.ml @@ -1,7 +1,5 @@ (** Module signatures. *) -open Capnp_rpc_lwt - module type ADDRESS = sig type t (** A network address at which a vat can be reached. *) @@ -21,7 +19,7 @@ module type ADDRESS = sig end module type NETWORK = sig - module Types : Capnp_rpc.S.NETWORK_TYPES + module Types : Capnp_rpc_proto.S.NETWORK_TYPES module Address : ADDRESS @@ -29,17 +27,16 @@ module type NETWORK = sig val connect : t -> - switch:Lwt_switch.t -> + sw:Eio.Switch.t -> secret_key:Auth.Secret_key.t Lazy.t -> Address.t -> - (Endpoint.t, [> `Msg of string]) result Lwt.t - (** [connect t ~switch ~secret_key address] connects to [address], proves ownership of + (Endpoint.t, [> `Msg of string]) result + (** [connect t ~sw ~secret_key address] connects to [address], proves ownership of [secret_key] (if TLS is being used), and returns the resulting endpoint. Returns an error if no connection can be established or the target fails - to authenticate itself. - If [switch] is turned off, the connection should be terminated. *) + to authenticate itself. *) - val parse_third_party_cap_id : Private.Schema.Reader.pointer_t -> Types.third_party_cap_id + val parse_third_party_cap_id : Capnp_rpc.Private.Schema.Reader.pointer_t -> Types.third_party_cap_id end module type VAT_NETWORK = sig @@ -49,9 +46,6 @@ module type VAT_NETWORK = sig type +'a capability (** An ['a capability] is a capability reference to a service of type ['a]. *) - type flow - (** A bi-directional byte-stream. *) - type restorer (** A function for restoring persistent capabilities from sturdy ref service IDs. *) @@ -69,17 +63,22 @@ module type VAT_NETWORK = sig type t (** A CapTP connection to a remote peer. *) - val connect : restore:restorer -> ?tags:Logs.Tag.set -> Endpoint.t -> t - (** [connect ~restore ~switch endpoint] is fresh CapTP protocol handler that sends and + val connect : sw:Eio.Switch.t -> restore:restorer -> ?tags:Logs.Tag.set -> Endpoint.t -> t + (** [connect ~sw ~restore ~switch endpoint] is fresh CapTP protocol handler that sends and receives messages using [endpoint]. [restore] is used to respond to "Bootstrap" messages. - If the connection fails then [endpoint] will be disconnected. *) + If the connection fails then [endpoint] will be disconnected. + You must call {!run} to run the loop handling messages. + @param sw Used to run methods and to run the transmit thread. *) + + val run : t -> unit + (** [run t] reads and handles incoming messages until the connection is finished. *) val bootstrap : t -> service_id -> 'a capability (** [bootstrap t object_id] is the peer's bootstrap object [object_id], if any. Use [object_id = ""] for the main, public object. *) - val disconnect : t -> Capnp_rpc.Exception.t -> unit Lwt.t + val disconnect : t -> Capnp_rpc.Exception.t -> unit (** [disconnect reason] closes the connection, sending [reason] to the peer to explain why. Capabilities and questions at both ends will break, with [reason] as the problem. *) @@ -99,26 +98,28 @@ module type VAT_NETWORK = sig (** A local Vat. *) val create : - ?switch:Lwt_switch.t -> ?tags:Logs.Tag.set -> ?restore:restorer -> ?address:Network.Address.t -> + sw:Eio.Switch.t -> secret_key:Auth.Secret_key.t Lazy.t -> Network.t -> t - (** [create ~switch ~restore ~address ~secret_key network] is a new Vat that + (** [create ~sw ~restore ~address ~secret_key network] is a new Vat that uses [restore] to restore sturdy refs hosted at this vat to live capabilities for peers. The Vat will suggest that other parties connect to it using [address]. Turning off the switch will disconnect any active connections. *) - val add_connection : t -> switch:Lwt_switch.t -> mode:[`Accept|`Connect] -> Endpoint.t -> CapTP.t Lwt.t - (** [add_connection t ~switch ~mode endpoint] runs the CapTP protocol over [endpoint], + val run_connection : t -> mode:[`Accept|`Connect] -> Endpoint.t -> (CapTP.t -> unit) -> unit + (** [run_connection t ~mode endpoint r] runs the protocol over [endpoint], which is a connection to another vat. - When the connection ends, [switch] will be turned off, and turning off [switch] will - end the connection. + Once connected, [r conn] is called with the new connection. + When [run_connection] returns, [endpoint] can be closed. [mode] is used if two Vats connect to each other at the same time to decide which connection to drop. Use [`Connect] if [t] initiated the new - connection. Note that [add_connection] may return an existing connection. *) + connection. + If there is already a connection to [endpoint], [run_connection] may + call [r] on that instead and then return. *) val public_address : t -> Network.Address.t option (** [public_address t] is the address that peers should use when connecting diff --git a/capnp-rpc-net/serialise.ml b/capnp-rpc-net/serialise.ml index 7c935eda8..2965503f7 100644 --- a/capnp-rpc-net/serialise.ml +++ b/capnp-rpc-net/serialise.ml @@ -1,9 +1,9 @@ -open Capnp_rpc_lwt.Private +open Capnp_rpc.Private -module EmbargoId = Capnp_rpc.Message_types.EmbargoId +module EmbargoId = Capnp_rpc_proto.Message_types.EmbargoId module Log = Capnp_rpc.Debug.Log module Builder = Schema.Builder -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array module Make (EP : Capnp_core.ENDPOINT) = struct open EP.Table diff --git a/capnp-rpc-net/serialise.mli b/capnp-rpc-net/serialise.mli index 5a70ef0fa..b5d4684da 100644 --- a/capnp-rpc-net/serialise.mli +++ b/capnp-rpc-net/serialise.mli @@ -1,4 +1,4 @@ -open Capnp_rpc_lwt.Private +open Capnp_rpc.Private module Make (EP : Capnp_core.ENDPOINT) : sig val message : EP.Out.t -> Rpc_schema.rw Schema.message_t diff --git a/capnp-rpc-net/tls_wrapper.ml b/capnp-rpc-net/tls_wrapper.ml index 25e615ebc..f2cc73faa 100644 --- a/capnp-rpc-net/tls_wrapper.ml +++ b/capnp-rpc-net/tls_wrapper.ml @@ -1,57 +1,40 @@ module Log = Capnp_rpc.Debug.Log -open Lwt.Infix open Auth let error fmt = fmt |> Fmt.kstr @@ fun msg -> Error (`Msg msg) -module Make (Underlying : Mirage_flow.S) = struct - module Flow = struct - include Tls_mirage.Make(Underlying) - - let read flow = - read flow >|= function - | Error (`Write `Closed) -> Ok `Eof (* This can happen, despite being a write error on a read! *) - | x -> x - - let writev flow bufs = - writev flow bufs >|= function - | Error (`Write `Closed) -> Error `Closed - | x -> x - - let write flow buf = writev flow [buf] - end - - let plain_endpoint ~switch flow = - Endpoint.of_flow ~switch ~peer_id:Auth.Digest.insecure (module Underlying) flow - - let connect_as_server ~switch flow secret_key = - match secret_key with - | None -> Lwt.return @@ Ok (plain_endpoint ~switch flow) - | Some key -> - Log.info (fun f -> f "Doing TLS server-side handshake..."); - let tls_config = Secret_key.tls_server_config key in - Flow.server_of_flow tls_config flow >|= function - | Error e -> error "TLS connection failed: %a" Flow.pp_write_error e - | Ok flow -> - match Flow.epoch flow with - | Error () -> failwith "Unknown error getting TLS epoch data" - | Ok data -> - match data.Tls.Core.peer_certificate with - | None -> error "No client certificate found" - | Some client_cert -> - let peer_id = Digest.of_certificate client_cert in - Ok (Endpoint.of_flow ~switch ~peer_id (module Flow) flow) - - let connect_as_client ~switch flow secret_key auth = - match Digest.authenticator auth with - | None -> Lwt.return @@ Ok (plain_endpoint ~switch flow) - | Some authenticator -> - let tls_config = Secret_key.tls_client_config ~authenticator (Lazy.force secret_key) in - Log.info (fun f -> f "Doing TLS client-side handshake..."); - Flow.client_of_flow tls_config flow >|= function - | Error e -> error "TLS connection failed: %a" Flow.pp_write_error e - | Ok flow -> Ok (Endpoint.of_flow ~switch ~peer_id:auth (module Flow) flow) -end +let plain_endpoint flow = + Endpoint.of_flow ~peer_id:Auth.Digest.insecure flow + +let connect_as_server flow secret_key = + match secret_key with + | None -> Ok (plain_endpoint flow) + | Some key -> + Log.info (fun f -> f "Doing TLS server-side handshake..."); + let tls_config = Secret_key.tls_server_config key in + match Tls_eio.server_of_flow tls_config flow with + | exception (Failure msg) -> error "TLS connection failed: %s" msg + | exception ex -> Eio.Fiber.check (); error "TLS connection failed: %a" Fmt.exn ex + | flow -> + match Tls_eio.epoch flow with + | Error () -> failwith "Unknown error getting TLS epoch data" + | Ok data -> + match data.Tls.Core.peer_certificate with + | None -> error "No client certificate found" + | Some client_cert -> + let peer_id = Digest.of_certificate client_cert in + Ok (Endpoint.of_flow ~peer_id flow) + +let connect_as_client flow secret_key auth = + match Digest.authenticator auth with + | None -> Ok (plain_endpoint flow) + | Some authenticator -> + let tls_config = Secret_key.tls_client_config ~authenticator (Lazy.force secret_key) in + Log.info (fun f -> f "Doing TLS client-side handshake..."); + match Tls_eio.client_of_flow tls_config flow with + | exception (Failure msg) -> error "TLS connection failed: %s" msg + | exception ex -> Eio.Fiber.check (); error "TLS connection failed: %a" Fmt.exn ex + | flow -> Ok (Endpoint.of_flow ~peer_id:auth flow) diff --git a/capnp-rpc-net/tls_wrapper.mli b/capnp-rpc-net/tls_wrapper.mli index f99c7b562..81c214f39 100644 --- a/capnp-rpc-net/tls_wrapper.mli +++ b/capnp-rpc-net/tls_wrapper.mli @@ -1,17 +1,13 @@ open Auth - -module Make (Underlying : Mirage_flow.S) : sig - (** Make an [Endpoint] from an [Underlying.flow], using TLS if appropriate. *) - - val connect_as_server : - switch:Lwt_switch.t -> Underlying.flow -> Auth.Secret_key.t option -> - (Endpoint.t, [> `Msg of string]) result Lwt.t - - val connect_as_client : - switch:Lwt_switch.t -> Underlying.flow -> Auth.Secret_key.t Lazy.t -> Digest.t -> - (Endpoint.t, [> `Msg of string]) result Lwt.t - (** [connect_as_client ~switch underlying key digest] is an endpoint using flow [underlying]. - If [digest] requires TLS, it performs a TLS handshake. It uses [key] as its private key - and checks that the server is the one required by [auth]. *) -end - +open Eio.Std + +val connect_as_server : + [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> Auth.Secret_key.t option -> + (Endpoint.t, [> `Msg of string]) result + +val connect_as_client : + [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> Auth.Secret_key.t Lazy.t -> Digest.t -> + (Endpoint.t, [> `Msg of string]) result +(** [connect_as_client underlying key digest] is an endpoint using flow [underlying]. + If [digest] requires TLS, it performs a TLS handshake. It uses [key] as its private key + and checks that the server is the one required by [auth]. *) diff --git a/capnp-rpc-net/two_party_network.ml b/capnp-rpc-net/two_party_network.ml index d800c9f40..a407d96d5 100644 --- a/capnp-rpc-net/two_party_network.ml +++ b/capnp-rpc-net/two_party_network.ml @@ -22,4 +22,4 @@ type t = unit let parse_third_party_cap_id _ = `Two_party_only -let connect () ~switch:_ ~secret_key:_ _ = assert false +let connect () ~sw:_ ~secret_key:_ _ = assert false diff --git a/capnp-rpc-net/vat.ml b/capnp-rpc-net/vat.ml index bf1d7c0ff..0d1afb9e2 100644 --- a/capnp-rpc-net/vat.ml +++ b/capnp-rpc-net/vat.ml @@ -1,83 +1,75 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Log = Capnp_rpc.Debug.Log module ID_map = Auth.Digest.Map -module Make (Network : S.NETWORK) (Underlying : Mirage_flow.S) = struct +module Make (Network : S.NETWORK) = struct module CapTP = CapTP_capnp.Make (Network) let hash = `SHA256 (* Only support a single hash for now *) - type connection_attempt = (CapTP.t, Capnp_rpc.Exception.t) result Lwt.t + type connection_attempt = (CapTP.t, Capnp_rpc.Exception.t) result Eio.Promise.t type t = { + sw : Eio.Switch.t; network : Network.t; - switch : Lwt_switch.t option; secret_key : Auth.Secret_key.t Lazy.t; address : Network.Address.t option; restore : Restorer.t; tags : Logs.Tag.set; - connection_removed : unit Lwt_condition.t; (* Fires when a connection is removed *) + connection_removed : Eio.Condition.t; (* Fires when a connection is removed *) mutable connecting : connection_attempt ID_map.t; (* Out-going connections being attempted. *) mutable connections : CapTP.t ID_map.t; (* Accepted connections *) mutable anon_connections : CapTP.t list; (* Connections not using TLS. *) } - let create ?switch ?(tags=Logs.Tag.empty) ?(restore=Restorer.none) ?address ~secret_key network = - let t = { + let create ?(tags=Logs.Tag.empty) ?(restore=Restorer.none) ?address ~sw ~secret_key network = + Fiber.fork_daemon ~sw Capnp_rpc.Leak_handler.run; + { + sw; network; - switch; secret_key; address; restore; tags; - connection_removed = Lwt_condition.create (); + connection_removed = Eio.Condition.create (); connecting = ID_map.empty; connections = ID_map.empty; anon_connections = []; - } in - Lwt_switch.add_hook switch (fun () -> - let ex = Capnp_rpc.Exception.v ~ty:`Disconnected "Vat shut down" in - ID_map.bindings t.connections |> Lwt_list.iter_p (fun (_, c) -> CapTP.disconnect c ex) >>= fun () -> - t.connections <- ID_map.empty; - Lwt_list.iter_p (fun c -> CapTP.disconnect c ex) t.anon_connections >|= fun () -> - t.anon_connections <- []; - ID_map.iter (fun _ th -> Lwt.cancel th) t.connecting; - t.connecting <- ID_map.empty; - ); - t - - let add_tls_connection t ~switch endpoint = - let conn = CapTP.connect ~tags:t.tags ~restore:t.restore endpoint in + } + + let run_connection_generic t ~add ~remove endpoint = + let conn = CapTP.connect ~sw:t.sw ~tags:t.tags ~restore:t.restore endpoint in + add conn; + Fun.protect (fun () -> CapTP.run conn) + ~finally:(fun () -> + remove conn; + Eio.Condition.broadcast t.connection_removed + ) + + let run_connection_tls t endpoint r = let peer_id = Endpoint.peer_id endpoint in - t.connections <- ID_map.add peer_id conn t.connections; - Lwt_switch.add_hook (Some switch) (fun () -> - begin match ID_map.find peer_id t.connections with - | Some x when x == conn -> t.connections <- ID_map.remove peer_id t.connections - | Some _ (* Already replaced by a new one? *) - | None -> () - end; - CapTP.disconnect conn (Capnp_rpc.Exception.v ~ty:`Disconnected "Switch turned off") >|= fun () -> - Lwt_condition.broadcast t.connection_removed () - ); - conn - - let add_connection t ~switch ~(mode:[`Accept|`Connect]) endpoint = - let tags = t.tags in + run_connection_generic t endpoint + ~add:(fun conn -> t.connections <- ID_map.add peer_id conn t.connections; r conn) + ~remove:(fun conn -> + match ID_map.find_opt peer_id t.connections with + | Some x when x == conn -> t.connections <- ID_map.remove peer_id t.connections + | Some _ (* Already replaced by a new one? *) + | None -> () + ) + + (* Run CapTP on [endpoint], calling [r conn] with the connection (possibly reusing an existing one). + If a new connection is used, it is also stored in [t] while running. *) + let run_connection t ~(mode:[`Accept|`Connect]) endpoint r = let peer_id = Endpoint.peer_id endpoint in if peer_id = Auth.Digest.insecure then ( - let conn = CapTP.connect ~tags ~restore:t.restore endpoint in - t.anon_connections <- conn :: t.anon_connections; - Lwt_switch.add_hook (Some switch) (fun () -> - t.anon_connections <- List.filter ((!=) conn) t.anon_connections; - CapTP.disconnect conn (Capnp_rpc.Exception.v ~ty:`Disconnected "Switch turned off") >|= fun () -> - Lwt_condition.broadcast t.connection_removed () - ); - Lwt.return conn - ) else match ID_map.find peer_id t.connections with - | None -> Lwt.return @@ add_tls_connection t ~switch endpoint + run_connection_generic t endpoint + ~add:(fun conn -> t.anon_connections <- conn :: t.anon_connections; r conn) + ~remove:(fun conn -> t.anon_connections <- List.filter ((!=) conn) t.anon_connections) + ) else match ID_map.find_opt peer_id t.connections with + | None -> run_connection_tls t endpoint r | Some existing -> Log.info (fun f -> f ~tags:t.tags "Trying to add a connection, but we already have one for this vat"); (* This can happen if two vats call each other at exactly the same time. @@ -127,70 +119,63 @@ module Make (Network : S.NETWORK) (Underlying : Mirage_flow.S) = struct let my_id = Auth.Secret_key.digest ~hash (Lazy.force t.secret_key) in let keep_new = (my_id > peer_id) = (mode = `Connect) in if keep_new then ( - let conn = add_tls_connection t ~switch endpoint in - let reason = Capnp_rpc.Exception.v "Closing duplicate connection" in - CapTP.disconnect existing reason >|= fun () -> - conn + let reason = Capnp_rpc.Exception.v "Invalidated by newer connection" in + CapTP.disconnect existing reason; + run_connection_tls t endpoint r ) else ( - Lwt_switch.turn_off switch >|= fun () -> - existing + Endpoint.disconnect endpoint; + r existing ) let public_address t = t.address - let connect_anon t addr ~service = - let switch = Lwt_switch.create () in - Network.connect t.network ~switch ~secret_key:t.secret_key addr >>= function - | Error (`Msg m) -> Lwt.return @@ Error (Capnp_rpc.Exception.v m) - | Ok ep -> - add_connection t ~switch ep ~mode:`Connect >|= fun conn -> - Ok (CapTP.bootstrap conn service) - - let initiate_connection t remote_id addr service = - (* We need to start a new connection attempt. *) - let switch = Lwt_switch.create () in - let conn = - Network.connect t.network ~switch ~secret_key:t.secret_key addr >>= function - | Error (`Msg m) -> Lwt.return @@ Error (Capnp_rpc.Exception.v m) - | Ok ep -> add_connection t ~switch ep ~mode:`Connect >|= fun conn -> Ok conn - in - t.connecting <- ID_map.add remote_id conn t.connecting; - conn >|= fun conn -> - t.connecting <- ID_map.remove remote_id t.connecting; - match conn with - | Ok conn -> Ok (CapTP.bootstrap conn service) - | Error _ as e -> e - - let rec connect_auth t remote_id addr ~service = + (* Make a new connection to remote service [addr] and request [service] from it. *) + let initiate_connection t addr service = + let remote_id = Network.Address.digest addr in + let p, r = Promise.create () in + let tracked = remote_id <> Auth.Digest.insecure in + if tracked then t.connecting <- ID_map.add remote_id p t.connecting; + Fun.protect + ~finally:(fun () -> + if tracked then t.connecting <- ID_map.remove remote_id t.connecting; + if not (Promise.is_resolved p) then Promise.resolve_error r Capnp_rpc.Exception.cancelled + ) + (fun () -> + Fiber.fork_daemon ~sw:t.sw (fun () -> + Switch.run (fun sw -> + match Network.connect ~sw t.network ~secret_key:t.secret_key addr with + | Error (`Msg m) -> Promise.resolve_error r (Capnp_rpc.Exception.v m) + | Ok ep -> run_connection t ep (Promise.resolve_ok r) ~mode:`Connect + ); + `Stop_daemon + ); + Promise.await p + ) + |> Result.map (fun conn -> CapTP.bootstrap conn service) + + (* Get a connection to [addr] and request [service] from it. *) + let rec connect t (addr, service) = + let remote_id = Network.Address.digest addr in let my_id = Auth.Secret_key.digest ~hash (Lazy.force t.secret_key) in if Auth.Digest.equal remote_id my_id then Restorer.restore t.restore service - else match ID_map.find remote_id t.connections with + else match ID_map.find_opt remote_id t.connections with | Some conn when CapTP.disconnecting conn -> - Lwt_condition.wait t.connection_removed >>= fun () -> - connect_auth t remote_id addr ~service + Eio.Condition.await_no_mutex t.connection_removed; + connect t (addr, service) | Some conn -> (* Already connected; use that. *) - Lwt.return @@ Ok (CapTP.bootstrap conn service) + Ok (CapTP.bootstrap conn service) | None -> - match ID_map.find remote_id t.connecting with - | None -> initiate_connection t remote_id addr service + match ID_map.find_opt remote_id t.connecting with + | None -> initiate_connection t addr service | Some conn -> (* We're already trying to establish a connection, wait for that. *) - conn >|= function - | Ok conn -> Ok (CapTP.bootstrap conn service) - | Error _ as e -> e + Promise.await conn |> Result.map (fun conn -> CapTP.bootstrap conn service) let make_sturdy_ref t sr = - Cast.sturdy_of_raw @@ object (_ : Private.Capnp_core.sturdy_ref) - method connect = - let (addr, service) = sr in - let remote_id = Network.Address.digest addr in - Lwt_result.map Cast.cap_to_raw ( - if remote_id = Auth.Digest.insecure then connect_anon t addr ~service - else connect_auth t remote_id addr ~service - ) - + Capnp_rpc.Cast.sturdy_of_raw @@ object (_ : Capnp_rpc.Private.Capnp_core.sturdy_ref) + method connect = Result.map Capnp_rpc.Cast.cap_to_raw (connect t sr) method to_uri_with_secrets = Network.Address.to_uri sr end @@ -202,7 +187,7 @@ module Make (Network : S.NETWORK) (Underlying : Mirage_flow.S) = struct let export _t sr = (* [t] isn't used currently. However, requiring it does emphasise that importing/exporting is a somewhat privileged operation (as it reveals the secret tokens in the sturdy ref). *) - (Cast.sturdy_to_raw sr)#to_uri_with_secrets + (Capnp_rpc.Cast.sturdy_to_raw sr)#to_uri_with_secrets let sturdy_uri t id = sturdy_ref t id |> export t @@ -229,10 +214,13 @@ module Make (Network : S.NETWORK) (Underlying : Mirage_flow.S) = struct Auth.Digest.pp id CapTP.dump conn + let dump_id_map pp f m = + Fmt.pf f "{@[%a@]}" (Fmt.seq pp) (ID_map.to_seq m) + let dump f t = Fmt.pf f "@[%a@,Connecting: %a@,Connected: %a@,Anonymous: %a@]" pp_vat_id t.address - (ID_map.dump dump_connecting) t.connecting - (ID_map.dump dump_id_conn) t.connections + (dump_id_map dump_connecting) t.connecting + (dump_id_map dump_id_conn) t.connections (Fmt.Dump.list CapTP.dump) t.anon_connections end diff --git a/capnp-rpc-unix.opam b/capnp-rpc-unix.opam index bf2e1d82f..46fcc03ce 100644 --- a/capnp-rpc-unix.opam +++ b/capnp-rpc-unix.opam @@ -13,19 +13,18 @@ depends: [ "ocaml" {>= "4.08.0"} "capnp-rpc-net" {= version} "cmdliner" {>= "1.1.0"} - "cstruct-lwt" + "cstruct" {>= "6.2.0"} "astring" "fmt" {>= "0.8.7"} "logs" "extunix" "base64" {>= "3.0.0"} - "dune" {>= "3.0"} + "dune" {>= "3.16"} "alcotest" {>= "1.6.0" & with-test} - "alcotest-lwt" { >= "1.6.0" & with-test} - "mirage-crypto-rng-lwt" {>= "0.11.0"} - "mdx" {>= "2.2.1" & with-test} - "lwt" {>= "5.6.1"} - "asetmap" {with-test} + "mirage-crypto-rng-eio" {>= "1.1.0" & with-test} + "mdx" {>= "2.4.1" & with-test} + "eio_main" {with-test} + "eio" {>= "1.2"} ] conflicts: [ "jbuilder" diff --git a/capnp-rpc.opam b/capnp-rpc.opam index 5f0d5f370..36e3d3d21 100644 --- a/capnp-rpc.opam +++ b/capnp-rpc.opam @@ -2,9 +2,8 @@ opam-version: "2.0" synopsis: "Cap'n Proto is a capability-based RPC system with bindings for many languages" description: """ -This package contains the core protocol. -Users will normally want to use `capnp-rpc-lwt` and, in most cases, -`capnp-rpc-unix` rather than using this one directly.""" +This package provides a version of the Cap'n Proto RPC system using the Cap'n +Proto serialisation format and Eio for concurrency.""" maintainer: "Thomas Leonard " authors: "Thomas Leonard " license: "Apache-2.0" @@ -13,12 +12,15 @@ bug-reports: "https://github.com/mirage/capnp-rpc/issues" doc: "https://mirage.github.io/capnp-rpc/" depends: [ "ocaml" {>= "4.08.0"} - "stdint" + "conf-capnproto" {build} + "capnp" {>= "3.6.0"} + "stdint" {>= "0.6.0"} + "eio" {>= "1.2"} "astring" "fmt" {>= "0.8.7"} "logs" - "asetmap" - "dune" {>= "3.0"} + "uri" {>= "1.6.0"} + "dune" {>= "3.16"} "alcotest" {>= "1.6.0" & with-test} "afl-persistent" {with-test} ] diff --git a/capnp-rpc/capability.ml b/capnp-rpc/capability.ml new file mode 100644 index 000000000..94101d735 --- /dev/null +++ b/capnp-rpc/capability.ml @@ -0,0 +1,130 @@ +open Eio.Std +open Capnp_core + +module Log = Capnp_rpc_proto.Debug.Log +module StructStorage = Capnp.BytesMessage.StructStorage + +type 'a t = Core_types.cap +type 'a capability_t = 'a t +type ('t, 'a, 'b) method_t = ('t, 'a, 'b) Capnp.RPC.MethodID.t + +module Request = Request + +let inc_ref = Core_types.inc_ref +let dec_ref = Core_types.dec_ref + +let with_ref t fn = + Fun.protect + (fun () -> fn t) + ~finally:(fun () -> dec_ref t) + +let pp f x = x#pp f + +let broken = Core_types.broken_cap +let when_broken = Core_types.when_broken +let when_released (x:Core_types.cap) f = x#when_released f +let problem x = x#problem + +let wait_until_settled (x : _ t) = + let result, set_result = Promise.create () in + let rec aux x = + if x#blocker = None then ( + Promise.resolve set_result () + ) else ( + x#when_more_resolved (fun x -> + Core_types.dec_ref x; + aux x + ) + ) + in + aux x; + Promise.await result + +let await_settled t = + wait_until_settled t; + match problem t with + | None -> Ok () + | Some ex -> Error ex + +let await_settled_exn t = + wait_until_settled t; + match problem t with + | None -> () + | Some e -> Fmt.failwith "%a" Capnp_rpc_proto.Exception.pp e + +let equal a b = + match a#blocker, b#blocker with + | None, None -> + let a = a#shortest in + let b = b#shortest in + begin match a#problem, b#problem with + | None, None -> Ok (a = b) + | Some a, Some b -> Ok (a = b) + | _ -> Ok false + end + | _ -> Error `Unsettled + +let call (target : 't capability_t) (m : ('t, 'a, 'b) method_t) (req : 'a Request.t) = + Log.debug (fun f -> f "Calling %a" Capnp.RPC.MethodID.pp m); + let msg = Request.finish m req in + let results, resolver = Local_struct_promise.make () in + target#call resolver msg; + results + +let call_and_wait cap (m : ('t, 'a, 'b StructStorage.reader_t) method_t) req = + let p, r = Promise.create () in + let result = call cap m req in + let finish = lazy (Core_types.dec_ref result) in + result#when_resolved (function + | Error e -> Promise.resolve_error r (`Capnp e) + | Ok resp -> + Lazy.force finish; + let payload = Msg.Response.readable resp in + let release_response_caps () = Core_types.Response_payload.release resp in + let contents = Schema.Reader.Payload.content_get payload |> Schema.Reader.of_pointer in + Promise.resolve_ok r (contents, release_response_caps) + ); + try Promise.await p + with ex -> + Lazy.force finish; + raise ex + +let call_for_value cap m req = + match call_and_wait cap m req with + | Error _ as response -> response + | Ok (response, release_response_caps) -> + release_response_caps (); + Ok response + +let call_for_value_exn cap m req = + match call_for_value cap m req with + | Ok x -> x + | Error (`Capnp e) -> + Log.debug (fun f -> f "Error calling %t(%a): %a" + cap#pp + Capnp.RPC.MethodID.pp m + Capnp_rpc_proto.Error.pp e); + Fmt.failwith "%a: %a" Capnp.RPC.MethodID.pp m Capnp_rpc_proto.Error.pp e + +let call_for_unit cap m req = + match call_for_value cap m req with + | Ok _ -> Ok () + | Error _ as e -> e + +let call_for_unit_exn cap m req = call_for_value_exn cap m req |> ignore + +let call_for_caps cap m req fn = + let q = call cap m req in + match fn q with + | r -> Core_types.dec_ref q; r + | exception ex -> Core_types.dec_ref q; raise ex + +type 'a resolver = Cap_proxy.resolver_cap + +let promise () = + let cap = Cap_proxy.local_promise () in + (cap :> Core_types.cap), (cap :> 'a resolver) + +let resolve_ok r x = r#resolve x + +let resolve_exn r ex = r#resolve (Core_types.broken_cap ex) diff --git a/capnp-rpc/capnp_core.ml b/capnp-rpc/capnp_core.ml new file mode 100644 index 000000000..fcddd1654 --- /dev/null +++ b/capnp-rpc/capnp_core.ml @@ -0,0 +1,18 @@ +module Capnp_content = struct + include Msg + + let ref_leak_detected = Leak_handler.ref_leak_detected +end + +module Core_types = Capnp_rpc_proto.Core_types(Capnp_content) + +module Local_struct_promise = Capnp_rpc_proto.Local_struct_promise.Make(Core_types) +module Cap_proxy = Capnp_rpc_proto.Cap_proxy.Make(Core_types) + +module type ENDPOINT = Capnp_rpc_proto.Message_types.ENDPOINT with + module Core_types = Core_types + +class type sturdy_ref = object + method connect : (Core_types.cap, Capnp_rpc_proto.Exception.t) result + method to_uri_with_secrets : Uri.t +end diff --git a/capnp-rpc/capnp_rpc.ml b/capnp-rpc/capnp_rpc.ml index 17d032d5d..6743dcce6 100644 --- a/capnp-rpc/capnp_rpc.ml +++ b/capnp-rpc/capnp_rpc.ml @@ -1,14 +1,84 @@ -module S = S -module RO_array = RO_array -module Stats = Stats -module Id = Id -module Debug = Debug -module Error = Error -module Exception = Exception -module Core_types(C : S.WIRE) = Core_types.Make(C) -module Local_struct_promise = Local_struct_promise -module Cap_proxy = Cap_proxy - -module Message_types = Message_types -module CapTP = CapTP -module RC = RC +open Capnp_core + +include Capnp.Message.BytesMessage + +module Exception = Capnp_rpc_proto.Exception +module Error = Capnp_rpc_proto.Error +module Log = Capnp_rpc_proto.Debug.Log +module RO_array = Capnp_rpc_proto.RO_array +module Debug = Capnp_rpc_proto.Debug +module Leak_handler = Leak_handler + +module Capability = Capability + +module StructRef = struct + type 'a t = Core_types.struct_ref + + let inc_ref = Core_types.inc_ref + let dec_ref = Core_types.dec_ref +end + +module Sturdy_ref = Sturdy_ref + +module Untyped = struct + let struct_field t i = + (* todo: would be better to have a separate type for this *) + object (_ : Core_types.struct_ref) + method cap path = t#cap (Xform.Field i :: path) + method when_resolved _ = failwith "Can't use when_resolved on a sub-struct" + method response = failwith "Can't use response on a sub-struct" + method update_rc = failwith "Can't use rec-counts on a sub-struct" + method sealed_dispatch _ = None + method pp f = Fmt.pf f "pointer %d in %t" i t#pp + method blocker = failwith "struct_field: blocker" + method check_invariants = () + end + + let capability_field t f = t#cap [Xform.Field f] + + let local = Service.local + + type abstract_method_t = Service.abstract_method_t + + let abstract_method x req release = + x (StructStorage.cast_reader req) release + + let get_cap a i = + Core_types.Attachments.cap (Stdint.Uint32.to_int i) (Msg.unwrap_attachments a) + + let add_cap a cap = + Core_types.Attachments.add_cap (Msg.unwrap_attachments a) cap |> Stdint.Uint32.of_int + + let clear_cap a i = + Core_types.Attachments.clear_cap (Msg.unwrap_attachments a) (Stdint.Uint32.to_int i) + + let unknown_interface ~interface_id _req release_params = + release_params (); + Core_types.fail ~ty:`Unimplemented "Unknown interface %a" Stdint.Uint64.printer interface_id + + let unknown_method ~interface_id ~method_id _req release_params = + release_params (); + Core_types.fail ~ty:`Unimplemented "Unknown method %a.%d" Stdint.Uint64.printer interface_id method_id + + class type generic_service = Service.generic +end + +module Service = Service + +module Private = Private + +module Cast = struct + let cap_of_raw x = x + let cap_to_raw x = x + + let sturdy_of_raw x = x + let sturdy_to_raw x = x +end + +module Persistence = Persistence + +module Std = struct + module Sturdy_ref = Sturdy_ref + module Capability = Capability + module Service = Service +end diff --git a/capnp-rpc/capnp_rpc.mli b/capnp-rpc/capnp_rpc.mli index 3ccbd331b..c551c4465 100644 --- a/capnp-rpc/capnp_rpc.mli +++ b/capnp-rpc/capnp_rpc.mli @@ -1,17 +1,345 @@ -(** The abstract and untyped Cap'n Proto RPC protocol. - Users will normally want to use the {!module:Capnp_rpc_lwt} API instead, - which provides a typed interface using the Cap'n Proto serialisation. *) - -module S = S -module RO_array = RO_array -module Stats = Stats -module Id = Id -module Debug = Debug -module Error = Error -module Exception = Exception -module Message_types = Message_types -module Core_types (W : S.WIRE) : S.CORE_TYPES with module Wire = W -module Local_struct_promise = Local_struct_promise -module Cap_proxy = Cap_proxy -module CapTP = CapTP -module RC = RC +(** Cap'n Proto core API for defining and using services. *) + +include (module type of Capnp.BytesMessage) +(** @closed *) + +module Exception = Capnp_rpc_proto.Exception +module Error = Capnp_rpc_proto.Error + +module StructRef : sig + (** A promise for a response structure. + You can use the generated [_get_pipelined] functions on a promise to get + a promise for a capability inside the promise, and then pipeline messages + to that promise without waiting for the response struct to arrive. *) + + type 'a t + (** An ['a t] is a reference to a response message (that may not have arrived yet) + with content type ['a]. *) + + val inc_ref : 'a t -> unit + (** [inc_ref t] increases the reference count on [t] by one. *) + + val dec_ref : 'a t -> unit + (** [dec_ref t] reduces the reference count on [t] by one. + When the count reaches zero, this result must never be used again. + If the results have not yet arrived when the count reaches zero, we send + a cancellation request (which may or may not succeed). As soon as the + results are available, they are released. *) +end + +module Capability : sig + (** A capability is a reference to an object, or to a promise for an object. + You can invoke methods on a capability even while it is still only a + promise. *) + + type +'a t + (** An ['a t] is a capability reference to a service of type ['a]. *) + + val broken : Exception.t -> 'a t + (** [broken ex] is a broken capability, with problem [ex]. + Any attempt to call methods on it will fail with [ex]. *) + + val when_broken : (Exception.t -> unit) -> 'a t -> unit + (** [when_broken fn x] calls [fn problem] when [x] becomes broken. + If [x] is already broken, [fn] is called immediately. + If [x] can never become broken (e.g. it is a near ref), this does nothing. + If [x]'s ref-count reaches zero without [fn] being called, it will never + be called. *) + + val when_released : 'a t -> (unit -> unit) -> unit + (** [when_released t fn] will call [fn ()] when [t]'s ref-count drops to zero. + This is used for caches, to remove entries when they become invalid. + For promises, [fn] will be transferred to the resolution if resolved. + For broken caps, this method does nothing (exceptions are never released). *) + + val problem : 'a t -> Exception.t option + (** [problem t] is [Some ex] if [t] is broken, or [None] if it is still + believed to be healthy. Once a capability is broken, it will never + work again and any calls made on it will fail with exception [ex]. *) + + val await_settled : 'a t -> (unit, Exception.t) result + (** [await_settled t] resolves once [t] is a "settled" (non-promise) reference. + If [t] is a near, far or broken reference, this returns immediately. + If it is currently a local or remote promise, it waits until it isn't. + [wait_until_settled] takes ownership of [t] until it returns (you must not + [dec_ref] it before then). + @return [Ok ()] on success, or [Error _] if [t] failed. + @since 1.2 *) + + val await_settled_exn : 'a t -> unit + (** Like [await_settled], but raises an exception on error. + @since 1.2 *) + + val equal : 'a t -> 'a t -> (bool, [`Unsettled]) result + (** [equal a b] indicates whether [a] and [b] designate the same settled service. + Returns [Error `Unsettled] if [a] or [b] is still a promise (and they therefore + may yet turn out to be equal when the promise resolves). *) + + module Request : sig + type 'a t + (** An ['a t] is a builder for the out-going request's payload. *) + + val create : ?message_size:int -> (Capnp.Message.rw Slice.t -> 'a) -> 'a t * 'a + (** [create init] is a fresh request payload and contents builder. + Use one of the generated [init_pointer] functions for [init]. + @param message_size An estimate of the size of the payload. If this is too small, + additional segments will be allocated automatically, but this + is less efficient than getting the size right to start with. *) + + val create_no_args : unit -> 'a t + (** [create_no_args ()] is a payload with no content. *) + + val release : 'a t -> unit + (** Clear the exported refs, dropping their ref-counts. This is called automatically + when you send a message, but you might need it if you decide to abort. *) + end + + val call : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> 'a Request.t -> 'b StructRef.t + (** [call target m req] invokes [target#m req] and returns a promise for the result. + Messages may be sent to the capabilities that will be in the result + before the result arrives - they will be pipelined to the service + responsible for resolving the promise. The caller must call [StructRef.dec_ref] + when finished with the result (consider using one of the [call_*] functions below + instead for a simpler interface). *) + + val call_and_wait : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> + 'a Request.t -> (('b StructStorage.reader_t * (unit -> unit)), [> `Capnp of Error.t]) result + (** [call_and_wait t m req] does [call t m req] and waits for the response. + This is simpler than using [call], but doesn't support pipelining + (you can't use any capabilities in the response in another message until the + response arrives). + On success, it returns [Ok (response, release_response_caps)]. + Call [release_response_caps] when done with the results, to release any capabilities it might + contain that you didn't use (remembering that future versions of the protocol might add + new optional capabilities you don't know about yet). + If you don't need any capabilities from the result, consider using [call_for_value] instead. + Cancelling the fiber will send a cancel message to the target for remote calls. *) + + val call_for_value : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> + 'a Request.t -> ('b StructStorage.reader_t, [> `Capnp of Error.t]) result + (** [call_for_value t m req] is similar to [call_and_wait], but automatically + releases any capabilities in the response before returning. Use this if + you aren't expecting any capabilities in the response. *) + + val call_for_value_exn : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> + 'a Request.t -> 'b StructStorage.reader_t + (** Wrapper for [call_for_value] that turns errors into exceptions. *) + + val call_for_unit : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> + 'a Request.t -> (unit, [> `Capnp of Error.t]) result + (** Wrapper for [call_for_value] that ignores the result. *) + + val call_for_unit_exn : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> + 'a Request.t -> unit + (** Wrapper for [call_for_unit] that turns errors into exceptions. *) + + val call_for_caps : 't t -> ('t, 'a, 'b StructStorage.reader_t) Capnp.RPC.MethodID.t -> + 'a Request.t -> ('b StructRef.t -> 'c) -> 'c + (** [call_for_caps target m req extract] is a wrapper for [call] that passes the results promise to + [extract], which should extract any required capability promises from it. + In the common case where you want a single cap "foo" from the result, use + [call_for_caps target m req Results.foo_get_pipelined]. + When the remote call finally returns, the result will be released automatically. *) + + type 'a resolver + (** An ['a resolver] can be used to resolve a promise for an ['a]. It can only be used once. *) + + val promise : unit -> 'a t * 'a resolver + (** [promise ()] returns a fresh local promise and a resolver for it. + Any calls made on the promise will be queued until it is resolved. *) + + val resolve_ok : 'a resolver -> 'a t -> unit + (** [resolve_ok r x] resolves [r]'s promise to [x]. [r] takes ownership of [x] + (the caller must use [inc_ref] first if they want to continue using it). *) + + val resolve_exn : 'a resolver -> Exception.t -> unit + (** [resolve_exn r x] breaks [r]'s promise with exception [x]. *) + + val inc_ref : _ t -> unit + (** [inc_ref t] increases the ref-count on [t] by one. *) + + val dec_ref : _ t -> unit + (** [dec_ref t] decreases the ref-count on [t] by one. When the count reaches zero, + the capability is released. This may involve sending a notification to a remote + peer. Any time you extract a capability from a struct or struct promise, + it must eventually be freed by calling [dec_ref] on it. *) + + val with_ref : 'a t -> ('a t -> 'b) -> 'b + (** [with_ref t fn] runs [fn t] and then calls [dec_ref t] (whether [fn] + succeeds or not). *) + + val pp : 'a t Fmt.t +end + +module Sturdy_ref : sig + type +'a t + (** An off-line (persistent) capability reference. + + A sturdy ref contains all the information necessary to get a live reference to a service: + + - The network address of the hosting vat (e.g. TCP host and port) + - A way to authenticate the hosting vat (e.g. a fingerprint of the vat's public key) + - A way to identify the target service within the vat and prove permission to access it + (e.g. a "Swiss number") + *) + + val connect : 'a t -> ('a Capability.t, Exception.t) result + (** [connect t] returns a live reference to [t]'s service. *) + + val connect_exn : 'a t -> 'a Capability.t + (** [connect_exn] is a wrapper for [connect] that raises an exception on error. *) + + val with_cap : + 'a t -> + ('a Capability.t -> ('b, [> `Capnp of Exception.t] as 'e) result) -> + ('b, 'e) result + (** [with_cap t f] uses [connect t] to get a live-ref [x], + then does [Capability.with_ref x f]. *) + + val with_cap_exn : 'a t -> ('a Capability.t -> 'b) -> 'b + (** [with_cap_exn t f] uses [connect_exn t] to get a live-ref [x], + then does [Capability.with_ref x f]. *) + + val reader : + ('a StructStorage.reader_t -> Capnp.MessageSig.ro Slice.t option) -> + 'a StructStorage.reader_t -> Uri.t + (** [reader accessor] is a field accessor for reading a sturdy ref. + e.g. if [sr_get] is a generated field accessor for an AnyPointer field, then + [reader Reader.Struct.sr_get] is an accessor that treats it as a SturdyRef field. + todo: This should really return a sturdy ref, not a URI, but that requires a change + to the spec to add a sturdy ref cap-descriptor table entry type. *) + + val builder : + ('a StructStorage.builder_t -> Capnp.MessageSig.rw Slice.t) -> + 'a StructStorage.builder_t -> _ t -> unit + (** [builder setter] converts a generated AnyPointer field setter [setter] to a SturdyRef + setter. Use it to add a SturdyRef to a message with [builder Params.sr_get params sr]. *) + + val cast : 'a t -> 'b t +end + +module Service : sig + (** Functions for service implementors. *) + + type ('a, 'b) method_t = 'a -> (unit -> unit) -> 'b StructRef.t + (** An ('a, 'b) method_t is a method implementation that takes + a reader for the parameters and + a function to release the capabilities in the parameters, + and returns a promise for the results. *) + + module Response : sig + type 'b t + (** An ['a t] is a builder for the out-going response. *) + + val create : ?message_size:int -> (Capnp.Message.rw Slice.t -> 'a) -> 'a t * 'a + (** [create init] is a fresh response and contents builder. + Use one of the generated [init_pointer] functions for [init]. *) + + val create_empty : unit -> 'a t + (** [empty ()] is an empty response. *) + + val release : 'a t -> unit + (** Clear the exported refs, dropping their ref-counts. This is called automatically + when you send a message, but you might need it if you decide to abort. *) + end + + val return : 'a Response.t -> 'a StructRef.t + (** [return r] wraps up a simple local result as a promise. *) + + val return_empty : unit -> 'a StructRef.t + (** [return_empty ()] is a promise for a response with no payload. *) + + val error : Error.t -> 'a StructRef.t + (** [error e] is a broken promise for a struct, with error [e]. *) + + val fail : ?ty:Exception.ty -> ('a, Format.formatter, unit, 'b StructRef.t) format4 -> 'a + (** [fail msg] is an exception {!error} with reason [msg]. *) +end + +(** Some aliases for common modules. + + This is intended to be opened, as [open Capnp_rpc.Std]. *) +module Std : sig + module Sturdy_ref = Sturdy_ref + module Capability = Capability + module Service = Service +end + +module Leak_handler = Leak_handler + +(**/**) + +module Untyped : sig + (** This module is only for use by the code generated by the capnp-ocaml + schema compiler. The generated code provides type-safe wrappers for + everything here. *) + + open Stdint + + type abstract_method_t + + val abstract_method : ('a StructStorage.reader_t, 'b) Service.method_t -> abstract_method_t + + val struct_field : 'a StructRef.t -> int -> 'b StructRef.t + + val capability_field : 'a StructRef.t -> int -> 'b Capability.t + + class type generic_service = object + method dispatch : interface_id:Uint64.t -> method_id:int -> abstract_method_t + method release : unit + method pp : Format.formatter -> unit + end + + val local : #generic_service -> 'a Capability.t + + val get_cap : Capnp.MessageSig.attachments -> Uint32.t -> _ Capability.t + val add_cap : Capnp.MessageSig.attachments -> _ Capability.t -> Uint32.t + val clear_cap : Capnp.MessageSig.attachments -> Uint32.t -> unit + + val unknown_interface : interface_id:Uint64.t -> abstract_method_t + val unknown_method : interface_id:Uint64.t -> method_id:int -> abstract_method_t +end + +module Private = Private + +module Cast : sig + val cap_of_raw : Capnp_core.Core_types.cap -> 'a Capability.t + val cap_to_raw : 'a Capability.t -> Capnp_core.Core_types.cap + + val sturdy_of_raw : Capnp_core.sturdy_ref -> 'a Sturdy_ref.t + val sturdy_to_raw : 'a Sturdy_ref.t -> Capnp_core.sturdy_ref +end + +module Debug = Capnp_rpc_proto.Debug + +(**/**) + +module Persistence : sig + class type ['a] persistent = object + method save : ('a Sturdy_ref.t, Exception.t) result + end + + val with_persistence : + ('a #persistent) -> + ('impl -> 'a Capability.t) -> + (#Untyped.generic_service as 'impl) -> + 'a Capability.t + (** [with_persistence persist Service.Foo.local obj] is like [Service.Foo.local obj], but the + resulting service also handles the Cap'n Proto persistence protocol, using [persist]. *) + + val with_sturdy_ref : + 'a Sturdy_ref.t -> + ('impl -> 'a Capability.t) -> + (#Untyped.generic_service as 'impl) -> + 'a Capability.t + (** [with_sturdy_ref sr Service.Foo.local obj] is like [Service.Foo.local obj], + but responds to [save] calls by returning [sr]. *) + + val save : 'a Capability.t -> (Uri.t, [> `Capnp of Error.t]) result + (** [save cap] calls the persistent [save] method on [cap]. + Note that not all capabilities can be saved. + todo: this should return an ['a Sturdy_ref.t]; see {!Sturdy_ref.reader}. *) + + val save_exn : 'a Capability.t -> Uri.t + (** [save_exn] is a wrapper for [save] that returns a failed thread on error. *) +end diff --git a/capnp-rpc/dune b/capnp-rpc/dune index 0c1d6131a..e0cb0cee2 100644 --- a/capnp-rpc/dune +++ b/capnp-rpc/dune @@ -1,4 +1,14 @@ (library (name capnp_rpc) (public_name capnp-rpc) - (libraries astring fmt logs stdint asetmap)) + (libraries astring capnp capnp-rpc.proto fmt logs eio uri)) + +(rule + (targets rpc_schema.ml rpc_schema.mli) + (deps rpc_schema.capnp) + (action (run capnp compile -o %{bin:capnpc-ocaml} %{deps}))) + +(rule + (targets persistent.ml persistent.mli) + (deps persistent.capnp) + (action (run capnp compile -o %{bin:capnpc-ocaml} %{deps}))) diff --git a/capnp-rpc/leak_handler.ml b/capnp-rpc/leak_handler.ml new file mode 100644 index 000000000..bf7326812 --- /dev/null +++ b/capnp-rpc/leak_handler.ml @@ -0,0 +1,54 @@ +module M = Map.Make(Int) + +module Log = Capnp_rpc_proto.Debug.Log + +(* A map from thread IDs to (n, q) pairs. + [q] is a queue of callbacks waiting to be run in the thread + and [n] is the number of loops consuming [q] (typically 1). *) +let handlers : (int * (unit -> unit) Eio.Stream.t) M.t Atomic.t = Atomic.make M.empty + +(* [add_handler id] increments the counter for thread [id] and returns the queue. + If there isn't one yet, it creates a new one. *) +let rec add_handler id = + let old = Atomic.get handlers in + let handler = + match M.find_opt id old with + | None -> (1, Eio.Stream.create max_int) + | Some (n, q) -> (n + 1, q) + in + let next = M.add id handler old in + if Atomic.compare_and_set handlers old next then snd handler + else add_handler id + +let rec remove_handler id = + let old = Atomic.get handlers in + let n, q = M.find id old in + let next = + if n > 1 then M.add id (n - 1, q) old + else M.remove id old + in + if not (Atomic.compare_and_set handlers old next) then remove_handler id + +let run () = + let id = Thread.(id (self ())) in + let q = add_handler id in + try + while true do + let fn = Eio.Stream.take q in + try + fn () + with ex -> + let bt = Printexc.get_raw_backtrace () in + Eio.Fiber.check (); + Log.warn (fun f -> f "Uncaught exception handling ref-leak: %a" Fmt.exn_backtrace (ex, bt)) + done + with ex -> + remove_handler id; + raise ex + +let ref_leak_detected thread fn = + match M.find_opt thread (Atomic.get handlers) with + | Some (_, q) -> Eio.Stream.add q fn + | None -> + Capnp_rpc_proto.Debug.Log.debug + (fun f -> f "Leak detected, but no leak reporter is running so ignoring") diff --git a/capnp-rpc/leak_handler.mli b/capnp-rpc/leak_handler.mli new file mode 100644 index 000000000..f54b3f73b --- /dev/null +++ b/capnp-rpc/leak_handler.mli @@ -0,0 +1,22 @@ +(** Handle references that got GC'd with a non-zero ref-count. + + If an application forgets to release a resource and it gets GC'd then we want to + log a warning and clean up (so forgotten refs don't build up over time). + + Because GC finalizers can run at any time and from any thread, + we need to pass the cleanup callback to a fiber running in the owning thread. *) + +val run : unit -> 'a +(** [run ()] registers a leak handler for the current thread and + runs a loop that waits for callbacks and runs them. + If the fiber is cancelled, the handler is removed. + + Each vat runs this in a daemon fiber. + It is safe to have multiple such fibers running in a single systhread. *) + +val ref_leak_detected : int -> (unit -> unit) -> unit +(** [ref_leak_detected thread_id fn] should be called from a GC finalizer if + the resource was not properly released. + + If a handler for [thread_id] is running (see {!run}) then it will schedule + [fn] to run at a safe point in that thread. If not, [fn] is ignored. *) diff --git a/capnp-rpc-lwt/msg.ml b/capnp-rpc/msg.ml similarity index 94% rename from capnp-rpc-lwt/msg.ml rename to capnp-rpc/msg.ml index c6f583ade..cac9e6a92 100644 --- a/capnp-rpc-lwt/msg.ml +++ b/capnp-rpc/msg.ml @@ -1,10 +1,10 @@ -module Log = Capnp_rpc.Debug.Log +module Log = Capnp_rpc_proto.Debug.Log module B = Schema.Builder module R = Schema.Reader -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array module StructStorage = Capnp.Message.BytesMessage.StructStorage -type Capnp.MessageSig.attachments += RPC_attachments of Capnp_rpc.S.attachments +type Capnp.MessageSig.attachments += RPC_attachments of Capnp_rpc_proto.S.attachments module Path = struct type t = Xform.t list @@ -30,11 +30,11 @@ let with_attachments a t = let unwrap_attachments = function | RPC_attachments x -> x - | Capnp.MessageSig.No_attachments -> Capnp_rpc.S.No_attachments + | Capnp.MessageSig.No_attachments -> Capnp_rpc_proto.S.No_attachments | _ -> failwith "Unknown attachment type!" let attachments = function - | Readonly None -> Capnp_rpc.S.No_attachments + | Readonly None -> Capnp_rpc_proto.S.No_attachments | Readonly (Some ss) -> unwrap_attachments @@ StructStorage.get_attachments ss | Builder ss -> unwrap_attachments @@ StructStorage.get_attachments ss diff --git a/capnp-rpc-lwt/msg.mli b/capnp-rpc/msg.mli similarity index 81% rename from capnp-rpc-lwt/msg.mli rename to capnp-rpc/msg.mli index 5574a8c43..1f8a49722 100644 --- a/capnp-rpc-lwt/msg.mli +++ b/capnp-rpc/msg.mli @@ -10,7 +10,7 @@ module Path : sig end module Request : sig - include Capnp_rpc.S.WIRE_PAYLOAD with type path := Path.t and type t = request msg + include Capnp_rpc_proto.S.WIRE_PAYLOAD with type path := Path.t and type t = request msg val writable : t -> Schema.Builder.Call.t (** We're about to transmit this message and we need to fill in the target and CapDescriptor table. @@ -24,7 +24,7 @@ module Request : sig end module Response : sig - include Capnp_rpc.S.WIRE_PAYLOAD with type path := Path.t and type t = response msg + include Capnp_rpc_proto.S.WIRE_PAYLOAD with type path := Path.t and type t = response msg val writable : t -> Schema.Builder.Return.t (** We're about to transmit this message and we need to fill in the CapDescriptor table. @@ -40,5 +40,5 @@ module Response : sig (** [bootstrap ()] is a fresh bootstrap response. *) end -val wrap_attachments : Capnp_rpc.S.attachments -> Capnp.MessageSig.attachments -val unwrap_attachments : Capnp.MessageSig.attachments -> Capnp_rpc.S.attachments +val wrap_attachments : Capnp_rpc_proto.S.attachments -> Capnp.MessageSig.attachments +val unwrap_attachments : Capnp.MessageSig.attachments -> Capnp_rpc_proto.S.attachments diff --git a/capnp-rpc/persistence.ml b/capnp-rpc/persistence.ml new file mode 100644 index 000000000..bce41ac07 --- /dev/null +++ b/capnp-rpc/persistence.ml @@ -0,0 +1,53 @@ +module Api = Persistent.Make(Capnp.BytesMessage) + +class type ['a] persistent = object + method save : ('a Sturdy_ref.t, Capnp_rpc_proto.Exception.t) result +end + +let with_persistence + (persistent:'b #persistent) + (_:(#Service.generic as 'a) -> 'b Capability.t) + (impl : 'a) = + (* We ignore the second argument. It's just to force the user to prove that [impl] + really does have type ['a]. *) + let dispatch_persistent method_id _params release_params = + if method_id = Capnp.RPC.MethodID.method_id Api.Client.Persistent.Save.method_id then ( + let open Api.Service.Persistent.Save in + release_params (); + match persistent#save with + | Error e -> Service.error (`Exception e) + | Ok sr -> + let resp, results = Service.Response.create Results.init_pointer in + Sturdy_ref.builder Results.sturdy_ref_get results sr; + Service.return resp + ) else ( + release_params (); + Service.fail ~ty:`Unimplemented "Unknown persistence method %d" method_id + ) + in + let wrapper = object (_ : #Service.generic) + method release = impl#release + method pp = impl#pp + method dispatch ~interface_id ~method_id = + if interface_id = Api.Service.Persistent.interface_id then dispatch_persistent method_id + else impl#dispatch ~interface_id ~method_id + end in + Service.local wrapper + +let with_sturdy_ref sr local impl = + let persistent = object + method save = Ok sr + end in + with_persistence persistent local impl + +let save cap = + let open Api.Client.Persistent.Save in + let request = Capability.Request.create_no_args () in + match Capability.call_for_value cap method_id request with + | Error _ as e -> e + | Ok response -> Ok (Sturdy_ref.reader Results.sturdy_ref_get response) + +let save_exn cap = + match save cap with + | Error (`Capnp e) -> failwith (Fmt.to_to_string Capnp_rpc_proto.Error.pp e) + | Ok x -> x diff --git a/capnp-rpc-lwt/persistent.capnp b/capnp-rpc/persistent.capnp similarity index 100% rename from capnp-rpc-lwt/persistent.capnp rename to capnp-rpc/persistent.capnp diff --git a/capnp-rpc-lwt/private.ml b/capnp-rpc/private.ml similarity index 100% rename from capnp-rpc-lwt/private.ml rename to capnp-rpc/private.ml diff --git a/capnp-rpc/capTP.ml b/capnp-rpc/proto/capTP.ml similarity index 97% rename from capnp-rpc/capTP.ml rename to capnp-rpc/proto/capTP.ml index 87ce05854..6db800c9f 100644 --- a/capnp-rpc/capTP.ml +++ b/capnp-rpc/proto/capTP.ml @@ -1,5 +1,3 @@ -open Asetmap - module Log = Debug.Log module IntMap = Map.Make(struct type t = int let compare (a:int) b = compare a b end) @@ -92,7 +90,7 @@ module Make (EP : Message_types.ENDPOINT) = struct mutable ref_count : RC.t; (* The switchable holds one until resolved, plus each [resolve_target] adds one. *) mutable count : int; (* Number of times remote sent us this. *) mutable used : bool; (* We have sent a message to this target (embargo needed on resolve). *) - mutable settled : bool; (* This was a SenderHosted - it can't resolve except to an exception. *) + settled : bool; (* This was a SenderHosted - it can't resolve except to an exception. *) mutable resolution : disembargo_info; proxy : Cap_proxy.resolver_cap Weak_ptr.t; (* Our switchable ([Weak_ptr.t] is mutable). *) strong_proxy : < > option ref; (* Keeps the switchable alive if there are callbacks registered. *) @@ -154,7 +152,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let mark_resolved t ~get_import result = if t.resolution <> `Unresolved then - Debug.failf "Got Resolve for already-resolved import %a" pp t + Fmt.failwith "Got Resolve for already-resolved import %a" pp t else match result with | Error _ -> t.resolution <- `Error | Ok desc -> @@ -547,7 +545,7 @@ module Make (EP : Message_types.ENDPOINT) = struct (* We're sending a return message. *) let return_resolved t ~exports_for_release ~resolve_targets = match t.state with - | `Finished -> Debug.failf "Can't return finished answer %a!" pp t + | `Finished -> Fmt.failwith "Can't return finished answer %a!" pp t | `Active x -> assert (x.resolution = `Unresolved); t.state <- `Active {x with resolution = `Resolved (resolve_targets, exports_for_release)} @@ -555,7 +553,7 @@ module Make (EP : Message_types.ENDPOINT) = struct (* We're sending a TakeFromOtherQuestion return message. *) let return_take_from_question t question = match t.state with - | `Finished -> Debug.failf "Can't return finished answer %a!" pp t + | `Finished -> Fmt.failwith "Can't return finished answer %a!" pp t | `Active x -> assert (x.resolution = `Unresolved); Question.inc_ref question; @@ -564,7 +562,7 @@ module Make (EP : Message_types.ENDPOINT) = struct (* Remove from Answers table after calling this. *) let finish t ~release_result_caps = match t.state with - | `Finished -> Debug.failf "Can't finish already-finished answer %a" pp t + | `Finished -> Fmt.failwith "Can't finish already-finished answer %a" pp t | `Active {answer; resolution} -> t.state <- `Finished; dec_ref answer; @@ -596,14 +594,14 @@ module Make (EP : Message_types.ENDPOINT) = struct [None] if we didn't return yet. *) let resolve_target t path = match t.state with - | `Finished -> Debug.failf "Answer %a is finished!" pp t + | `Finished -> Fmt.failwith "Answer %a is finished!" pp t | `Active {answer; resolution} -> match resolution with | `Unresolved -> None | `Forwarded q -> Some (Ok (`QuestionCap (q, path))) | `Resolved (resolve_targets, _) -> match answer#response with - | None -> Debug.failf "Answer %a is resolved, but no response recorded!" pp t + | None -> Fmt.failwith "Answer %a is resolved, but no response recorded!" pp t | Some (Error _) as e -> e | Some (Ok msg) -> match Core_types.Wire.Response.cap_index msg path with @@ -614,7 +612,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let disembargo_target t path = match resolve_target t path with - | None -> Debug.failf "Got disembargo request for unresolved answer %a!" pp t + | None -> Fmt.failwith "Got disembargo request for unresolved answer %a!" pp t | Some (Error _) -> failwith "Got disembargo for an exception!" | Some (Ok target) -> target @@ -631,7 +629,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let init t answer = match t.state with | `Finished -> t.state <- `Active { answer; resolution = `Unresolved } - | `Active _ -> Debug.failf "Answer %a already initialised!" pp t + | `Active _ -> Fmt.failwith "Answer %a already initialised!" pp t end module Export = struct @@ -705,6 +703,7 @@ module Make (EP : Message_types.ENDPOINT) = struct tags : Logs.Tag.set; embargoes : (EmbargoId.t * Cap_proxy.resolver_cap) Embargoes.t; restore : restorer; + fork : (unit -> unit) -> unit; questions : Question.t Questions.t; answers : Answer.t Answers.t; @@ -740,11 +739,12 @@ module Make (EP : Message_types.ENDPOINT) = struct let default_restore k _object_id = k @@ Error (Exception.v "This vat has no restorer") - let create ?(restore=default_restore) ~tags ~queue_send = + let create ?(restore=default_restore) ~tags ~fork ~queue_send = { queue_send = (queue_send :> EP.Out.t -> unit); tags; restore = restore; + fork; questions = Questions.make (); answers = Answers.make (); imports = Imports.make (); @@ -770,7 +770,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let check_connected t = match t.disconnected with | None -> () - | Some ex -> Debug.failf "CapTP connection is disconnected (%a)" Exception.pp ex + | Some ex -> Fmt.failwith "CapTP connection is disconnected (%a)" Exception.pp ex module Send : sig (** Converts struct pointers into integer table indexes, ready for sending. @@ -874,7 +874,6 @@ module Make (EP : Message_types.ENDPOINT) = struct else `SenderPromise id let bootstrap t remote_promise = - check_connected t; Questions.alloc t.questions (Question.v ~params_for_release:[] ~remote_promise) (* This is for level 0 implementations, which don't understand about releasing caps. *) @@ -1086,15 +1085,18 @@ module Make (EP : Message_types.ENDPOINT) = struct t.queue_send (`Disembargo_request request) let bootstrap t object_id = - let result = make_remote_promise t in - let question = Send.bootstrap t (result :> Core_types.struct_resolver) in - result#set_question question; - let qid = Question.id question in - Log.debug (fun f -> f ~tags:(with_qid qid t) "Sending: bootstrap"); - t.queue_send (`Bootstrap (qid, object_id)); - let service = result#cap Wire.Path.root in - dec_ref result; - service + match t.disconnected with + | Some ex -> Core_types.broken_cap ex + | None -> + let result = make_remote_promise t in + let question = Send.bootstrap t (result :> Core_types.struct_resolver) in + result#set_question question; + let qid = Question.id question in + Log.debug (fun f -> f ~tags:(with_qid qid t) "Sending: bootstrap"); + t.queue_send (`Bootstrap (qid, object_id)); + let service = result#cap Wire.Path.root in + dec_ref result; + service module Switchable = struct class type handler = object @@ -1132,6 +1134,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let make ~(release:unit Lazy.t) ~settled ~strong_proxy init = object (self : #Core_types.cap) val id = Debug.OID.next () + val thread_id = Thread.(id (self ())) val mutable state = Unset { rc = RC.one; handler = init; on_set = Queue.create (); on_release = Queue.create () } @@ -1156,7 +1159,7 @@ module Make (EP : Message_types.ENDPOINT) = struct method resolve cap = match state with - | Set _ -> Debug.failf "Can't resolve already-set switchable %t to %t!" self#pp cap#pp + | Set _ -> Fmt.failwith "Can't resolve already-set switchable %t to %t!" self#pp cap#pp | Unset {handler = _; rc; on_set; on_release} -> let pp f = self#pp f in RC.check ~pp rc; @@ -1215,7 +1218,7 @@ module Make (EP : Message_types.ENDPOINT) = struct | Gc -> begin match state with | Unset x -> - Core_types.Wire.ref_leak_detected (fun () -> + Core_types.Wire.ref_leak_detected thread_id (fun () -> if RC.is_zero x.rc then ( Log.warn (fun f -> f "@[Reference GC'd with non-zero ref-count!@,%t@,\ But, ref-count is now zero, so a previous GC leak must have fixed it.@]" @@ -1465,8 +1468,10 @@ module Make (EP : Message_types.ENDPOINT) = struct | `Local target -> Log.debug (fun f -> f ~tags:t.tags "Handling call: (%t).call %a" target#pp Core_types.Request_payload.pp msg); - target#call answer_resolver msg; (* Takes ownership of [caps]. *) - dec_ref target + t.fork (fun () -> + target#call answer_resolver msg; (* Takes ownership of [caps]. *) + dec_ref target + ) | #message_target_cap as target -> Log.debug (fun f -> f ~tags:t.tags "Forwarding call: (%a).call %a" pp_message_target_cap target Core_types.Request_payload.pp msg); @@ -1476,6 +1481,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let promise, answer_resolver = Local_struct_promise.make () in let answer = Answer.create id ~answer:promise in Answers.set t.answers id answer; + t.fork @@ fun () -> object_id |> t.restore @@ fun service -> if Answer.needs_return answer && t.disconnected = None then ( let results = @@ -1498,7 +1504,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let caps_used = Question.paths_used question |> caps_used ~msg in let import_with_embargoes cap_index d = let embargo_path = - match IntMap.find cap_index caps_used with + match IntMap.find_opt cap_index caps_used with | None -> None | Some path -> Some (Question.message_target question path) in @@ -1518,7 +1524,7 @@ module Make (EP : Message_types.ENDPOINT) = struct | `AcceptFromThirdParty -> failwith "todo: AcceptFromThirdParty" | `TakeFromOtherQuestion aid -> match Answer.answer_struct (Answers.find_exn t.answers aid) with - | `Finished -> Debug.failf "Can't take from answer %a - it's already finished!" AnswerId.pp aid + | `Finished -> Fmt.failwith "Can't take from answer %a - it's already finished!" AnswerId.pp aid | `Promise other -> match question.remote_promise with | `Released -> `TakeFromCancelledQuestion @@ -1575,7 +1581,7 @@ module Make (EP : Message_types.ENDPOINT) = struct let embargoes_needed = caps_used ~msg paths_used in let maybe_embargo cap_index cap = inc_ref cap; - match IntMap.find cap_index embargoes_needed with + match IntMap.find_opt cap_index embargoes_needed with | None -> cap | Some path -> let old_path = Question.message_target question path in @@ -1604,8 +1610,8 @@ module Make (EP : Message_types.ENDPOINT) = struct let send_disembargo t embargo_id target = let desc = match target with - | `None -> Debug.failf "Protocol error: disembargo request for None cap" - | `Local -> Debug.failf "Protocol error: disembargo request for local target" + | `None -> Fmt.failwith "Protocol error: disembargo request for None cap" + | `Local -> Fmt.failwith "Protocol error: disembargo request for local target" | `QuestionCap (question, path) -> Question.message_target question path | `Import import -> Import.message_target import in diff --git a/capnp-rpc/capTP.mli b/capnp-rpc/proto/capTP.mli similarity index 86% rename from capnp-rpc/capTP.mli rename to capnp-rpc/proto/capTP.mli index 93eb5fa0f..1b47b8238 100644 --- a/capnp-rpc/capTP.mli +++ b/capnp-rpc/proto/capTP.mli @@ -12,11 +12,13 @@ module Make (EP : Message_types.ENDPOINT) : sig capability. *) val create : ?restore:restorer -> tags:Logs.Tag.set -> + fork:((unit -> unit) -> unit) -> queue_send:([> EP.Out.t] -> unit) -> t - (** [create ~bootstrap ~tags ~queue_send] is a handler for a connection to a remote peer. + (** [create ~restore ~tags ~fork ~queue_send] is a handler for a connection to a remote peer. Messages will be sent to the peer by calling [queue_send] (which MUST deliver them in order). - If the remote peer asks for the bootstrap object, it will be given a reference to [bootstrap]. - Log messages will be tagged with [tags]. *) + If the remote peer asks for a bootstrap object, [restore] will be used to get it. + Log messages will be tagged with [tags]. + @param fork is used when dispatching a local method handler. *) val bootstrap : t -> string -> EP.Core_types.cap (** [bootstrap t object_id] returns a reference to the remote peer's bootstrap object, if any. diff --git a/capnp-rpc/cap_proxy.ml b/capnp-rpc/proto/cap_proxy.ml similarity index 100% rename from capnp-rpc/cap_proxy.ml rename to capnp-rpc/proto/cap_proxy.ml diff --git a/capnp-rpc/cap_proxy.mli b/capnp-rpc/proto/cap_proxy.mli similarity index 100% rename from capnp-rpc/cap_proxy.mli rename to capnp-rpc/proto/cap_proxy.mli diff --git a/capnp-rpc/proto/capnp_rpc_proto.ml b/capnp-rpc/proto/capnp_rpc_proto.ml new file mode 100644 index 000000000..17d032d5d --- /dev/null +++ b/capnp-rpc/proto/capnp_rpc_proto.ml @@ -0,0 +1,14 @@ +module S = S +module RO_array = RO_array +module Stats = Stats +module Id = Id +module Debug = Debug +module Error = Error +module Exception = Exception +module Core_types(C : S.WIRE) = Core_types.Make(C) +module Local_struct_promise = Local_struct_promise +module Cap_proxy = Cap_proxy + +module Message_types = Message_types +module CapTP = CapTP +module RC = RC diff --git a/capnp-rpc/proto/capnp_rpc_proto.mli b/capnp-rpc/proto/capnp_rpc_proto.mli new file mode 100644 index 000000000..49dd5f1d5 --- /dev/null +++ b/capnp-rpc/proto/capnp_rpc_proto.mli @@ -0,0 +1,17 @@ +(** The abstract and untyped Cap'n Proto RPC protocol. + Users will normally want to use the {!module:Capnp_rpc} API instead, + which provides a typed interface using the Cap'n Proto serialisation. *) + +module S = S +module RO_array = RO_array +module Stats = Stats +module Id = Id +module Debug = Debug +module Error = Error +module Exception = Exception +module Message_types = Message_types +module Core_types (W : S.WIRE) : S.CORE_TYPES with module Wire = W +module Local_struct_promise = Local_struct_promise +module Cap_proxy = Cap_proxy +module CapTP = CapTP +module RC = RC diff --git a/capnp-rpc/core_types.ml b/capnp-rpc/proto/core_types.ml similarity index 98% rename from capnp-rpc/core_types.ml rename to capnp-rpc/proto/core_types.ml index d6ef5ac1b..045c20c13 100644 --- a/capnp-rpc/core_types.ml +++ b/capnp-rpc/proto/core_types.ml @@ -51,6 +51,7 @@ module Make(Wire : S.WIRE) = struct class virtual ref_counted = object (self : #base_ref) + val thread_id = Thread.(id (self ())) val mutable ref_count = RC.one method private virtual release : unit method virtual pp : Format.formatter -> unit @@ -72,7 +73,7 @@ module Make(Wire : S.WIRE) = struct method sealed_dispatch : type a. a S.brand -> a option = function | Gc -> if not (RC.is_zero ref_count) then ( - ref_leak_detected (fun () -> + ref_leak_detected thread_id (fun () -> if RC.is_zero ref_count then ( Log.warn (fun f -> f "@[Reference GC'd with non-zero ref-count!@,%t@,\ But, ref-count is now zero, so a previous GC leak must have fixed it.@]" diff --git a/capnp-rpc/debug.ml b/capnp-rpc/proto/debug.ml similarity index 100% rename from capnp-rpc/debug.ml rename to capnp-rpc/proto/debug.ml diff --git a/capnp-rpc/debug.mli b/capnp-rpc/proto/debug.mli similarity index 95% rename from capnp-rpc/debug.mli rename to capnp-rpc/proto/debug.mli index 26fcc760e..f5cf7832a 100644 --- a/capnp-rpc/debug.mli +++ b/capnp-rpc/proto/debug.mli @@ -15,6 +15,7 @@ val pp_exn : exn Fmt.t (** [pp_exn] is like [Fmt.exn], but pretty-prints [Invariant_broken]. *) val failf : ('a, Format.formatter, unit, 'b) format4 -> 'a +[@@deprecated "Use Fmt.failwith instead"] (** [failf msg] raises [Failure msg]. *) val invariant_broken : (Format.formatter -> unit) -> 'a diff --git a/capnp-rpc/proto/dune b/capnp-rpc/proto/dune new file mode 100644 index 000000000..c7ad1b496 --- /dev/null +++ b/capnp-rpc/proto/dune @@ -0,0 +1,4 @@ +(library + (name capnp_rpc_proto) + (public_name capnp-rpc.proto) + (libraries astring fmt logs stdint threads)) diff --git a/capnp-rpc/dyn_array.ml b/capnp-rpc/proto/dyn_array.ml similarity index 100% rename from capnp-rpc/dyn_array.ml rename to capnp-rpc/proto/dyn_array.ml diff --git a/capnp-rpc/error.ml b/capnp-rpc/proto/error.ml similarity index 100% rename from capnp-rpc/error.ml rename to capnp-rpc/proto/error.ml diff --git a/capnp-rpc/exception.ml b/capnp-rpc/proto/exception.ml similarity index 100% rename from capnp-rpc/exception.ml rename to capnp-rpc/proto/exception.ml diff --git a/capnp-rpc/id.ml b/capnp-rpc/proto/id.ml similarity index 100% rename from capnp-rpc/id.ml rename to capnp-rpc/proto/id.ml diff --git a/capnp-rpc/local_struct_promise.ml b/capnp-rpc/proto/local_struct_promise.ml similarity index 100% rename from capnp-rpc/local_struct_promise.ml rename to capnp-rpc/proto/local_struct_promise.ml diff --git a/capnp-rpc/local_struct_promise.mli b/capnp-rpc/proto/local_struct_promise.mli similarity index 100% rename from capnp-rpc/local_struct_promise.mli rename to capnp-rpc/proto/local_struct_promise.mli diff --git a/capnp-rpc/message_types.ml b/capnp-rpc/proto/message_types.ml similarity index 100% rename from capnp-rpc/message_types.ml rename to capnp-rpc/proto/message_types.ml diff --git a/capnp-rpc/rC.ml b/capnp-rpc/proto/rC.ml similarity index 67% rename from capnp-rpc/rC.ml rename to capnp-rpc/proto/rC.ml index 4e233b4fd..3492ae172 100644 --- a/capnp-rpc/rC.ml +++ b/capnp-rpc/proto/rC.ml @@ -13,14 +13,14 @@ let sum ~pp:pp_obj t d = if t > 0 then ( let t' = t + d in if t' < 0 then ( - if d > 0 then Debug.failf "Ref-count %a + %d would wrap!" pp t d pp_obj - else Debug.failf "Ref-count %a - %d would go negative!" pp t (-d) pp_obj + if d > 0 then Fmt.failwith "Ref-count %a + %d would wrap!" pp t d pp_obj + else Fmt.failwith "Ref-count %a - %d would go negative!" pp t (-d) pp_obj ); t' ) else if d >= 0 then ( - Debug.failf "Attempt to change ref-count (to %a+%d) on freed resource %t" pp t d pp_obj + Fmt.failwith "Attempt to change ref-count (to %a+%d) on freed resource %t" pp t d pp_obj ) else ( - Debug.failf "Attempt to change ref-count (to %a%d) on freed resource %t" pp t d pp_obj + Fmt.failwith "Attempt to change ref-count (to %a%d) on freed resource %t" pp t d pp_obj ) let succ ~pp t = sum ~pp t 1 diff --git a/capnp-rpc/rC.mli b/capnp-rpc/proto/rC.mli similarity index 100% rename from capnp-rpc/rC.mli rename to capnp-rpc/proto/rC.mli diff --git a/capnp-rpc/rO_array.ml b/capnp-rpc/proto/rO_array.ml similarity index 100% rename from capnp-rpc/rO_array.ml rename to capnp-rpc/proto/rO_array.ml diff --git a/capnp-rpc/rO_array.mli b/capnp-rpc/proto/rO_array.mli similarity index 100% rename from capnp-rpc/rO_array.mli rename to capnp-rpc/proto/rO_array.mli diff --git a/capnp-rpc/s.ml b/capnp-rpc/proto/s.ml similarity index 97% rename from capnp-rpc/s.ml rename to capnp-rpc/proto/s.ml index a846fcebb..0e6e215cd 100644 --- a/capnp-rpc/s.ml +++ b/capnp-rpc/proto/s.ml @@ -57,16 +57,16 @@ module type WIRE = sig (** The (empty) content for the reply to the bootstrap message. *) end - val ref_leak_detected : (unit -> unit) -> unit - (** [ref_leak_detected fn] is called when a promise or capability is GC'd while + val ref_leak_detected : int -> (unit -> unit) -> unit + (** [ref_leak_detected thread_id fn] is called when a promise or capability is GC'd while its ref-count is non-zero, indicating that resources may have been leaked. [fn ()] will log a warning about this and free the resources itself. The reason for going via [ref_leak_detected] rather than calling [fn] directly is because the OCaml GC may detect the problem at any point (e.g. while we're sending another message). The implementation should arrange for [fn] to be - called at a safe point (e.g. when returning to the main loop). - Unit-tests may wish to call [fn] immediately to show the error and then - fail the test. *) + called at a safe point in thread [thread_id] (e.g. when returning to the + thread's main loop). Unit-tests may wish to call [fn] immediately to show + the error and then fail the test. *) end module type PAYLOAD = sig diff --git a/capnp-rpc/stats.ml b/capnp-rpc/proto/stats.ml similarity index 100% rename from capnp-rpc/stats.ml rename to capnp-rpc/proto/stats.ml diff --git a/capnp-rpc/struct_proxy.ml b/capnp-rpc/proto/struct_proxy.ml similarity index 97% rename from capnp-rpc/struct_proxy.ml rename to capnp-rpc/proto/struct_proxy.ml index e7b996b91..37ac70754 100644 --- a/capnp-rpc/struct_proxy.ml +++ b/capnp-rpc/proto/struct_proxy.ml @@ -1,5 +1,3 @@ -open Asetmap - module Log = Debug.Log module Make (C : S.CORE_TYPES) = struct @@ -73,8 +71,6 @@ module Make (C : S.CORE_TYPES) = struct | Forwarding of struct_ref | Finished - let pp_fields = Field_map.dump (fun f (k, v) -> Fmt.pf f "%a:%a" Wire.Path.pp k RC.pp v.ref_count) - let pp_opt_blocked_on f = function | None -> () | Some b -> Fmt.pf f " (blocked on %t)" b#pp @@ -239,7 +235,7 @@ module Make (C : S.CORE_TYPES) = struct dispatch state ~unresolved:(fun u -> let field = - match Field_map.find path u.fields with + match Field_map.find_opt path u.fields with | Some f -> f | None -> let cap = field path (self :> struct_ref_internal) in @@ -393,7 +389,7 @@ module Make (C : S.CORE_TYPES) = struct ~unresolved:(fun u -> (* When we resolve, we'll be holding references to all the caps in the resolution, so so they must still be alive by the time we pass on any extra inc or dec refs. *) - let f = Field_map.get path u.fields in + let f = Field_map.find path u.fields in assert (f.ref_count > RC.one); (* rc can't be one because that's our reference *) let pp = self#field_pp path in f.ref_count <- RC.sum f.ref_count d ~pp @@ -406,7 +402,7 @@ module Make (C : S.CORE_TYPES) = struct method field_dec_ref path = dispatch state ~unresolved:(fun u -> - let f = Field_map.get path u.fields in + let f = Field_map.find path u.fields in assert (f.ref_count > RC.one); (* rc can't be one because that's our reference *) let pp = self#field_pp path in f.ref_count <- RC.pred f.ref_count ~pp @@ -424,18 +420,18 @@ module Make (C : S.CORE_TYPES) = struct method field_check_invariants i = dispatch state ~unresolved:(fun u -> - let f = Field_map.get i u.fields in + let f = Field_map.find i u.fields in assert (f.ref_count > RC.one); self#check_invariants ) - ~forwarding:(fun _ -> Debug.failf "Promise is resolved, but field %a isn't!" Wire.Path.pp i) + ~forwarding:(fun _ -> Fmt.failwith "Promise is resolved, but field %a isn't!" Wire.Path.pp i) method field_pp path f = match state with | Finished -> Fmt.pf f "Promise is finished, but field %a isn't!" Wire.Path.pp path | Forwarding _ -> Fmt.pf f "Promise is resolved, but field %a isn't!" Wire.Path.pp path | Unresolved u -> - let field = Field_map.get path u.fields in + let field = Field_map.find path u.fields in match RC.to_int field.ref_count with | None -> Fmt.pf f "(rc=LEAKED) -> #%a -> %t" Wire.Path.pp path self#pp diff --git a/capnp-rpc/table.ml b/capnp-rpc/proto/table.ml similarity index 100% rename from capnp-rpc/table.ml rename to capnp-rpc/proto/table.ml diff --git a/capnp-rpc/weak_ptr.ml b/capnp-rpc/proto/weak_ptr.ml similarity index 100% rename from capnp-rpc/weak_ptr.ml rename to capnp-rpc/proto/weak_ptr.ml diff --git a/capnp-rpc/weak_ptr.mli b/capnp-rpc/proto/weak_ptr.mli similarity index 100% rename from capnp-rpc/weak_ptr.mli rename to capnp-rpc/proto/weak_ptr.mli diff --git a/capnp-rpc-lwt/request.ml b/capnp-rpc/request.ml similarity index 95% rename from capnp-rpc-lwt/request.ml rename to capnp-rpc/request.ml index bb301a643..06ed1adbf 100644 --- a/capnp-rpc-lwt/request.ml +++ b/capnp-rpc/request.ml @@ -1,6 +1,6 @@ open Capnp_core open Schema.Builder -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array module StructStorage = Capnp.Message.BytesMessage.StructStorage type 'a t = Message.t diff --git a/capnp-rpc-lwt/request.mli b/capnp-rpc/request.mli similarity index 84% rename from capnp-rpc-lwt/request.mli rename to capnp-rpc/request.mli index 524265770..2b026dcc0 100644 --- a/capnp-rpc-lwt/request.mli +++ b/capnp-rpc/request.mli @@ -1,6 +1,6 @@ type 'a t -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array val create : ?message_size:int -> (Capnp.Message.rw Capnp.BytesMessage.Slice.t -> 'a) -> 'a t * 'a val create_no_args : unit -> 'a t diff --git a/capnp-rpc-lwt/response.ml b/capnp-rpc/response.ml similarity index 95% rename from capnp-rpc-lwt/response.ml rename to capnp-rpc/response.ml index 3afd60cd7..f7a3746b2 100644 --- a/capnp-rpc-lwt/response.ml +++ b/capnp-rpc/response.ml @@ -1,6 +1,6 @@ open Capnp_core open Schema.Builder -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array module StructStorage = Capnp.Message.BytesMessage.StructStorage type 'a cap = Core_types.cap diff --git a/capnp-rpc-lwt/rpc_schema.capnp b/capnp-rpc/rpc_schema.capnp similarity index 100% rename from capnp-rpc-lwt/rpc_schema.capnp rename to capnp-rpc/rpc_schema.capnp diff --git a/capnp-rpc-lwt/schema.ml b/capnp-rpc/schema.ml similarity index 100% rename from capnp-rpc-lwt/schema.ml rename to capnp-rpc/schema.ml diff --git a/capnp-rpc/service.ml b/capnp-rpc/service.ml new file mode 100644 index 000000000..01b0e40ec --- /dev/null +++ b/capnp-rpc/service.ml @@ -0,0 +1,69 @@ +open Capnp_core + +module Log = Capnp_rpc_proto.Debug.Log + +module Response = Response +module RO_array = Capnp_rpc_proto.RO_array + +type abstract_response_promise = Core_types.struct_ref + +type abstract + +type abstract_method_t = + abstract Schema.reader_t -> (unit -> unit) -> abstract_response_promise + +type 'a response_promise = abstract_response_promise +type ('a, 'b) method_t = 'a -> (unit -> unit) -> Core_types.struct_ref + +let pp_method = Capnp.RPC.Registry.pp_method + +class type generic = object + method dispatch : interface_id:Stdint.Uint64.t -> method_id:int -> abstract_method_t + method release : unit + method pp : Format.formatter -> unit +end + +let local (s:#generic) = + object (_ : Core_types.cap) + inherit Core_types.service as super + + method! pp f = Fmt.pf f "%t(%t)" s#pp super#pp_refcount + + method! private release = + super#release; + s#release + + method call results msg = + let open Schema.Reader in + let call = Msg.Request.readable msg in + let interface_id = Call.interface_id_get call in + let method_id = Call.method_id_get call in + Log.debug (fun f -> f "Invoking local method %a" pp_method (interface_id, method_id)); + let p = Call.params_get call in + let m : abstract_method_t = s#dispatch ~interface_id ~method_id in + let release_params () = Core_types.Request_payload.release msg in + let contents : abstract Schema.reader_t = + Payload.content_get p |> Schema.ReaderOps.deref_opt_struct_pointer |> Schema.ReaderOps.cast_struct in + match m contents release_params with + | r -> results#resolve r + | exception (Eio.Cancel.Cancelled _ as ex) -> + release_params (); + Core_types.resolve_payload results (Error `Cancelled); + raise ex + | exception ex -> + release_params (); + Log.warn (fun f -> f "Uncaught exception handling %a: %a" pp_method (interface_id, method_id) Fmt.exn ex); + Core_types.resolve_payload results + (Error (Capnp_rpc_proto.Error.exn "Internal error from %a" pp_method (interface_id, method_id))) + end + +(* The simple case for returning a message (rather than another value). *) +let return resp = + Core_types.return @@ Response.finish resp + +let return_empty () = + return @@ Response.create_empty () + +let fail = Core_types.fail + +let error = Core_types.broken_struct diff --git a/capnp-rpc/sturdy_ref.ml b/capnp-rpc/sturdy_ref.ml new file mode 100644 index 000000000..3841ea672 --- /dev/null +++ b/capnp-rpc/sturdy_ref.ml @@ -0,0 +1,25 @@ +class type [+'a] t = Capnp_core.sturdy_ref + +let connect t = t#connect + +let connect_exn t = + match connect t with + | Ok x -> x + | Error e -> failwith (Fmt.to_to_string Capnp_rpc_proto.Exception.pp e) + +let reader fn s = + fn s |> Schema.ReaderOps.string_of_pointer |> Uri.of_string + +let builder fn (s : 'a Capnp.BytesMessage.StructStorage.builder_t) (sr : 'a t) = + sr#to_uri_with_secrets |> Uri.to_string |> Schema.BuilderOps.write_string (fn s) + +let cast t = t + +let with_cap t f = + match connect t with + | Ok x -> Capability.with_ref x f + | Error e -> Error (`Capnp e) + +let with_cap_exn t f = + let x = connect_exn t in + Capability.with_ref x f diff --git a/capnp-rpc-lwt/xform.ml b/capnp-rpc/xform.ml similarity index 100% rename from capnp-rpc-lwt/xform.ml rename to capnp-rpc/xform.ml diff --git a/capnp-rpc-lwt/xform.mli b/capnp-rpc/xform.mli similarity index 100% rename from capnp-rpc-lwt/xform.mli rename to capnp-rpc/xform.mli diff --git a/dune-project b/dune-project index df0f4945f..727b33d03 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.0) +(lang dune 3.16) (name capnp-rpc) diff --git a/examples/pipelining/dune b/examples/pipelining/dune index fc80455c8..c3b83a62c 100644 --- a/examples/pipelining/dune +++ b/examples/pipelining/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-unix logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc-unix mirage-crypto-rng-eio logs.fmt)) (rule (targets echo_api.ml echo_api.mli) diff --git a/examples/pipelining/echo.ml b/examples/pipelining/echo.ml index a293321b3..e05728db2 100644 --- a/examples/pipelining/echo.ml +++ b/examples/pipelining/echo.ml @@ -1,7 +1,7 @@ -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Callback = struct let local fn = @@ -26,23 +26,23 @@ module Callback = struct Capability.call_for_unit t method_id request end -let (>>!=) = Lwt_result.bind (* Return errors *) - -let notify callback ~msg = +let notify ~delay msg callback = let rec loop = function | 0 -> - Lwt.return @@ Ok (Service.Response.create_empty ()) + Service.return_empty () | i -> - Callback.log callback msg >>!= fun () -> - Lwt_unix.sleep 1.0 >>= fun () -> - loop (i - 1) + match Callback.log callback msg with + | Error (`Capnp e) -> Service.error e + | Ok () -> + Eio.Time.Timeout.sleep delay; + loop (i - 1) in loop 3 let service_logger = - Callback.local (Printf.printf "[server] Received %S\n%!") + Callback.local (traceln "[server] Received %S") -let local = +let local ~delay = let module Echo = Api.Service.Echo in Echo.local @@ object inherit Echo.service @@ -63,8 +63,7 @@ let local = match callback with | None -> Service.fail "No callback parameter!" | Some callback -> - Service.return_lwt @@ fun () -> - Capability.with_ref callback (notify ~msg) + Capability.with_ref callback (notify ~delay msg) (* $MDX part-begin=server-get-logger *) method get_logger_impl _ release_params = @@ -82,7 +81,7 @@ let ping t msg = let open Echo.Ping in let request, params = Capability.Request.create Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get let heartbeat t msg callback = let open Echo.Heartbeat in diff --git a/examples/pipelining/main.ml b/examples/pipelining/main.ml index 8d0adbd94..123e735fa 100644 --- a/examples/pipelining/main.ml +++ b/examples/pipelining/main.ml @@ -1,17 +1,19 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std + +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg (* $MDX part-begin=run-client *) let run_client service = let logger = Echo.get_logger service in - Echo.Callback.log logger "Message from client" >|= function + match Echo.Callback.log logger "Message from client" with | Ok () -> () | Error (`Capnp err) -> Fmt.epr "Server's logger failed: %a" Capnp_rpc.Error.pp err @@ -20,18 +22,22 @@ let run_client service = let secret_key = `Ephemeral let listen_address = `TCP ("127.0.0.1", 7000) -let start_server () = +let start_server ~sw ~delay net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in - let restore = Capnp_rpc_net.Restorer.single service_id Echo.local in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> + let service = Echo.local ~delay in + Switch.on_release sw (fun () -> Capability.dec_ref service); + let restore = Capnp_rpc_net.Restorer.single service_id service in + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in Capnp_rpc_unix.Vat.sturdy_uri vat service_id let () = - Lwt_main.run begin - start_server () >>= fun uri -> - Fmt.pr "[client] Connecting to echo service...@."; - let client_vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in - Sturdy_ref.with_cap_exn sr run_client - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + let uri = start_server ~sw ~delay env#net in + traceln "[client] Connecting to echo service..."; + let client_vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in + Sturdy_ref.with_cap_exn sr run_client diff --git a/examples/sturdy-refs-2/dune b/examples/sturdy-refs-2/dune index 137d3fd39..cfebddc5a 100644 --- a/examples/sturdy-refs-2/dune +++ b/examples/sturdy-refs-2/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-unix logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc-unix mirage-crypto-rng-eio logs.fmt)) (rule (targets api.ml api.mli) diff --git a/examples/sturdy-refs-2/logger.ml b/examples/sturdy-refs-2/logger.ml index 9d83494c1..c5940516d 100644 --- a/examples/sturdy-refs-2/logger.ml +++ b/examples/sturdy-refs-2/logger.ml @@ -1,6 +1,6 @@ -module Api = Api.MakeRPC(Capnp_rpc_lwt) +module Api = Api.MakeRPC(Capnp_rpc) -open Capnp_rpc_lwt +open Capnp_rpc.Std let rec local label = let module Logger = Api.Service.Logger in diff --git a/examples/sturdy-refs-2/main.ml b/examples/sturdy-refs-2/main.ml index 025035432..9104cf391 100644 --- a/examples/sturdy-refs-2/main.ml +++ b/examples/sturdy-refs-2/main.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Restorer = Capnp_rpc_net.Restorer @@ -14,7 +14,7 @@ let or_fail = function | Ok x -> x | Error (`Msg m) -> failwith m -let start_server () = +let start_server ~sw net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in let services = Restorer.Table.create make_sturdy in @@ -22,20 +22,22 @@ let start_server () = let root_id = Capnp_rpc_unix.Vat_config.derived_id config "root" in let root = Logger.local "root" in Restorer.Table.add services root_id root; - Capnp_rpc_unix.serve config ~restore >|= fun _vat -> + let _vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in Capnp_rpc_unix.Vat_config.sturdy_uri config root_id (* $MDX part-begin=main *) let () = - Lwt_main.run begin - start_server () >>= fun root_uri -> - let vat = Capnp_rpc_unix.client_only_vat () in - let root_sr = Capnp_rpc_unix.Vat.import vat root_uri |> or_fail in - Sturdy_ref.with_cap_exn root_sr @@ fun root -> - Logger.log root "Message from Admin" >>= fun () -> - Capability.with_ref (Logger.sub root "alice") @@ fun for_alice -> - Capability.with_ref (Logger.sub root "bob") @@ fun for_bob -> - Logger.log for_alice "Message from Alice" >>= fun () -> - Logger.log for_bob "Message from Bob" - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let net = env#net in + let root_uri = start_server ~sw net in + let vat = Capnp_rpc_unix.client_only_vat ~sw net in + let root_sr = Capnp_rpc_unix.Vat.import vat root_uri |> or_fail in + Sturdy_ref.with_cap_exn root_sr @@ fun root -> + Logger.log root "Message from Admin"; + Capability.with_ref (Logger.sub root "alice") @@ fun for_alice -> + Capability.with_ref (Logger.sub root "bob") @@ fun for_bob -> + Logger.log for_alice "Message from Alice"; + Logger.log for_bob "Message from Bob" (* $MDX part-end *) diff --git a/examples/sturdy-refs-3/dune b/examples/sturdy-refs-3/dune index 137d3fd39..cfebddc5a 100644 --- a/examples/sturdy-refs-3/dune +++ b/examples/sturdy-refs-3/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-unix logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc-unix mirage-crypto-rng-eio logs.fmt)) (rule (targets api.ml api.mli) diff --git a/examples/sturdy-refs-3/logger.ml b/examples/sturdy-refs-3/logger.ml index d75df1344..9c9254ce2 100644 --- a/examples/sturdy-refs-3/logger.ml +++ b/examples/sturdy-refs-3/logger.ml @@ -1,11 +1,11 @@ -module Api = Api.MakeRPC(Capnp_rpc_lwt) +module Api = Api.MakeRPC(Capnp_rpc) -open Capnp_rpc_lwt +open Capnp_rpc.Std (* $MDX part-begin=local *) let rec local ~services sr label = let module Logger = Api.Service.Logger in - Persistence.with_sturdy_ref sr Logger.local @@ object + Capnp_rpc.Persistence.with_sturdy_ref sr Logger.local @@ object (* $MDX part-end *) inherit Logger.service diff --git a/examples/sturdy-refs-3/main.ml b/examples/sturdy-refs-3/main.ml index 63ed200cf..f02a37ba3 100644 --- a/examples/sturdy-refs-3/main.ml +++ b/examples/sturdy-refs-3/main.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Restorer = Capnp_rpc_net.Restorer @@ -14,11 +14,11 @@ let or_fail = function | Ok x -> x | Error (`Msg m) -> failwith m -let start_server ~switch () = +let start_server ~sw net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in let services = Restorer.Table.create make_sturdy in - Lwt_switch.add_hook (Some switch) (fun () -> Restorer.Table.clear services; Lwt.return_unit); + Switch.on_release sw (fun () -> Restorer.Table.clear services); let restore = Restorer.of_table services in (* $MDX part-begin=root *) let root_id = Capnp_rpc_unix.Vat_config.derived_id config "root" in @@ -28,31 +28,30 @@ let start_server ~switch () = in (* $MDX part-end *) Restorer.Table.add services root_id root; - Capnp_rpc_unix.serve ~switch config ~restore >|= fun _vat -> + let _vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in Capnp_rpc_unix.Vat_config.sturdy_uri config root_id -let run_client cap_file = - Lwt_switch.with_switch @@ fun switch -> - let vat = Capnp_rpc_unix.client_only_vat ~switch () in +let run_client ~net cap_file = + Switch.run @@ fun sw -> + let vat = Capnp_rpc_unix.client_only_vat ~sw net in let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in Sturdy_ref.with_cap_exn sr @@ fun for_alice -> Logger.log for_alice "Message from Alice" let () = - Lwt_main.run begin - Lwt_switch.with_switch @@ fun switch -> - start_server ~switch () >>= fun root_uri -> - let vat = Capnp_rpc_unix.client_only_vat ~switch () in - let root_sr = Capnp_rpc_unix.Vat.import vat root_uri |> or_fail in - Sturdy_ref.with_cap_exn root_sr @@ fun root -> - Logger.log root "Message from Admin" >>= fun () -> - (* $MDX part-begin=save *) - (* The admin creates a logger for Alice and saves it: *) - Capability.with_ref (Logger.sub root "alice") (fun for_alice -> - Persistence.save_exn for_alice >|= fun uri -> - Capnp_rpc_unix.Cap_file.save_uri uri "alice.cap" |> or_fail - ) >>= fun () -> - (* Alice uses it: *) - run_client "alice.cap" - (* $MDX part-end *) - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let net = env#net in + let root_uri = start_server ~sw net in + let vat = Capnp_rpc_unix.client_only_vat ~sw net in + let root_sr = Capnp_rpc_unix.Vat.import vat root_uri |> or_fail in + Sturdy_ref.with_cap_exn root_sr @@ fun root -> + Logger.log root "Message from Admin"; + (* $MDX part-begin=save *) + (* The admin creates a logger for Alice and saves it: *) + let uri = Capability.with_ref (Logger.sub root "alice") Capnp_rpc.Persistence.save_exn in + Capnp_rpc_unix.Cap_file.save_uri uri "alice.cap" |> or_fail; + (* Alice uses it: *) + run_client ~net "alice.cap" + (* $MDX part-end *) diff --git a/examples/sturdy-refs-4/db.ml b/examples/sturdy-refs-4/db.ml index 32bcada09..b9bb244ba 100644 --- a/examples/sturdy-refs-4/db.ml +++ b/examples/sturdy-refs-4/db.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std open Capnp_rpc_net module File_store = Capnp_rpc_unix.File_store @@ -9,7 +9,7 @@ type loader = [`Logger_beacebd78653e9af] Sturdy_ref.t -> label:string -> Restore type t = { store : Store.Reader.SavedService.struct_t File_store.t; - loader : loader Lwt.t; + loader : loader Promise.t; make_sturdy : Restorer.Id.t -> Uri.t; } @@ -32,16 +32,17 @@ let save_new t ~label = let load t sr digest = match File_store.load t.store ~digest with - | None -> Lwt.return Restorer.unknown_service_id + | None -> Restorer.unknown_service_id | Some saved_service -> let logger = Store.Reader.SavedService.logger_get saved_service in let label = Store.Reader.SavedLogger.label_get logger in - let sr = Capnp_rpc_lwt.Sturdy_ref.cast sr in - t.loader >|= fun loader -> + let sr = Capnp_rpc.Sturdy_ref.cast sr in + let loader = Promise.await t.loader in loader sr ~label let create ~make_sturdy dir = - let loader, set_loader = Lwt.wait () in - if not (Sys.file_exists dir) then Unix.mkdir dir 0o755; + let loader, set_loader = Promise.create () in + if not (Eio.Path.is_directory dir) then + Eio.Path.mkdir dir ~perm:0o755; let store = File_store.create dir in {store; loader; make_sturdy}, set_loader diff --git a/examples/sturdy-refs-4/db.mli b/examples/sturdy-refs-4/db.mli index 6ededf061..349ea573c 100644 --- a/examples/sturdy-refs-4/db.mli +++ b/examples/sturdy-refs-4/db.mli @@ -1,4 +1,4 @@ -open Capnp_rpc_lwt +open Capnp_rpc.Std open Capnp_rpc_net include Restorer.LOADER @@ -6,7 +6,7 @@ include Restorer.LOADER type loader = [`Logger_beacebd78653e9af] Sturdy_ref.t -> label:string -> Restorer.resolution (** A function to create a new in-memory logger with the given label and sturdy-ref. *) -val create : make_sturdy:(Restorer.Id.t -> Uri.t) -> string -> t * loader Lwt.u +val create : make_sturdy:(Restorer.Id.t -> Uri.t) -> _ Eio.Path.t -> t * loader Eio.Promise.u (** [create ~make_sturdy dir] is a database that persists services in [dir] and a resolver to let you set the loader (we're not ready to set the loader when we create the database). *) diff --git a/examples/sturdy-refs-4/dune b/examples/sturdy-refs-4/dune index 97144379c..364c6ebba 100644 --- a/examples/sturdy-refs-4/dune +++ b/examples/sturdy-refs-4/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-unix logs.fmt cmdliner) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc-unix mirage-crypto-rng-eio logs.fmt cmdliner)) (rule (targets api.ml api.mli) diff --git a/examples/sturdy-refs-4/logger.ml b/examples/sturdy-refs-4/logger.ml index c20d7ab55..af66c8a69 100644 --- a/examples/sturdy-refs-4/logger.ml +++ b/examples/sturdy-refs-4/logger.ml @@ -1,12 +1,10 @@ -open Lwt.Infix +module Api = Api.MakeRPC(Capnp_rpc) -module Api = Api.MakeRPC(Capnp_rpc_lwt) - -open Capnp_rpc_lwt +open Capnp_rpc.Std let local ~persist_new sr label = let module Logger = Api.Service.Logger in - Persistence.with_sturdy_ref sr Logger.local @@ object + Capnp_rpc.Persistence.with_sturdy_ref sr Logger.local @@ object inherit Logger.service method log_impl params release_param_caps = @@ -22,14 +20,13 @@ let local ~persist_new sr label = let sub_label = Params.label_get params in release_param_caps (); let label = Printf.sprintf "%s/%s" label sub_label in - Service.return_lwt @@ fun () -> - persist_new ~label >|= function - | Error e -> Error (`Capnp (`Exception e)) + match persist_new ~label with + | Error e -> Service.error (`Exception e) | Ok logger -> let response, results = Service.Response.create Results.init_pointer in Results.logger_set results (Some logger); Capability.dec_ref logger; - Ok response + Service.return response (* $MDX part-end *) method! pp f = diff --git a/examples/sturdy-refs-4/main.ml b/examples/sturdy-refs-4/main.ml index 6746cb400..a09f9ea7a 100644 --- a/examples/sturdy-refs-4/main.ml +++ b/examples/sturdy-refs-4/main.ml @@ -1,8 +1,10 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Restorer = Capnp_rpc_net.Restorer +let ( / ) = Eio.Path.( / ) + let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) @@ -13,56 +15,58 @@ let or_fail = function (* $MDX part-begin=server *) let serve config = - Lwt_main.run begin - (* Create the on-disk store *) - let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in - let db, set_loader = Db.create ~make_sturdy "./store" in - (* Create the restorer *) - let services = Restorer.Table.of_loader (module Db) db in - let restore = Restorer.of_table services in - (* Add the root service *) - let persist_new ~label = - let id = Db.save_new db ~label in - Capnp_rpc_net.Restorer.restore restore id - in - let root_id = Capnp_rpc_unix.Vat_config.derived_id config "root" in - let root = - let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services root_id in - Logger.local ~persist_new sr "root" - in - Restorer.Table.add services root_id root; - (* Tell the database how to restore saved loggers *) - Lwt.wakeup set_loader (fun sr ~label -> Restorer.grant @@ Logger.local ~persist_new sr label); - (* Run the server *) - Capnp_rpc_unix.serve config ~restore >>= fun _vat -> - let uri = Capnp_rpc_unix.Vat_config.sturdy_uri config root_id in - Capnp_rpc_unix.Cap_file.save_uri uri "admin.cap" |> or_fail; - print_endline "Wrote admin.cap"; - fst @@ Lwt.wait () (* Wait forever *) - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + (* Create the on-disk store *) + let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in + let db, set_loader = Db.create ~make_sturdy (env#cwd / "store") in + (* Create the restorer *) + let services = Restorer.Table.of_loader ~sw (module Db) db in + Switch.on_release sw (fun () -> Restorer.Table.clear services); + let restore = Restorer.of_table services in + (* Add the root service *) + let persist_new ~label = + let id = Db.save_new db ~label in + Capnp_rpc_net.Restorer.restore restore id + in + let root_id = Capnp_rpc_unix.Vat_config.derived_id config "root" in + let root = + let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services root_id in + Logger.local ~persist_new sr "root" + in + Restorer.Table.add services root_id root; + (* Tell the database how to restore saved loggers *) + Promise.resolve set_loader (fun sr ~label -> Restorer.grant @@ Logger.local ~persist_new sr label); + (* Run the server *) + let _vat = Capnp_rpc_unix.serve ~sw ~net:env#net ~restore config in + let uri = Capnp_rpc_unix.Vat_config.sturdy_uri config root_id in + Capnp_rpc_unix.Cap_file.save_uri uri "admin.cap" |> or_fail; + print_endline "Wrote admin.cap"; + Fiber.await_cancel () (* $MDX part-end *) let log cap_file msg = - Lwt_main.run begin - let vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in - Sturdy_ref.with_cap_exn sr @@ fun logger -> - Logger.log logger msg - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in + Sturdy_ref.with_cap_exn sr @@ fun logger -> + Logger.log logger msg let sub cap_file label = - Lwt_main.run begin - let sub_file = label ^ ".cap" in - if Sys.file_exists sub_file then Fmt.failwith "%S already exists!" sub_file; - let vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in - Sturdy_ref.with_cap_exn sr @@ fun logger -> - Capability.with_ref (Logger.sub logger label) @@ fun sub -> - Persistence.save_exn sub >>= fun uri -> - Capnp_rpc_unix.Cap_file.save_uri uri sub_file |> or_fail; - Printf.printf "Wrote %S\n%!" sub_file; - Lwt.return_unit - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let sub_file = label ^ ".cap" in + if Sys.file_exists sub_file then Fmt.failwith "%S already exists!" sub_file; + let vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in + Sturdy_ref.with_cap_exn sr @@ fun logger -> + let uri = Capability.with_ref (Logger.sub root "alice") Capnp_rpc.Persistence.save_exn in + Capnp_rpc_unix.Cap_file.save_uri uri sub_file |> or_fail; + Printf.printf "Wrote %S\n%!" sub_file; open Cmdliner diff --git a/examples/sturdy-refs/dune b/examples/sturdy-refs/dune index 137d3fd39..cfebddc5a 100644 --- a/examples/sturdy-refs/dune +++ b/examples/sturdy-refs/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-unix logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc-unix mirage-crypto-rng-eio logs.fmt)) (rule (targets api.ml api.mli) diff --git a/examples/sturdy-refs/logger.ml b/examples/sturdy-refs/logger.ml index ea5ae3b19..ad4267b29 100644 --- a/examples/sturdy-refs/logger.ml +++ b/examples/sturdy-refs/logger.ml @@ -1,6 +1,6 @@ -module Api = Api.MakeRPC(Capnp_rpc_lwt) +module Api = Api.MakeRPC(Capnp_rpc) -open Capnp_rpc_lwt +open Capnp_rpc.Std let local label = let module Logger = Api.Service.Logger in diff --git a/examples/sturdy-refs/main.ml b/examples/sturdy-refs/main.ml index 01492e265..8d8fb6578 100644 --- a/examples/sturdy-refs/main.ml +++ b/examples/sturdy-refs/main.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Restorer = Capnp_rpc_net.Restorer @@ -21,30 +21,33 @@ let make_service ~config ~services name = Restorer.Table.add services id service; name, id -let start_server () = +let start_server ~sw net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in let services = Restorer.Table.create make_sturdy in let restore = Restorer.of_table services in let services = List.map (make_service ~config ~services) ["alice"; "bob"] in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in services |> List.iter (fun (name, id) -> let cap_file = name ^ ".cap" in Capnp_rpc_unix.Cap_file.save_service vat id cap_file |> or_fail; Printf.printf "[server] saved %S\n%!" cap_file ) -let run_client cap_file msg = - let vat = Capnp_rpc_unix.client_only_vat () in +let run_client ~net cap_file msg = + Switch.run @@ fun sw -> + let vat = Capnp_rpc_unix.client_only_vat ~sw net in let sr = Capnp_rpc_unix.Cap_file.load vat cap_file |> or_fail in Printf.printf "[client] loaded %S\n%!" cap_file; Sturdy_ref.with_cap_exn sr @@ fun cap -> Logger.log cap msg let () = - Lwt_main.run begin - start_server () >>= fun () -> - run_client "./alice.cap" "Message from Alice" >>= fun () -> - run_client "./bob.cap" "Message from Bob" - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let net = env#net in + start_server ~sw net; + run_client ~net "./alice.cap" "Message from Alice"; + run_client ~net "./bob.cap" "Message from Bob" (* $MDX part-end *) diff --git a/examples/testlib/api.ml b/examples/testlib/api.ml index 827889900..2fb7185a0 100644 --- a/examples/testlib/api.ml +++ b/examples/testlib/api.ml @@ -1 +1 @@ -include Test_api.MakeRPC(Capnp_rpc_lwt) +include Test_api.MakeRPC(Capnp_rpc) diff --git a/examples/testlib/calc.ml b/examples/testlib/calc.ml index bac69b1f2..170a4d918 100644 --- a/examples/testlib/calc.ml +++ b/examples/testlib/calc.ml @@ -1,7 +1,7 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std -module Api = Calculator.MakeRPC(Capnp_rpc_lwt) +module Api = Calculator.MakeRPC(Capnp_rpc) type calc = [`Calculator_97983392df35cc36] type value = [`Value_c3e69d34d3ee48d2] @@ -85,10 +85,10 @@ module Value = struct let read v = let open Api.Client.Calculator.Value.Read in let req = Capability.Request.create_no_args () in - Capability.call_for_value_exn v method_id req >|= Results.value_get + Capability.call_for_value_exn v method_id req |> Results.value_get let final_read v = - read v >|= fun result -> + let result = read v in Capability.dec_ref v; result @@ -114,26 +114,31 @@ let call_fn fn args = let open Api.Client.Calculator.Function.Call in let req, p = Capability.Request.create Params.init_pointer in ignore (Params.params_set_list p args); - Capability.call_for_value_exn fn method_id req >|= Results.value_get + Capability.call_for_value_exn fn method_id req |> Results.value_get -let pp_result_lwt f x = - match Lwt.state x with - | Lwt.Return v -> Fmt.float f v - | Lwt.Fail ex -> Fmt.exn f ex - | Lwt.Sleep -> Fmt.string f "(still calculating)" +let pp_result_promise f x = + match Promise.peek x with + | Some (Ok v) -> Fmt.float f v + | Some (Error ex) -> Fmt.exn f ex + | None -> Fmt.string f "(still calculating)" -(* Evaluate an expression, where some sub-expressions may require remote calls. *) -let rec eval ?(args=[||]) : _ -> Api.Reader.Calculator.Value.t Capability.t = +(* Evaluate an expression, where some sub-expressions may require remote calls. + Immediately returns a service for the result, while the calculation continues in [sw]. *) +let rec eval ~sw ?(args=[||]) : _ -> Api.Reader.Calculator.Value.t Capability.t = let open Expr in function | Float f -> Value.local f | Prev v -> Capability.inc_ref v; v | Param p -> Value.local args.(p) | Call (f, params) -> - let params = params |> Lwt_list.map_p (fun p -> - let value = eval ~args p in - Value.final_read value - ) in - let result = params >>= call_fn f in + let result = Fiber.fork_promise ~sw (fun () -> + params + |> Fiber.List.map (fun p -> + let value = eval ~sw ~args p in + Value.final_read value + ) + |> call_fn f + ) + in let open Api.Service.Calculator in Value.local @@ object inherit Value.service @@ -141,17 +146,15 @@ let rec eval ?(args=[||]) : _ -> Api.Reader.Calculator.Value.t Capability.t = val id = Capnp_rpc.Debug.OID.next () method! pp f = - Fmt.pf f "EvalResultValue(%a) = %a" Capnp_rpc.Debug.OID.pp id pp_result_lwt result + Fmt.pf f "EvalResultValue(%a) = %a" Capnp_rpc.Debug.OID.pp id pp_result_promise result method read_impl _ release_params = let open Value.Read in release_params (); - Service.return_lwt (fun () -> - result >|= fun result -> - let resp, c = Service.Response.create Results.init_pointer in - Results.value_set c result; - Ok resp - ) + let result = Promise.await_exn result in + let resp, c = Service.Response.create Results.init_pointer in + Results.value_set c result; + Service.return resp end module Fn = struct @@ -168,15 +171,14 @@ module Fn = struct let open Function.Call in let args = Params.params_get_array params in assert (Array.length args = n_args); - let value = eval ~args body in - release_params (); (* Functions return floats, not Value objects, so we have to wait here. *) - Service.return_lwt (fun () -> - Value.final_read value >|= fun value -> - let resp, r = Service.Response.create ~message_size:200 Results.init_pointer in - Results.value_set r value; - Ok resp - ) + Switch.run @@ fun sw -> + let value = eval ~sw ~args body in + release_params (); + let value = Value.final_read value in + let resp, r = Service.Response.create ~message_size:200 Results.init_pointer in + Results.value_set r value; + Service.return resp end let local_binop op : Api.Builder.Calculator.Function.t Capability.t = @@ -204,7 +206,7 @@ module Fn = struct end (* The main calculator service *) -let local = +let local ~sw = let module Calculator = Api.Service.Calculator in Calculator.local @@ object inherit Calculator.service @@ -224,7 +226,7 @@ let local = let open Calculator.Evaluate in let expr = Expr.parse (Params.expression_get params) in release_params (); - let value_obj = eval expr in + let value_obj = eval ~sw expr in Expr.release expr; let resp, results = Service.Response.create ~message_size:200 Results.init_pointer in Results.value_set results (Some value_obj); diff --git a/examples/testlib/calc.mli b/examples/testlib/calc.mli index 8d6eb835e..115de8ff3 100644 --- a/examples/testlib/calc.mli +++ b/examples/testlib/calc.mli @@ -1,16 +1,16 @@ (** This is the OCaml version of the C++ capnp calculator example. *) -open Capnp_rpc_lwt +open Capnp_rpc.Std type t = [`Calculator_97983392df35cc36] Capability.t module rec Value : sig type t = [`Value_c3e69d34d3ee48d2] Capability.t - val read : t -> float Lwt.t + val read : t -> float (** [read t] reads the value of the remote value object. *) - val final_read : t -> float Lwt.t + val final_read : t -> float (** [final_read t] reads the value and dec_ref's [t]. *) val local : float -> t @@ -20,7 +20,7 @@ end and Fn : sig type t = [`Function_ede83a3d96840394] Capability.t - val call : t -> float list -> float Lwt.t + val call : t -> float list -> float (** [call fn args] does [fn args]. *) val local : int -> Expr.t -> Fn.t @@ -58,5 +58,6 @@ val evaluate : t -> Expr.t -> Value.t val getOperator : t -> [`Add | `Subtract | `Multiply | `Divide] -> Fn.t (** [getOperator t op] is a remote operator function provided by [t]. *) -val local : t -(** A capability to a local calculator service *) +val local : sw:Eio.Switch.t -> t +(** A capability to a local calculator service. + It may immediately return a promise of a result, while continuing the calculation in [sw]. *) diff --git a/examples/testlib/dune b/examples/testlib/dune index ca2e05ab6..5f665f4a8 100644 --- a/examples/testlib/dune +++ b/examples/testlib/dune @@ -1,7 +1,6 @@ (library (name testlib) - (libraries astring capnp-rpc-lwt capnp-rpc-net) - (flags :standard -w -53-55)) + (libraries astring capnp-rpc capnp-rpc-net)) (rule (targets test_api.ml test_api.mli) diff --git a/examples/testlib/echo.ml b/examples/testlib/echo.ml index f040f9f93..b99d1dd13 100644 --- a/examples/testlib/echo.ml +++ b/examples/testlib/echo.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std type t = Api.Service.Echo.t Capability.t @@ -10,7 +10,7 @@ let local () = Echo.local @@ object inherit Echo.service - val mutable blocked = Lwt.wait () + val mutable blocked = Promise.create () val mutable count = 0 val id = Capnp_rpc.Debug.OID.next () @@ -25,16 +25,15 @@ let local () = Results.reply_set results (Fmt.str "got:%d:%s" count msg); count <- count + 1; if Params.slow_get params then ( - Service.return_lwt (fun () -> - fst blocked >|= fun () -> Ok resp - ) + Promise.await (fst blocked); + Service.return resp ) else Service.return resp method unblock_impl _ release_params = release_params (); - Lwt.wakeup (snd blocked) (); - blocked <- Lwt.wait (); + Promise.resolve (snd blocked) (); + blocked <- Promise.create (); Service.return_empty () end @@ -45,14 +44,14 @@ let ping t ?(slow=false) msg = let req, p = Capability.Request.create Params.init_pointer in Params.slow_set p slow; Params.msg_set p msg; - Capability.call_for_value_exn t method_id req >|= Results.reply_get + Capability.call_for_value_exn t method_id req |> Results.reply_get let ping_result t ?(slow=false) msg = let open Echo.Ping in let req, p = Capability.Request.create Params.init_pointer in Params.slow_set p slow; Params.msg_set p msg; - Capability.call_for_value t method_id req >|= function + match Capability.call_for_value t method_id req with | Ok x -> Ok (Results.reply_get x) | Error _ as e -> e diff --git a/examples/testlib/echo.mli b/examples/testlib/echo.mli index f42797de0..dfc54381d 100644 --- a/examples/testlib/echo.mli +++ b/examples/testlib/echo.mli @@ -1,17 +1,17 @@ -open Capnp_rpc_lwt +open Capnp_rpc.Std type t = [`Echo_bb48258560861cec] Capability.t val local : unit -> t (** [local ()] is a capability to a new local echo service. *) -val ping : t -> ?slow:bool -> string -> string Lwt.t +val ping : t -> ?slow:bool -> string -> string (** [ping t msg] sends [msg] to [t] and returns its response. If [slow] is given, the service will wait until [unblock] is called before replying. *) -val ping_result : t -> ?slow:bool -> string -> (string, [> `Capnp of Capnp_rpc.Error.t]) Lwt_result.t +val ping_result : t -> ?slow:bool -> string -> (string, [> `Capnp of Capnp_rpc.Error.t]) result (** [ping t msg] sends [msg] to [t] and returns its response. If [slow] is given, the service will wait until [unblock] is called before replying. *) -val unblock : t -> unit Lwt.t +val unblock : t -> unit (** [unblock t] tells the service to return any blocked ping responses. *) diff --git a/examples/testlib/registry.ml b/examples/testlib/registry.ml index 513499b19..b7bc24566 100644 --- a/examples/testlib/registry.ml +++ b/examples/testlib/registry.ml @@ -1,5 +1,5 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std type t = Api.Service.Registry.t Capability.t @@ -17,12 +17,12 @@ let version_service = Service.return resp end -let local () = +let local ~sw () = let module Registry = Api.Service.Registry in Registry.local @@ object inherit Registry.service - val mutable blocked = Lwt.wait () + val mutable blocked = Promise.create () val mutable echo_service = Echo.local () method! release = Capability.dec_ref echo_service @@ -45,9 +45,8 @@ let local () = let open Registry.EchoService in let resp, results = Service.Response.create Results.init_pointer in Results.service_set results (Some echo_service); - Service.return_lwt (fun () -> - fst blocked >|= fun () -> Ok resp - ) + Promise.await (fst blocked); + Service.return resp method echo_service_promise_impl _params release_params = release_params (); @@ -56,8 +55,8 @@ let local () = let promise, resolver = Capability.promise () in Results.service_set results (Some promise); Capability.dec_ref promise; - Lwt.async (fun () -> - fst blocked >|= fun () -> + Fiber.fork ~sw (fun () -> + Promise.await (fst blocked); Capability.inc_ref echo_service; Capability.resolve_ok resolver echo_service ); @@ -65,8 +64,8 @@ let local () = method unblock_impl _ release_params = release_params (); - Lwt.wakeup (snd blocked) (); - blocked <- Lwt.wait (); + Promise.resolve (snd blocked) (); + blocked <- Promise.create (); Service.return_empty () method complex_impl _ release_params = @@ -131,5 +130,5 @@ module Version = struct let read t = let open Version.Read in let req = Capability.Request.create_no_args () in - Capability.call_for_value_exn t method_id req >|= Results.version_get + Capability.call_for_value_exn t method_id req |> Results.version_get end diff --git a/examples/testlib/registry.mli b/examples/testlib/registry.mli index f0e442ee8..7948b3e45 100644 --- a/examples/testlib/registry.mli +++ b/examples/testlib/registry.mli @@ -1,14 +1,15 @@ -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std module Version : sig type t = [`Version_ed7d11372e0a7243] Capability.t - val read : t -> string Lwt.t + val read : t -> string end type t = [`Registry_d9975f668b337b6d] Capability.t -val set_echo_service : t -> Echo.t -> unit Lwt.t +val set_echo_service : t -> Echo.t -> unit val echo_service : t -> Echo.t (** Waits until unblocked before returning. *) @@ -17,10 +18,10 @@ val echo_service_promise : t -> Echo.t (** Returns a promise immediately. Resolves promise when unblocked. (should appear to work the same as [echo_service] to users) *) -val unblock : t -> unit Lwt.t +val unblock : t -> unit val complex : t -> Echo.t * Version.t (** [complex t] returns two capabilities in a single, somewhat complex, message. *) -val local : unit -> t -(** [local ()] is a new local registry. *) +val local : sw:Switch.t -> unit -> t +(** [local ~sw ()] is a new local registry. *) diff --git a/examples/testlib/store.ml b/examples/testlib/store.ml index 5177d2747..1b5c94c1c 100644 --- a/examples/testlib/store.ml +++ b/examples/testlib/store.ml @@ -1,5 +1,4 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std open Capnp_rpc_net type digest = string @@ -57,11 +56,11 @@ module File = struct let get t = let open Api.Client.File.Get in let request = Capability.Request.create_no_args () in - Capability.call_for_value_exn t method_id request >|= Results.data_get + Capability.call_for_value_exn t method_id request |> Results.data_get let local (db:DB.t) sr digest = let module File = Api.Service.File in - Persistence.with_sturdy_ref sr File.local @@ object + Capnp_rpc.Persistence.with_sturdy_ref sr File.local @@ object inherit File.service method get_impl _ release_params = @@ -92,14 +91,14 @@ module File = struct let load t sr digest = if DB.mem t.db digest then ( let sr = Sturdy_ref.cast sr in - Lwt.return @@ Restorer.grant @@ local t.db sr digest + Restorer.grant @@ local t.db sr digest ) else ( - Lwt.return Restorer.unknown_service_id + Restorer.unknown_service_id ) end - let table ~make_sturdy db = - Restorer.Table.of_loader (module Loader) {Loader.db; make_sturdy} + let table ~sw ~make_sturdy db = + Restorer.Table.of_loader ~sw (module Loader) {Loader.db; make_sturdy} end type t = Api.Client.Store.t Capability.t @@ -121,12 +120,11 @@ let local ~restore db = let open Store.CreateFile in release_params (); let id = DB.add db in - Service.return_lwt @@ fun () -> - Restorer.restore restore id >|= function - | Error e -> Error (`Capnp (`Exception e)) + match Restorer.restore restore id with + | Error e -> Service.error (`Exception e) | Ok x -> let resp, results = Service.Response.create Results.init_pointer in Results.file_set results (Some x); Capability.dec_ref x; - Ok resp + Service.return resp end diff --git a/examples/testlib/store.mli b/examples/testlib/store.mli index b7ca9037c..487359654 100644 --- a/examples/testlib/store.mli +++ b/examples/testlib/store.mli @@ -2,7 +2,7 @@ The user can create a new file, get and set its contents, and get a sturdy ref to it. See [test_store] for an example using this. *) -open Capnp_rpc_lwt +open Capnp_rpc.Std open Capnp_rpc_net module DB : sig @@ -16,13 +16,13 @@ end module File : sig type t = [`File_aec5916d9557ed0e] Capability.t - val set : t -> string -> unit Lwt.t + val set : t -> string -> unit (** [set t data] saves [data] as [t]'s contents. *) - val get : t -> string Lwt.t + val get : t -> string (** [get t] is the current contents of [t]. *) - val table : make_sturdy:(Restorer.Id.t -> Uri.t) -> DB.t -> Restorer.Table.t + val table : sw:Eio.Switch.t -> make_sturdy:(Restorer.Id.t -> Uri.t) -> DB.t -> Restorer.Table.t (** [table ~make_sturdy db] is a table of file services, backed by [db]. [make_sturdy] is used to generate sturdy URIs for files. *) end diff --git a/examples/v1/dune b/examples/v1/dune index 9d2eaf789..dbb916768 100644 --- a/examples/v1/dune +++ b/examples/v1/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-lwt logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc logs.fmt)) (rule (targets echo_api.ml echo_api.mli) diff --git a/examples/v1/echo.ml b/examples/v1/echo.ml index 8fa53dbed..b4547b7bb 100644 --- a/examples/v1/echo.ml +++ b/examples/v1/echo.ml @@ -1,8 +1,7 @@ (* $MDX part-begin=server *) -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std let local = let module Echo = Api.Service.Echo in @@ -26,5 +25,5 @@ let ping t msg = let open Echo.Ping in let request, params = Capability.Request.create Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get (* $MDX part-end *) diff --git a/examples/v1/main.ml b/examples/v1/main.ml index a8a396bec..a15068fcb 100644 --- a/examples/v1/main.ml +++ b/examples/v1/main.ml @@ -1,13 +1,11 @@ -open Lwt.Infix +open Eio.Std let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let () = - Lwt_main.run begin - let service = Echo.local in - Echo.ping service "foo" >>= fun reply -> - Fmt.pr "Got reply %S@." reply; - Lwt.return_unit - end + Eio_main.run @@ fun _ -> + let service = Echo.local in + let reply = Echo.ping service "foo" in + traceln "Got reply %S" reply diff --git a/examples/v2/dune b/examples/v2/dune index 9d2eaf789..dbb916768 100644 --- a/examples/v2/dune +++ b/examples/v2/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-lwt logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc logs.fmt)) (rule (targets echo_api.ml echo_api.mli) diff --git a/examples/v2/echo.ml b/examples/v2/echo.ml index 933e76f35..1784dffa8 100644 --- a/examples/v2/echo.ml +++ b/examples/v2/echo.ml @@ -1,7 +1,6 @@ -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std module Callback = struct let local fn = @@ -27,21 +26,21 @@ module Callback = struct end (* $MDX part-begin=notify *) -let (>>!=) = Lwt_result.bind (* Return errors *) - -let notify callback ~msg = +let notify ~delay msg callback = let rec loop = function | 0 -> - Lwt.return @@ Ok (Service.Response.create_empty ()) + Service.return_empty () | i -> - Callback.log callback msg >>!= fun () -> - Lwt_unix.sleep 1.0 >>= fun () -> - loop (i - 1) + match Callback.log callback msg with + | Error (`Capnp e) -> Service.error e + | Ok () -> + Eio.Time.Timeout.sleep delay; + loop (i - 1) in loop 3 (* $MDX part-end *) -let local = +let local ~delay = let module Echo = Api.Service.Echo in Echo.local @@ object inherit Echo.service @@ -63,8 +62,7 @@ let local = match callback with | None -> Service.fail "No callback parameter!" | Some callback -> - Service.return_lwt @@ fun () -> - Capability.with_ref callback (notify ~msg) + Capability.with_ref callback (notify ~delay msg) (* $MDX part-end *) end @@ -74,7 +72,7 @@ let ping t msg = let open Echo.Ping in let request, params = Capability.Request.create Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get (* $MDX part-begin=client-heartbeat *) let heartbeat t msg callback = diff --git a/examples/v2/main.ml b/examples/v2/main.ml index ee9fb597f..8fee79e13 100644 --- a/examples/v2/main.ml +++ b/examples/v2/main.ml @@ -1,18 +1,21 @@ -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std + +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg let run_client service = Capability.with_ref (Echo.Callback.local callback_fn) @@ fun callback -> Echo.heartbeat service "foo" callback let () = - Lwt_main.run begin - let service = Echo.local in - run_client service - end + Eio_main.run @@ fun env -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + let service = Echo.local ~delay in + run_client service diff --git a/examples/v3/dune b/examples/v3/dune index fc80455c8..c3b83a62c 100644 --- a/examples/v3/dune +++ b/examples/v3/dune @@ -1,7 +1,6 @@ (executable (name main) - (libraries lwt.unix capnp-rpc-unix logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc-unix mirage-crypto-rng-eio logs.fmt)) (rule (targets echo_api.ml echo_api.mli) diff --git a/examples/v3/echo.ml b/examples/v3/echo.ml index 933e76f35..1784dffa8 100644 --- a/examples/v3/echo.ml +++ b/examples/v3/echo.ml @@ -1,7 +1,6 @@ -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std module Callback = struct let local fn = @@ -27,21 +26,21 @@ module Callback = struct end (* $MDX part-begin=notify *) -let (>>!=) = Lwt_result.bind (* Return errors *) - -let notify callback ~msg = +let notify ~delay msg callback = let rec loop = function | 0 -> - Lwt.return @@ Ok (Service.Response.create_empty ()) + Service.return_empty () | i -> - Callback.log callback msg >>!= fun () -> - Lwt_unix.sleep 1.0 >>= fun () -> - loop (i - 1) + match Callback.log callback msg with + | Error (`Capnp e) -> Service.error e + | Ok () -> + Eio.Time.Timeout.sleep delay; + loop (i - 1) in loop 3 (* $MDX part-end *) -let local = +let local ~delay = let module Echo = Api.Service.Echo in Echo.local @@ object inherit Echo.service @@ -63,8 +62,7 @@ let local = match callback with | None -> Service.fail "No callback parameter!" | Some callback -> - Service.return_lwt @@ fun () -> - Capability.with_ref callback (notify ~msg) + Capability.with_ref callback (notify ~delay msg) (* $MDX part-end *) end @@ -74,7 +72,7 @@ let ping t msg = let open Echo.Ping in let request, params = Capability.Request.create Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get (* $MDX part-begin=client-heartbeat *) let heartbeat t msg callback = diff --git a/examples/v3/main.ml b/examples/v3/main.ml index d039ae5b4..58e0e245d 100644 --- a/examples/v3/main.ml +++ b/examples/v3/main.ml @@ -1,12 +1,14 @@ -open Lwt.Infix -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std + +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg let run_client service = Capability.with_ref (Echo.Callback.local callback_fn) @@ fun callback -> @@ -15,18 +17,20 @@ let run_client service = let secret_key = `Ephemeral let listen_address = `TCP ("127.0.0.1", 7000) -let start_server () = +let start_server ~sw ~delay net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key listen_address in let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in - let restore = Capnp_rpc_net.Restorer.single service_id Echo.local in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> + let restore = Capnp_rpc_net.Restorer.single service_id (Echo.local ~delay) in + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in Capnp_rpc_unix.Vat.sturdy_uri vat service_id let () = - Lwt_main.run begin - start_server () >>= fun uri -> - Fmt.pr "Connecting to echo service at: %a@." Uri.pp_hum uri; - let client_vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in - Sturdy_ref.with_cap_exn sr run_client - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + let uri = start_server ~sw ~delay env#net in + traceln "Connecting to echo service at: %a" Uri.pp_hum uri; + let client_vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in + Sturdy_ref.with_cap_exn sr run_client diff --git a/examples/v4/client.ml b/examples/v4/client.ml index 95e556e4e..a35f62fc3 100644 --- a/examples/v4/client.ml +++ b/examples/v4/client.ml @@ -1,22 +1,24 @@ -open Capnp_rpc_lwt +open Eio.Std +open Capnp_rpc.Std let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) let callback_fn msg = - Fmt.pr "Callback got %S@." msg + traceln "Callback got %S" msg let run_client service = Capability.with_ref (Echo.Callback.local callback_fn) @@ fun callback -> Echo.heartbeat service "foo" callback let connect uri = - Lwt_main.run begin - let client_vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in - Capnp_rpc_unix.with_cap_exn sr run_client - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let client_vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in + Capnp_rpc_unix.with_cap_exn sr run_client open Cmdliner diff --git a/examples/v4/dune b/examples/v4/dune index 26674af9a..64753b864 100644 --- a/examples/v4/dune +++ b/examples/v4/dune @@ -1,7 +1,6 @@ (executables (names client server) - (libraries lwt.unix capnp-rpc-lwt logs.fmt capnp-rpc-unix) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc logs.fmt capnp-rpc-unix mirage-crypto-rng-eio)) (rule (targets echo_api.ml echo_api.mli) diff --git a/examples/v4/echo.ml b/examples/v4/echo.ml index bfedc5664..d624e96d0 100644 --- a/examples/v4/echo.ml +++ b/examples/v4/echo.ml @@ -1,7 +1,6 @@ -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std module Callback = struct let local fn = @@ -26,20 +25,20 @@ module Callback = struct Capability.call_for_unit t method_id request end -let (>>!=) = Lwt_result.bind (* Return errors *) - -let notify callback ~msg = +let notify ~delay msg callback = let rec loop = function | 0 -> - Lwt.return @@ Ok (Service.Response.create_empty ()) + Service.return_empty () | i -> - Callback.log callback msg >>!= fun () -> - Lwt_unix.sleep 1.0 >>= fun () -> - loop (i - 1) + match Callback.log callback msg with + | Error (`Capnp e) -> Service.error e + | Ok () -> + Eio.Time.Timeout.sleep delay; + loop (i - 1) in loop 3 -let local = +let local ~delay = let module Echo = Api.Service.Echo in Echo.local @@ object inherit Echo.service @@ -60,8 +59,7 @@ let local = match callback with | None -> Service.fail "No callback parameter!" | Some callback -> - Service.return_lwt @@ fun () -> - Capability.with_ref callback (notify ~msg) + Capability.with_ref callback (notify ~delay msg) end module Echo = Api.Client.Echo @@ -70,7 +68,7 @@ let ping t msg = let open Echo.Ping in let request, params = Capability.Request.create Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get let heartbeat t msg callback = let open Echo.Heartbeat in diff --git a/examples/v4/server.ml b/examples/v4/server.ml index 6439c6e11..32e8071da 100644 --- a/examples/v4/server.ml +++ b/examples/v4/server.ml @@ -1,6 +1,8 @@ -open Lwt.Infix +open Eio.Std open Capnp_rpc_net +let delay = if Sys.getenv_opt "CI" = None then 1.0 else 0.0 + let () = Logs.set_level (Some Logs.Warning); Logs.set_reporter (Logs_fmt.reporter ()) @@ -8,16 +10,18 @@ let () = let cap_file = "echo.cap" let serve config = - Lwt_main.run begin - let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in - let restore = Restorer.single service_id Echo.local in - Capnp_rpc_unix.serve config ~restore >>= fun vat -> - match Capnp_rpc_unix.Cap_file.save_service vat service_id cap_file with - | Error `Msg m -> failwith m - | Ok () -> - Fmt.pr "Server running. Connect using %S.@." cap_file; - fst @@ Lwt.wait () (* Wait forever *) - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + let delay = Eio.Time.Timeout.seconds env#mono_clock delay in + Switch.run @@ fun sw -> + let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in + let restore = Restorer.single service_id (Echo.local ~delay) in + let vat = Capnp_rpc_unix.serve ~sw ~net:env#net ~restore config in + match Capnp_rpc_unix.Cap_file.save_service vat service_id cap_file with + | Error `Msg m -> failwith m + | Ok () -> + traceln "Server running. Connect using %S." cap_file; + Fiber.await_cancel () open Cmdliner diff --git a/fuzz/direct.ml b/fuzz/direct.ml index a4aa571a8..5a3d02f56 100644 --- a/fuzz/direct.ml +++ b/fuzz/direct.ml @@ -1,4 +1,4 @@ -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array let next = ref 0 diff --git a/fuzz/direct.mli b/fuzz/direct.mli index cb17ba65d..bcde3a8a0 100644 --- a/fuzz/direct.mli +++ b/fuzz/direct.mli @@ -1,4 +1,4 @@ -open Capnp_rpc +open Capnp_rpc_proto (* For each capability and struct_ref in the real system, we make a corresponding "direct" object. While a real capability must be converted to an export diff --git a/fuzz/dune b/fuzz/dune index 8be3026c1..f5c625ce9 100644 --- a/fuzz/dune +++ b/fuzz/dune @@ -1,3 +1,3 @@ (executables (names fuzz) - (libraries capnp-rpc alcotest logs.fmt testbed afl-persistent)) + (libraries capnp-rpc.proto alcotest logs.fmt testbed afl-persistent)) diff --git a/fuzz/fuzz.ml b/fuzz/fuzz.ml index 0b4fe272b..0158ca907 100644 --- a/fuzz/fuzz.ml +++ b/fuzz/fuzz.ml @@ -1,7 +1,6 @@ -open Asetmap -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array module Test_utils = Testbed.Test_utils -module OID = Capnp_rpc.Debug.OID +module OID = Capnp_rpc_proto.Debug.OID module IntSet = Set.Make(struct type t = int let compare = compare end) let running_under_afl = @@ -9,7 +8,7 @@ let running_under_afl = | [] -> assert false | [_] -> false | [_; "--fuzz"] -> true - | prog :: _ -> Capnp_rpc.Debug.failf "Usage: %s < input-data" prog + | prog :: _ -> Fmt.failwith "Usage: %s < input-data" prog let test_script_path = "test_script.ml" @@ -75,7 +74,7 @@ let pp_counters f {next_to_send; next_expected; _} = Fmt.pf f "{send=%d; expect= module Msg = struct type 'a msg = { contents : 'a; - attachments : Capnp_rpc.S.attachments; + attachments : Capnp_rpc_proto.S.attachments; } let pp_msg pp_contents f {contents; attachments = _} = pp_contents f contents @@ -125,7 +124,7 @@ module Msg = struct counters.cancelled <- IntSet.add seq counters.cancelled; ) ); - { contents; attachments = Capnp_rpc.S.No_attachments } + { contents; attachments = Capnp_rpc_proto.S.No_attachments } end module Response = struct @@ -133,17 +132,17 @@ module Msg = struct type t = contents msg let pp = pp_msg Fmt.string let cap_index _ i = Some i - let bootstrap () = {contents = "(boot)"; attachments = Capnp_rpc.S.No_attachments} + let bootstrap () = {contents = "(boot)"; attachments = Capnp_rpc_proto.S.No_attachments} let with_attachments attachments x = {x with attachments} let attachments x = x.attachments let v contents = - { contents; attachments = Capnp_rpc.S.No_attachments } + { contents; attachments = Capnp_rpc_proto.S.No_attachments } end type request = Request.contents type response = Response.contents - let ref_leak_detected fn = + let ref_leak_detected _ fn = fn (); failwith "ref_leak_detected" @@ -152,7 +151,7 @@ module Msg = struct | `Bootstrap _ -> "bootstrap" | `Call (_, _, msg, _, _) -> Fmt.str "call:%a:%d" OID.pp msg.contents.Request.sender msg.contents.Request.seq | `Return (_, `Results (msg, _), _) -> "return:" ^ msg.contents - | `Return (_, `Exception ex, _) -> "return:" ^ ex.Capnp_rpc.Exception.reason + | `Return (_, `Exception ex, _) -> "return:" ^ ex.Capnp_rpc_proto.Exception.reason | `Return (_, `Cancelled, _) -> "return:(cancelled)" | `Return (_, `AcceptFromThirdParty, _) -> "return:accept" | `Return (_, `ResultsSentElsewhere, _) -> "return:sent-elsewhere" @@ -166,7 +165,7 @@ module Msg = struct end -module Core_types = Capnp_rpc.Core_types(Msg) +module Core_types = Capnp_rpc_proto.Core_types(Msg) module Network_types = struct type provision_id @@ -175,18 +174,18 @@ module Network_types = struct type join_key_part end -module Local_struct_promise = Capnp_rpc.Local_struct_promise.Make(Core_types) +module Local_struct_promise = Capnp_rpc_proto.Local_struct_promise.Make(Core_types) module Table_types = struct - module QuestionId = Capnp_rpc.Id.Make ( ) + module QuestionId = Capnp_rpc_proto.Id.Make ( ) module AnswerId = QuestionId - module ImportId = Capnp_rpc.Id.Make ( ) + module ImportId = Capnp_rpc_proto.Id.Make ( ) module ExportId = ImportId end -module EP = Capnp_rpc.Message_types.Endpoint(Core_types)(Network_types)(Table_types) +module EP = Capnp_rpc_proto.Message_types.Endpoint(Core_types)(Network_types)(Table_types) module Endpoint = struct - module Conn = Capnp_rpc.CapTP.Make(EP) + module Conn = Capnp_rpc_proto.CapTP.Make(EP) type t = { local_id : int; @@ -214,9 +213,11 @@ module Endpoint = struct let check t = Conn.check t.conn + let fork f = f () + let create ~restore ~tags ~dump ~local_id ~remote_id xmit_queue recv_queue = let queue_send x = Queue.add x xmit_queue in - let conn = Conn.create ~restore ~tags ~queue_send in + let conn = Conn.create ~restore ~tags ~queue_send ~fork in { local_id; remote_id; @@ -256,7 +257,7 @@ module Endpoint = struct ) else false let disconnect t = - Conn.disconnect t.conn (Capnp_rpc.Exception.v "Tests finished") + Conn.disconnect t.conn (Capnp_rpc_proto.Exception.v "Tests finished") end let () = @@ -297,7 +298,7 @@ let pp_error f base = with ex -> Fmt.pf f "@,[%a] %a" Fmt.(styled `Red string) "ERROR" - Capnp_rpc.Debug.pp_exn ex + Capnp_rpc_proto.Debug.pp_exn ex module Struct_info = struct type t = { @@ -375,7 +376,7 @@ module Vat = struct t.caps |> WrapArray.iter (fun c -> c.cr_cap#check_invariants); t.structs |> WrapArray.iter Struct_info.check_invariants with ex -> - Logs.err (fun f -> f ~tags:(tags t) "Invariants check failed: %a" Capnp_rpc.Debug.pp_exn ex); + Logs.err (fun f -> f ~tags:(tags t) "Invariants check failed: %a" Capnp_rpc_proto.Debug.pp_exn ex); raise ex let do_action state = @@ -471,11 +472,11 @@ module Vat = struct Direct.return answer_id RO_array.empty; let msg = "(simulated-failure)" in code (fun f -> - Fmt.pf f "resolve_exn %a (Capnp_rpc.Exception.v %S);" + Fmt.pf f "resolve_exn %a (Capnp_rpc_proto.Exception.v %S);" pp_resolver answer_var msg ); - Core_types.resolve_exn answer (Capnp_rpc.Exception.v msg) + Core_types.resolve_exn answer (Capnp_rpc_proto.Exception.v msg) | `Return_results (args, arg_refs) -> let arg_ids = List.map (fun cr -> cr.cr_target) arg_refs in RO_array.iter Core_types.inc_ref args; @@ -496,10 +497,10 @@ module Vat = struct object (self : test_service) inherit Core_types.service as super - val id = Capnp_rpc.Debug.OID.next () + val id = Capnp_rpc_proto.Debug.OID.next () method! pp f = Fmt.pf f "test-service(%a, %t) %a" - Capnp_rpc.Debug.OID.pp id + Capnp_rpc_proto.Debug.OID.pp id super#pp_refcount Direct.pp self_id @@ -617,7 +618,7 @@ module Vat = struct let restore t k object_id = match object_id, t.bootstrap with | "", Some (cap, _) -> Core_types.inc_ref cap; k @@ Ok (cap :> Core_types.cap) - | _ -> k @@ Error (Capnp_rpc.Exception.v "Bad object_id for restore") + | _ -> k @@ Error (Capnp_rpc_proto.Exception.v "Bad object_id for restore") let free_all t = WrapArray.free t.caps; @@ -642,9 +643,9 @@ module Vat = struct in let free_answer (ans, _, answer_var) = code (fun f -> - Fmt.pf f "Core_types.resolve_exn %a (Capnp_rpc.Exception.v \"Operation rejected\");" pp_resolver answer_var + Fmt.pf f "Core_types.resolve_exn %a (Capnp_rpc_proto.Exception.v \"Operation rejected\");" pp_resolver answer_var ); - Core_types.resolve_exn ans @@ Capnp_rpc.Exception.v "Operation rejected" + Core_types.resolve_exn ans @@ Capnp_rpc_proto.Exception.v "Operation rejected" in let t = { id; diff --git a/test-bin/calc.ml b/test-bin/calc.ml index 881ad436e..3db0f87ae 100644 --- a/test-bin/calc.ml +++ b/test-bin/calc.ml @@ -1,4 +1,4 @@ -open Lwt.Infix +open Eio.Std module Vat = Capnp_rpc_unix.Vat module Calc = Testlib.Calc @@ -30,29 +30,31 @@ let reporter = (* Run as server *) let serve vat_config = - Lwt_main.run begin - let service_id = Capnp_rpc_net.Restorer.Id.public "" in - let restore = Capnp_rpc_net.Restorer.single service_id Calc.local in - Capnp_rpc_unix.serve vat_config ~restore >>= fun vat -> - let sr = Vat.sturdy_uri vat service_id in - Fmt.pr "Waiting for incoming connections at:@.%a@." Uri.pp_hum sr; - fst @@ Lwt.wait () - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let service_id = Capnp_rpc_net.Restorer.Id.public "" in + let service = Calc.local ~sw in + let restore = Capnp_rpc_net.Restorer.single service_id service in + let vat = Capnp_rpc_unix.serve ~sw ~net:env#net ~restore vat_config in + let sr = Vat.sturdy_uri vat service_id in + traceln "Waiting for incoming connections at:@.%a" Uri.pp_hum sr; + Fiber.await_cancel () (* Run as client *) let connect addr = - Lwt_main.run begin - let vat = Capnp_rpc_unix.client_only_vat () in - let sr = Vat.import_exn vat addr in - Capnp_rpc_unix.with_cap_exn sr @@ fun calc -> - Logs.info (fun f -> f "Evaluating expression..."); - let remote_add = Calc.getOperator calc `Add in - let result = Calc.evaluate calc Calc.Expr.(Call (remote_add, [Float 40.0; Float 2.0])) in - Calc.Value.read result >>= fun v -> - Fmt.pr "Result: %f@." v; - Lwt.return_unit - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run @@ fun sw -> + let vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Vat.import_exn vat addr in + Capnp_rpc_unix.with_cap_exn sr @@ fun calc -> + Logs.info (fun f -> f "Evaluating expression..."); + let remote_add = Calc.getOperator calc `Add in + let result = Calc.evaluate calc Calc.Expr.(Call (remote_add, [Float 40.0; Float 2.0])) in + let v = Calc.Value.read result in + traceln "Result: %f" v (* Command-line parsing *) @@ -79,7 +81,7 @@ let () = Logs.set_reporter reporter; Logs.set_level ~all:true (Some Logs.Info); Logs.Src.list () |> List.iter (fun src -> - if Astring.String.is_prefix ~affix:"capnp" (Logs.Src.name src) then + if String.starts_with ~prefix:"capnp" (Logs.Src.name src) then Logs.Src.set_level src (Some Logs.Debug); ); let doc = "a calculator example" in diff --git a/test-bin/calc_direct.ml b/test-bin/calc_direct.ml index 1f75b66bc..07df5dd81 100644 --- a/test-bin/calc_direct.ml +++ b/test-bin/calc_direct.ml @@ -1,7 +1,7 @@ (* Run the calc service as a child process, connecting directly over a socketpair. Unlike a normal connection, there is no encryption or use of sturdy refs here. *) -open Lwt.Infix +open Eio.Std module Calc = Testlib.Calc @@ -29,78 +29,63 @@ module Logging = struct Logs.set_reporter (reporter id) end +let run_connection conn = + Fiber.both + (* Normally the vat runs a leak handler to free resources that get GC'd + with a non-zero reference count. We're not using a vat, so run it ourselves. *) + Capnp_rpc.Leak_handler.run + (fun () -> Capnp_rpc_unix.CapTP.run conn) + module Parent = struct let run socket = Logging.init "parent"; + Switch.run @@ fun sw -> (* Run Cap'n Proto RPC protocol on [socket]: *) - Lwt_switch.with_switch @@ fun switch -> - let p = Lwt_unix.of_unix_file_descr socket - |> Capnp_rpc_unix.Unix_flow.connect ~switch - |> Capnp_rpc_net.Endpoint.of_flow (module Capnp_rpc_unix.Unix_flow) - ~peer_id:Capnp_rpc_net.Auth.Digest.insecure - ~switch in + let p = Capnp_rpc_net.Endpoint.of_flow socket ~peer_id:Capnp_rpc_net.Auth.Digest.insecure in Logs.info (fun f -> f "Connecting to child process..."); - let conn = Capnp_rpc_unix.CapTP.connect ~restore:Capnp_rpc_net.Restorer.none p in + let conn = Capnp_rpc_unix.CapTP.connect ~sw ~restore:Capnp_rpc_net.Restorer.none p in + Fiber.fork_daemon ~sw (fun () -> run_connection conn; `Stop_daemon); (* Get the child's service object: *) let calc = Capnp_rpc_unix.CapTP.bootstrap conn service_name in (* Use the service: *) Logs.app (fun f -> f "Sending request..."); let remote_mul = Calc.getOperator calc `Multiply in let result = Calc.evaluate calc Calc.Expr.(Call (remote_mul, [Float 21.0; Float 2.0])) in - Calc.Value.read result >>= fun v -> + let v = Calc.Value.read result in Logs.app (fun f -> f "Result: %f" v); - Logs.app (fun f -> f "Shutting down..."); - Lwt.return_unit + Logs.app (fun f -> f "Shutting down...") end module Child = struct - let service = Calc.local - let run socket = Logging.init "child"; - Lwt_main.run begin - Lwt_switch.with_switch @@ fun switch -> - let restore = Capnp_rpc_net.Restorer.single service_name service in - (* Run Cap'n Proto RPC protocol on [socket]: *) - let endpoint = Capnp_rpc_unix.Unix_flow.connect (Lwt_unix.of_unix_file_descr socket) - |> Capnp_rpc_net.Endpoint.of_flow (module Capnp_rpc_unix.Unix_flow) - ~peer_id:Capnp_rpc_net.Auth.Digest.insecure - ~switch - in - let _ : Capnp_rpc_unix.CapTP.t = Capnp_rpc_unix.CapTP.connect ~restore endpoint in - Logs.info (fun f -> f "Serving requests..."); - fst (Lwt.wait ()) (* Wait forever *) - end + Switch.run @@ fun sw -> + let socket = Eio_unix.Net.import_socket_stream ~sw ~close_unix:false socket in + let service = Calc.local ~sw in + let restore = Capnp_rpc_net.Restorer.single service_name service in + (* Run Cap'n Proto RPC protocol on [socket]: *) + let endpoint = Capnp_rpc_net.Endpoint.of_flow socket ~peer_id:Capnp_rpc_net.Auth.Digest.insecure in + let conn = Capnp_rpc_unix.CapTP.connect ~sw ~restore endpoint in + Logs.info (fun f -> f "Serving requests..."); + run_connection conn end -let find_our_path prog = - if Sys.file_exists prog then prog - else ( - (* Hack for running under "dune exec" *) - let prog = "./_build/default/" ^ prog in - if Sys.file_exists prog then prog - else Fmt.failwith "Can't find path to own binary %S from %S" prog (Sys.getcwd ()) - ) - let () = - Lwt_main.run begin - match Sys.argv with - | [| prog |] -> - (* We are the parent. *) - let prog = find_our_path prog in - let p, c = Unix.(socketpair PF_UNIX SOCK_STREAM 0 ~cloexec:true) in - Unix.clear_close_on_exec c; - (* Run the child, passing the socket as its stdin. *) - let child = Lwt_process.open_process_none ~stdin:(`FD_move c) ("", [| prog; "--child" |]) in - Parent.run p >>= fun () -> - Logs.info (fun f -> f "Waiting for child to exit..."); - child#terminate; - child#status >>= fun _ -> - Logs.info (fun f -> f "Done"); - Lwt.return_unit - | [| _prog; "--child" |] -> - (* We are the child. Our socket is on stdin. *) - Child.run Unix.stdin - | _ -> - failwith "Run this command without arguments." - end + Eio_main.run @@ fun env -> + let prog_mgr = env#process_mgr in + match Sys.argv with + | [| prog |] -> + (* We are the parent. *) + Switch.run @@ fun sw -> + let prog = if Filename.is_implicit prog then "./" ^ prog else prog in + let p, c = Eio_unix.Net.socketpair_stream ~sw () in + (* Run the child, passing the socket as its stdin. *) + let _child = Eio.Process.spawn ~sw prog_mgr [prog; "--child"] ~stdin:c in + Eio.Net.close c; + Parent.run p; + Logs.info (fun f -> f "Done") + | [| _prog; "--child" |] -> + (* We are the child. Our socket is on stdin. *) + Child.run Unix.stdin + | _ -> + failwith "Run this command without arguments." diff --git a/test-bin/dune b/test-bin/dune index 9c46081cf..f51935d10 100644 --- a/test-bin/dune +++ b/test-bin/dune @@ -1,3 +1,4 @@ (executables (names calc calc_direct) - (libraries testlib cmdliner astring logs.fmt fmt.tty capnp-rpc-unix)) + (libraries testlib cmdliner astring logs.fmt fmt.tty capnp-rpc-unix eio_main + mirage-crypto-rng-eio)) diff --git a/test-bin/echo/dune b/test-bin/echo/dune index 19562b5df..3cc3789b3 100644 --- a/test-bin/echo/dune +++ b/test-bin/echo/dune @@ -1,7 +1,6 @@ (executable (name echo_bench) - (libraries lwt.unix capnp-rpc capnp-rpc-lwt capnp-rpc-net capnp-rpc-unix logs.fmt) - (flags (:standard -w -53-55))) + (libraries eio_main capnp-rpc capnp-rpc-net capnp-rpc-unix mirage-crypto-rng-eio logs.fmt)) (rule (targets echo_api.ml echo_api.mli) diff --git a/test-bin/echo/echo.ml b/test-bin/echo/echo.ml index 4b207c644..f521a644b 100755 --- a/test-bin/echo/echo.ml +++ b/test-bin/echo/echo.ml @@ -1,7 +1,6 @@ -module Api = Echo_api.MakeRPC(Capnp_rpc_lwt) +module Api = Echo_api.MakeRPC(Capnp_rpc) -open Lwt.Infix -open Capnp_rpc_lwt +open Capnp_rpc.Std (*-- Server ----------------------------------------*) let local = @@ -29,4 +28,4 @@ let ping t msg = let message_size = 200 + String.length msg in (* (rough estimate) *) let request, params = Capability.Request.create ~message_size Params.init_pointer in Params.msg_set params msg; - Capability.call_for_value_exn t method_id request >|= Results.reply_get + Capability.call_for_value_exn t method_id request |> Results.reply_get diff --git a/test-bin/echo/echo_bench.ml b/test-bin/echo/echo_bench.ml index 5c6a13b65..0ee7daeaa 100755 --- a/test-bin/echo/echo_bench.ml +++ b/test-bin/echo/echo_bench.ml @@ -1,7 +1,6 @@ +open Eio.Std -open Lwt.Infix - -open Capnp_rpc_lwt +open Capnp_rpc.Std let () = Logs.set_level (Some Logs.Info); @@ -12,32 +11,33 @@ let run_client service = let ops = List.init n (fun i -> let payload = Int.to_string i in let desired_result = "echo:" ^ payload in - fun () -> - Echo.ping service payload >|= fun res -> + fun () -> + let res = Echo.ping service payload in assert (res = desired_result) ) in let st = Unix.gettimeofday () in - Lwt_stream.of_list ops |> Lwt_stream.iter_n ~max_concurrency:12 (fun v -> v ()) >>= fun () -> + ops |> Fiber.List.iter ~max_fibers:12 (fun v -> v ()); let ed = Unix.gettimeofday () in let rate = (Int.to_float n) /. (ed -. st) in - Logs.info (fun m -> m "rate = %f" rate ); - Lwt.return_unit + Logs.info (fun m -> m "rate = %f" rate) let secret_key = `Ephemeral let listen_address = `TCP ("127.0.0.1", 7000) -let start_server () = +let start_server ~sw net = let config = Capnp_rpc_unix.Vat_config.create ~secret_key ~serve_tls:false listen_address in let service_id = Capnp_rpc_unix.Vat_config.derived_id config "main" in let restore = Capnp_rpc_net.Restorer.single service_id Echo.local in - Capnp_rpc_unix.serve config ~restore >|= fun vat -> + let vat = Capnp_rpc_unix.serve ~sw ~net ~restore config in Capnp_rpc_unix.Vat.sturdy_uri vat service_id let () = - Lwt_main.run begin - start_server () >>= fun uri -> - Fmt.pr "Connecting to echo service at: %a@." Uri.pp_hum uri; - let client_vat = Capnp_rpc_unix.client_only_vat () in - let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in - Sturdy_ref.with_cap_exn sr run_client - end + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + Switch.run ~name:"main" @@ fun sw -> + let uri = start_server ~sw env#net in + Fmt.pr "Connecting to echo service at: %a@." Uri.pp_hum uri; + Switch.run ~name:"client" @@ fun sw -> + let client_vat = Capnp_rpc_unix.client_only_vat ~sw env#net in + let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in + Sturdy_ref.with_cap_exn sr run_client diff --git a/test-lwt/dune b/test-lwt/dune deleted file mode 100644 index 30ea84cd2..000000000 --- a/test-lwt/dune +++ /dev/null @@ -1,5 +0,0 @@ -(test - (package capnp-rpc-unix) - (name test_lwt) - (libraries capnp-rpc-lwt capnp-rpc-unix alcotest-lwt testlib logs.fmt - testbed)) diff --git a/test-lwt/test_lwt.ml b/test-lwt/test_lwt.ml deleted file mode 100644 index 4b30ba299..000000000 --- a/test-lwt/test_lwt.ml +++ /dev/null @@ -1,744 +0,0 @@ -open Astring -open Testlib -open Lwt.Infix -open Capnp_rpc_lwt -open Capnp_rpc_net - -module Test_utils = Testbed.Test_utils - -module Vat = Capnp_rpc_unix.Vat -module CapTP = Capnp_rpc_unix.CapTP -module Unix_flow = Capnp_rpc_unix.Unix_flow -module Tls_wrapper = Capnp_rpc_net.Tls_wrapper.Make(Unix_flow) -module Exception = Capnp_rpc.Exception - -type cs = { - client : Vat.t; - server : Vat.t; - client_key : Auth.Secret_key.t; - server_key : Auth.Secret_key.t; - serve_tls : bool; - server_switch : Lwt_switch.t; -} - -let ensure_removed path = - try Unix.unlink path - with Unix.Unix_error(Unix.ENOENT, _, _) -> () - -let next_port = ref 8000 - -let get_test_address ~switch name = - match Sys.os_type with - | "Win32" -> - (* No Unix-domain sockets on Windows *) - let port = !next_port in - incr next_port; - `TCP ("127.0.0.1", port) - | _ -> - let socket_path = Filename.(concat (Filename.get_temp_dir_name ())) name in - Lwt_switch.add_hook (Some switch) (fun () -> Lwt.return @@ ensure_removed socket_path); - `Unix socket_path - -(* Have the client ask the server for its bootstrap object, and return the - resulting client-side proxy to it. *) -let get_bootstrap cs = - let id = Restorer.Id.public "" in - let sr = Vat.sturdy_uri cs.server id |> Vat.import_exn cs.client in - Sturdy_ref.connect_exn sr - -module Utils = struct - [@@@ocaml.warning "-32"] - - let dump cs = - Logs.info (fun f -> f ~tags:Test_utils.client_tags "%a" Vat.dump cs.client); - Logs.info (fun f -> f ~tags:Test_utils.server_tags "%a" Vat.dump cs.server) -end - -let cap_equal_exn a b = - match Capability.equal a b with - | Ok x -> x - | Error `Unsettled -> Alcotest.failf "Can't compare %a and %a: not settled!" - Capability.pp a - Capability.pp b - -let cap = Alcotest.testable Capability.pp cap_equal_exn - -let () = Logs.(set_level (Some Logs.Warning)) -let server_key = Auth.Secret_key.generate () -let client_key = Auth.Secret_key.generate () -let bad_key = Auth.Secret_key.generate () -let () = Logs.(set_level (Some Logs.Info)) - -let server_pem = `PEM (Auth.Secret_key.to_pem_data server_key) - -let make_vats_full ?(serve_tls=false) ~client_switch ~server_switch ~restore () = - let server_config = - let addr = get_test_address ~switch:server_switch "capnp-rpc-test-server" in - Capnp_rpc_unix.Vat_config.create ~secret_key:server_pem ~serve_tls addr - in - Capnp_rpc_unix.serve ~switch:server_switch ~tags:Test_utils.server_tags ~restore server_config >>= fun server -> - Lwt.return { - client = Vat.create ~switch:client_switch ~tags:Test_utils.client_tags ~secret_key:(lazy client_key) (); - server; - client_key; - server_key; - serve_tls; - server_switch; - } - -let make_vats ?serve_tls ~switch ~service () = - let server_switch = Lwt_switch.create () in - Lwt_switch.add_hook (Some switch) (fun () -> Lwt_switch.turn_off server_switch); - let id = Restorer.Id.public "" in - let restore = Restorer.single id service in - Lwt_switch.add_hook (Some switch) (fun () -> Capability.dec_ref service; Lwt.return_unit); - make_vats_full ?serve_tls ~client_switch:switch ~server_switch ~restore () - -(* Generic Lwt running for Alcotest. *) -let run_lwt name ?(expected_warnings=0) fn = - Alcotest_lwt.test_case name `Quick @@ fun sw () -> - let warnings_at_start = Logs.(err_count () + warn_count ()) in - Logs.info (fun f -> f "Start test-case"); - let finished = ref false in - Lwt_switch.add_hook (Some sw) (fun () -> - if not !finished then !Lwt.async_exception_hook (Failure "Switch turned off early"); - Lwt.return_unit - ); - fn sw >>= fun () -> finished := true; - Lwt_switch.turn_off sw >|= fun () -> - Gc.full_major (); - Lwt.wakeup_paused (); - Gc.full_major (); - Lwt.wakeup_paused (); - Gc.full_major (); - let warnings_at_end = Logs.(err_count () + warn_count ()) in - Alcotest.(check int) "Check log for warnings" expected_warnings (warnings_at_end - warnings_at_start) - -let test_simple switch ~serve_tls = - make_vats ~switch ~serve_tls ~service:(Echo.local ()) () >>= fun cs -> - get_bootstrap cs >>= fun service -> - Echo.ping service "ping" >>= fun reply -> - Alcotest.(check string) "Ping response" "got:0:ping" reply; - Capability.dec_ref service; - Lwt.return () - -let test_bad_crypto switch = - make_vats ~switch ~serve_tls:true ~service:(Echo.local ()) () >>= fun cs -> - let id = Restorer.Id.public "" in - let uri = Vat.sturdy_uri cs.server id in - let bad_digest = Auth.Secret_key.digest ~hash:`SHA256 bad_key in - let uri = Auth.Digest.add_to_uri bad_digest uri in - let sr = Capnp_rpc_unix.Vat.import_exn cs.client uri in - let old_warnings = Logs.warn_count () in - Sturdy_ref.connect sr >>= function - | Ok _ -> Alcotest.fail "Wrong TLS key should have been rejected" - | Error e -> - let msg = Fmt.to_to_string Capnp_rpc.Exception.pp e in - assert (String.is_prefix ~affix:"Failed: TLS connection failed: authentication failure" msg); - (* Wait for server to log warning *) - let rec wait () = - if Logs.warn_count () = old_warnings then Lwt.pause () >>= wait - else Lwt.return_unit - in - wait () - -let test_parallel switch = - make_vats ~switch ~service:(Echo.local ()) () >>= fun cs -> - get_bootstrap cs >>= fun service -> - let reply1 = Echo.ping service ~slow:true "ping1" in - Echo.ping service "ping2" >|= Alcotest.(check string) "Ping2 response" "got:1:ping2" >>= fun () -> - assert (Lwt.state reply1 = Lwt.Sleep); - Echo.unblock service >>= fun () -> - reply1 >|= Alcotest.(check string) "Ping1 response" "got:0:ping1" >>= fun () -> - Capability.dec_ref service; - Lwt.return () - -let test_registry switch = - let registry_impl = Registry.local () in - make_vats ~switch ~service:registry_impl () >>= fun cs -> - get_bootstrap cs >>= fun registry -> - Capability.with_ref (Registry.echo_service registry) @@ fun echo_service -> - Registry.unblock registry >>= fun () -> - Echo.ping echo_service "ping" >|= Alcotest.(check string) "Ping response" "got:0:ping" >>= fun () -> - Capability.dec_ref registry; - Lwt.return () - -let test_embargo switch = - let registry_impl = Registry.local () in - let local_echo = Echo.local () in - make_vats ~switch ~service:registry_impl () >>= fun cs -> - get_bootstrap cs >>= fun registry -> - Registry.set_echo_service registry local_echo >>= fun () -> - Capability.dec_ref local_echo; - let echo_service = Registry.echo_service registry in - let reply1 = Echo.ping echo_service "ping" in - Registry.unblock registry >>= fun () -> - reply1 >|= Alcotest.(check string) "Ping response" "got:0:ping" >>= fun () -> - (* Flush, to ensure we resolve the echo_service's location. *) - Echo.ping echo_service "ping" >|= Alcotest.(check string) "Ping response" "got:1:ping" >>= fun () -> - (* Test local connection. *) - Echo.ping echo_service "ping" >|= Alcotest.(check string) "Ping response" "got:2:ping" >>= fun () -> - Capability.dec_ref echo_service; - Capability.dec_ref registry; - Lwt.return () - -let test_resolve switch = - let registry_impl = Registry.local () in - let local_echo = Echo.local () in - make_vats ~switch ~service:registry_impl () >>= fun cs -> - get_bootstrap cs >>= fun registry -> - Registry.set_echo_service registry local_echo >>= fun () -> - Capability.dec_ref local_echo; - let echo_service = Registry.echo_service_promise registry in - let reply1 = Echo.ping echo_service "ping" in - Registry.unblock registry >>= fun () -> - reply1 >|= Alcotest.(check string) "Ping response" "got:0:ping" >>= fun () -> - (* Flush, to ensure we resolve the echo_service's location. *) - Echo.ping echo_service "ping" >|= Alcotest.(check string) "Ping response" "got:1:ping" >>= fun () -> - (* Test local connection. *) - Echo.ping echo_service "ping" >|= Alcotest.(check string) "Ping response" "got:2:ping" >>= fun () -> - Capability.dec_ref echo_service; - Capability.dec_ref registry; - Lwt.return () - -let test_cancel switch = - make_vats ~switch ~service:(Echo.local ()) () >>= fun cs -> - get_bootstrap cs >>= fun service -> - let reply1 = Echo.ping service ~slow:true "ping1" in - assert (Lwt.state reply1 = Lwt.Sleep); - Lwt.cancel reply1; - Lwt.try_bind - (fun () -> reply1) - (fun _ -> Alcotest.fail "Should have been cancelled!") - (function - | Lwt.Canceled -> Lwt.return () - | ex -> Lwt.fail ex - ) - >>= fun () -> - Echo.unblock service >|= fun () -> - Capability.dec_ref service - -let float = Alcotest.testable Fmt.float (=) - -let test_calculator switch = - let open Calc in - Capability.inc_ref Calc.local; - make_vats ~switch ~service:Calc.local () >>= fun cs -> - get_bootstrap cs >>= fun c -> - Calc.evaluate c (Float 1.) |> Value.final_read >|= Alcotest.check float "Simple calc" 1. >>= fun () -> - let local_add = Calc.Fn.add in - let expr = Expr.(Call (local_add, [Float 1.; Float 2.])) in - Calc.evaluate c expr |> Value.final_read >|= Alcotest.check float "Complex with local fn" 3. >>= fun () -> - let remote_add = Calc.getOperator c `Add in - Calc.Fn.call remote_add [5.; 3.] >|= Alcotest.check float "Check fn" 8. >>= fun () -> - let expr = Expr.(Call (remote_add, [Float 1.; Float 2.])) in - Calc.evaluate c expr |> Value.final_read >|= Alcotest.check float "Complex with remote fn" 3. >>= fun () -> - Capability.dec_ref remote_add; - Capability.dec_ref c; - Lwt.return () - -let test_calculator2 switch = - let open Calc in - Capability.inc_ref Calc.local; - make_vats ~switch ~service:Calc.local () >>= fun cs -> - get_bootstrap cs >>= fun c -> - let remote_add = Calc.getOperator c `Add in - let remote_mul = Calc.getOperator c `Multiply in - let expr = Expr.(Call (remote_mul, [Float 4.; Float 6.])) in - let result = Calc.evaluate c expr in - let expr = Expr.(Call (remote_add, [Prev result; Float 3.])) in - let add3 = Calc.evaluate c expr |> Value.final_read in - let expr = Expr.(Call (remote_add, [Prev result; Float 5.])) in - let add5 = Calc.evaluate c expr |> Value.final_read in - add3 >>= fun add3 -> - add5 >>= fun add5 -> - Alcotest.check float "First" 27.0 add3; - Alcotest.check float "Second" 29.0 add5; - Capability.dec_ref result; - Capability.dec_ref remote_add; - Capability.dec_ref remote_mul; - Capability.dec_ref c; - Lwt.return () - -let test_indexing switch = - let registry_impl = Registry.local () in - make_vats ~switch ~service:registry_impl () >>= fun cs -> - get_bootstrap cs >>= fun registry -> - let echo_service, version = Registry.complex registry in - Echo.ping echo_service "ping" >|= Alcotest.(check string) "Ping response" "got:0:ping" >>= fun () -> - Registry.Version.read version >|= Alcotest.(check string) "Version response" "0.1" >>= fun () -> - Capability.dec_ref registry; - Capability.dec_ref echo_service; - Capability.dec_ref version; - Lwt.return () - -let cmd_result t = - let pp f (x : ('a Cmdliner.Cmd.eval_ok, Cmdliner.Cmd.eval_error) result) = - match x with - | Ok (`Help) -> Fmt.string f "help" - | Ok (`Version) -> Fmt.string f "version" - | Ok (`Ok x) -> Alcotest.pp t f x - | _ -> Fmt.string f "error" - in - let equal a b = - match a, b with - | Ok (`Ok a), Ok (`Ok b) -> Alcotest.equal t a b - | _ -> a = b - in - Alcotest.testable pp equal - -let vat_config = Alcotest.testable Capnp_rpc_unix.Vat_config.pp Capnp_rpc_unix.Vat_config.equal - -let config_result = cmd_result vat_config - -let test_options () = - let term = Cmdliner.Cmd.(v (info "main") Capnp_rpc_unix.Vat_config.cmd) in - let config = Cmdliner.Cmd.eval_value - ~argv:[| "main"; "--capnp-secret-key-file=key.pem"; "--capnp-listen-address"; "unix:/run/socket" |] term in - let expected = - Result.ok (`Ok (Capnp_rpc_unix.Vat_config.create - ~secret_key:(`File "key.pem") - (`Unix "/run/socket"))) - in - Alcotest.check config_result "Unix, same address" expected config; - let expected = - Result.ok (`Ok (Capnp_rpc_unix.Vat_config.create - ~secret_key:(`File "key.pem") - ~public_address:(`TCP ("1.2.3.4", 7001)) - (`TCP ("0.0.0.0", 7000)))) - in - Cmdliner.Cmd.eval_value ~argv:[| "main"; - "--capnp-secret-key-file=key.pem"; - "--capnp-public-address"; "tcp:1.2.3.4:7001"; - "--capnp-listen-address"; "tcp:0.0.0.0:7000" |] term - |> Alcotest.check config_result "Using TCP" expected - -let expect_ok = function - | Error (`Msg m) -> Alcotest.fail m - | Ok x -> x - -let test_sturdy_uri () = - let module Address = Capnp_rpc_unix.Network.Address in - let address = (module Address : Alcotest.TESTABLE with type t = Address.t) in - let sturdy_ref = Alcotest.pair address Alcotest.string in - let check msg expected_uri sr = - let uri = Address.to_uri sr in - Alcotest.(check string) msg expected_uri (Uri.to_string uri); - let sr2 = Address.parse_uri uri |> expect_ok in - Alcotest.check sturdy_ref msg sr sr2 - in - let sr = (`Unix "/sock", Auth.Digest.insecure), "" in - check "Insecure Unix" "capnp://insecure@/sock/" sr; - let sr = (`TCP ("localhost", 7000), Auth.Digest.insecure), "" in - check "Insecure TCP" "capnp://insecure@localhost:7000" sr; - let test_uri = Uri.of_string "capnp://sha-256:s16WV4JeGusAL_nTjvICiQOFqm3LqYrDj3K-HXdMi8s@/" in - let auth = Auth.Digest.from_uri test_uri |> expect_ok in - let sr = (`TCP ("localhost", 7000), auth), "main" in - check "Secure TCP" "capnp://sha-256:s16WV4JeGusAL_nTjvICiQOFqm3LqYrDj3K-HXdMi8s@localhost:7000/bWFpbg" sr; - let sr = (`Unix "/sock", auth), "main" in - check "Secure Unix" "capnp://sha-256:s16WV4JeGusAL_nTjvICiQOFqm3LqYrDj3K-HXdMi8s@/sock/bWFpbg" sr - -let test_sturdy_self switch = - let service = Echo.local () in - Capability.inc_ref service; - make_vats ~switch ~serve_tls:true ~service () >>= fun cs -> - let id = Restorer.Id.public "" in - let sr = Vat.sturdy_uri cs.server id |> Vat.import_exn cs.server in - Sturdy_ref.connect_exn sr >>= fun service2 -> - Alcotest.check cap "Restore from same vat" service service2; - Capability.dec_ref service2; - Capability.dec_ref service; - Lwt.return () - -let expect_non_exn = function - | Ok x -> x - | Error ex -> Alcotest.failf "expect_non_exn: %a" Capnp_rpc.Exception.pp ex - -let except = Alcotest.testable Capnp_rpc.Exception.pp (=) -let except_ty = Alcotest.testable Capnp_rpc.Exception.pp_ty (=) - -let test_table_restorer _switch = - let make_sturdy id = Uri.make ~path:(Restorer.Id.to_string id) () in - let table = Restorer.Table.create make_sturdy in - let echo_id = Restorer.Id.public "echo" in - let registry_id = Restorer.Id.public "registry" in - let broken_id = Restorer.Id.public "broken" in - let unknown_id = Restorer.Id.public "unknown" in - Restorer.Table.add table echo_id @@ Echo.local (); - Restorer.Table.add table registry_id @@ Registry.local (); - Restorer.Table.add table broken_id @@ Capability.broken (Capnp_rpc.Exception.v "broken"); - let r = Restorer.of_table table in - Restorer.restore r echo_id >|= expect_non_exn >>= fun a1 -> - Echo.ping a1 "ping" >>= fun reply -> - Alcotest.(check string) "Ping response" "got:0:ping" reply; - Restorer.restore r echo_id >|= expect_non_exn >>= fun a2 -> - Alcotest.check cap "Same cap" a1 a2; - Restorer.restore r registry_id >|= expect_non_exn >>= fun r1 -> - assert (a1 <> r1); - Restorer.restore r broken_id >|= expect_non_exn >>= fun x -> - let expected = Some (Capnp_rpc.Exception.v "broken") in - Alcotest.(check (option except)) "Broken response" expected (Capability.problem x); - Restorer.restore r unknown_id >>= fun x -> - let expected = Error (Capnp_rpc.Exception.v "Unknown persistent service ID") in - Alcotest.(check (result reject except)) "Missing mapping" expected x; - Capability.dec_ref a1; - Capability.dec_ref a2; - Capability.dec_ref r1; - Restorer.Table.remove table echo_id; - Restorer.Table.clear table; - Lwt.return () - -module Loader = struct - type t = string -> Restorer.resolution Lwt.t - - let hash _ = `SHA256 - let make_sturdy _ id = Uri.make ~path:(Restorer.Id.to_string id) () - let load t _sr digest = t digest -end - -let test_fn_restorer _switch = - let cap = Alcotest.testable Capability.pp (=) in - let a = Restorer.Id.public "a" in - let b = Restorer.Id.public "b" in - let c = Restorer.Id.public "c" in - let current_c = ref (Restorer.reject (Exception.v "Broken C")) in - let delay = Lwt_condition.create () in - let digest = Restorer.Id.digest (Loader.hash ()) in - let load d = - if d = digest a then Lwt.return @@ Restorer.grant @@ Echo.local () - else if d = digest b then Lwt_condition.wait delay >|= fun () -> Restorer.grant @@ Echo.local () - else if d = digest c then Lwt_condition.wait delay >|= fun () -> !current_c - else Lwt.return @@ Restorer.unknown_service_id - in - let table = Restorer.Table.of_loader (module Loader) load in - let restorer = Restorer.of_table table in - let restore x = Restorer.restore restorer x in - (* Check that restoring the same ID twice caches the capability. *) - restore a >|= expect_non_exn >>= fun a1 -> - restore a >|= expect_non_exn >>= fun a2 -> - Alcotest.check cap "Restore cached" a1 a2; - Capability.dec_ref a1; - Capability.dec_ref a2; - (* But if it's released, the next lookup loads a fresh one. *) - restore a >|= expect_non_exn >>= fun a3 -> - if a1 = a3 then Alcotest.fail "Returned released cap!"; - Capability.dec_ref a3; - (* Doing two lookups in parallel only does one load. *) - let b1 = restore b in - let b2 = restore b in - assert (Lwt.state b1 = Lwt.Sleep); - Lwt_condition.broadcast delay (); - b1 >|= expect_non_exn >>= fun b1 -> - b2 >|= expect_non_exn >>= fun b2 -> - Alcotest.check cap "Restore delayed cached" b1 b2; - Restorer.Table.clear table; (* (should have no effect) *) - Capability.dec_ref b1; - Capability.dec_ref b2; - (* Failed lookups aren't cached. *) - let c1 = restore c in - Lwt_condition.broadcast delay (); - c1 >>= fun c1 -> - let reject = Alcotest.result cap except in - Alcotest.check reject "C initially fails" (Error (Exception.v "Broken C")) c1; - let c2 = restore c in - let c_service = Echo.local () in - current_c := Restorer.grant c_service; - Lwt_condition.broadcast delay (); - c2 >|= expect_non_exn >>= fun c2 -> - Alcotest.check cap "C now works" c_service c2; - Capability.dec_ref c2; - (* Two users; one frees the cap immediately *) - let b1 = - restore b >|= expect_non_exn >|= fun b1 -> - Capability.dec_ref b1; - b1 - in - let b2 = restore b in - Lwt_condition.broadcast delay (); - b1 >>= fun b1 -> - b2 >|= expect_non_exn >>= fun b2 -> - Alcotest.check cap "Cap not freed" b1 b2; - Capability.dec_ref b2; - Lwt.return_unit - -let test_broken switch = - make_vats ~switch ~service:(Echo.local ()) () >>= fun cs -> - get_bootstrap cs >>= fun service -> - Echo.ping service "ping" >|= Alcotest.(check string) "Ping response" "got:0:ping" >>= fun () -> - let problem, set_problem = Lwt.wait () in - Capability.when_broken (fun x -> Lwt.wakeup set_problem x) service; - Alcotest.check (Alcotest.option except) "Still OK" None @@ Capability.problem service; - assert (Lwt.state problem = Lwt.Sleep); - Logs.info (fun f -> f "Turning off server..."); - Lwt_switch.turn_off cs.server_switch >>= fun () -> - problem >>= fun problem -> - Alcotest.check except_ty "Broken callback ran" `Disconnected problem.ty; - assert (Capability.problem service <> None); - Lwt.catch - (fun () -> Echo.ping service "ping" >|= fun _ -> Alcotest.fail "Should have failed!") - (fun _ -> Lwt.return ()) - >|= fun () -> - Capability.dec_ref service - -(* [when_broken] follows promises. *) -let test_broken2 () = - let promise, resolver = Capability.promise () in - let problem = ref None in - Capability.when_broken (fun x -> problem := Some x) promise; - let p2, r2 = Capability.promise () in - Capability.resolve_ok resolver p2; - Alcotest.check (Alcotest.option except) "No problem yet" None !problem; - let ex = Exception.v "Test" in - Capability.resolve_ok r2 (Capability.broken ex); - Alcotest.check (Alcotest.option except) "Now broken" (Some ex) !problem; - () - -let test_broken3 () = - let ex = Exception.v "Test" in - let c = Capability.broken ex in - let problem = ref None in - Capability.when_broken (fun x -> problem := Some x) c; - Alcotest.check (Alcotest.option except) "Broken immediately" (Some ex) !problem - -let test_broken4 () = - let promise, _resolver = Capability.promise () in - let problem = ref None in - Capability.when_broken (fun x -> problem := Some x) promise; - Capability.dec_ref promise; - Alcotest.check (Alcotest.option except) "Released, not called" None !problem - -let test_parallel_connect switch = - make_vats ~switch ~serve_tls:true ~service:(Echo.local ()) () >>= fun cs -> - let service = get_bootstrap cs in - let service2 = get_bootstrap cs in - service >>= fun service -> - service2 >>= fun service2 -> - Capability.await_settled_exn service >>= fun () -> - Capability.await_settled_exn service2 >>= fun () -> - Alcotest.check cap "Shared connection" service service2; - Capability.dec_ref service; - Capability.dec_ref service2; - Lwt.return_unit - -let test_parallel_fails switch = - make_vats ~switch ~serve_tls:true ~service:(Echo.local ()) () >>= fun cs -> - let service = get_bootstrap cs in - let service2 = get_bootstrap cs in - service >>= fun service -> - service2 >>= fun service2 -> - Lwt_switch.turn_off cs.server_switch >>= fun () -> - Capability.await_settled_exn service >>= fun () -> - Capability.await_settled_exn service2 >>= fun () -> - Alcotest.check cap "Shared failure" service service2; - Capability.dec_ref service; - Capability.dec_ref service2; - (* Restart server (ignore new client) *) - Lwt.pause () >>= fun () -> - make_vats ~switch ~serve_tls:true ~service:(Echo.local ()) () >>= fun _cs2 -> - get_bootstrap cs >>= fun service -> - Echo.ping service "ping" >|= Alcotest.(check string) "Ping response" "got:0:ping" >>= fun () -> - Capability.dec_ref service; - Lwt.return_unit - -let test_crossed_calls switch = - (* Would be good to control the ordering here, to test the various cases. - Currently, it's not certain which path is actually tested. *) - let id = Restorer.Id.public "" in - let make_vat ~secret_key ~tags addr = - let service = Echo.local () in - let restore = Restorer.(single id) service in - let config = - let secret_key = `PEM (Auth.Secret_key.to_pem_data secret_key) in - let name = Fmt.str "capnp-rpc-test-%s" addr in - Capnp_rpc_unix.Vat_config.create ~secret_key (get_test_address ~switch name) - in - Capnp_rpc_unix.serve ~switch ~tags ~restore config >>= fun vat -> - Lwt_switch.add_hook (Some switch) (fun () -> Capability.dec_ref service; Lwt.return_unit); - Lwt.return vat - in - make_vat ~secret_key:client_key ~tags:Test_utils.client_tags "client" >>= fun client -> - make_vat ~secret_key:server_key ~tags:Test_utils.server_tags "server" >>= fun server -> - let sr_to_client = Capnp_rpc_unix.Vat.sturdy_uri client id |> Vat.import_exn server in - let sr_to_server = Capnp_rpc_unix.Vat.sturdy_uri server id |> Vat.import_exn client in - let to_client = Sturdy_ref.connect_exn sr_to_client in - let to_server = Sturdy_ref.connect_exn sr_to_server in - to_client >>= fun to_client -> - to_server >>= fun to_server -> - Logs.info (fun f -> f ~tags:Test_utils.client_tags "%a" Capnp_rpc_unix.Vat.dump client); - Logs.info (fun f -> f ~tags:Test_utils.server_tags "%a" Capnp_rpc_unix.Vat.dump server); - let s_got = Echo.ping_result to_client "ping" in - let c_got = Echo.ping_result to_server "ping" in - s_got >>= fun s_got -> - c_got >>= fun c_got -> - begin match c_got, s_got with - | Ok x, Ok y -> Lwt.return (x, y) - | Ok x, Error _ -> - (* Server got an error. Try client again. *) - Sturdy_ref.connect_exn sr_to_client >>= fun to_client -> - Capability.with_ref to_client @@ fun to_client -> - Echo.ping to_client "ping" >|= fun s_got -> (x, s_got) - | Error _, Ok y -> - (* Client got an error. Try server again. *) - Sturdy_ref.connect_exn sr_to_server >>= fun to_server -> - Capability.with_ref to_server @@ fun to_server -> - Echo.ping to_server "ping" >|= fun c_got -> (c_got, y) - | Error (`Capnp e1), Error (`Capnp e2) -> - Fmt.failwith "@[Both connections failed!@,%a@,%a@]" - Capnp_rpc.Error.pp e1 - Capnp_rpc.Error.pp e2 - end >>= fun (c_got, s_got) -> - Alcotest.(check string) "Client's ping response" "got:0:ping" c_got; - Alcotest.(check string) "Server's ping response" "got:0:ping" s_got; - Capability.dec_ref to_client; - Capability.dec_ref to_server; - Lwt.return_unit - -(* Run test_crossed_calls several times to try to trigger the various behaviours. *) -let test_crossed_calls _switch = - let rec aux i = - if i = 0 then Lwt.return_unit - else ( - Lwt_switch.with_switch test_crossed_calls >>= fun () -> - aux (i - 1) - ) - in - aux 10 - -let test_store switch = - (* Persistent server configuration *) - let db = Store.DB.create () in - let config = - let addr = get_test_address ~switch "capnp-rpc-test-server" in - Capnp_rpc_unix.Vat_config.create ~secret_key:server_pem addr - in - let main_id = Restorer.Id.generate () in - let start_server ~switch () = - let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in - let table = Store.File.table ~make_sturdy db in - Lwt_switch.add_hook (Some switch) (fun () -> Restorer.Table.clear table; Lwt.return_unit); - let restore = Restorer.of_table table in - let service = Store.local ~restore db in - Restorer.Table.add table main_id service; - Capnp_rpc_unix.serve ~switch ~restore ~tags:Test_utils.server_tags config - in - (* Start server *) - let server_switch = Lwt_switch.create () in - start_server ~switch:server_switch () >>= fun server -> - let store_uri = Capnp_rpc_unix.Vat.sturdy_uri server main_id in - (* Set up client *) - let client = Capnp_rpc_unix.client_only_vat ~tags:Test_utils.client_tags ~switch () in - let sr = Capnp_rpc_unix.Vat.import_exn client store_uri in - Sturdy_ref.with_cap_exn sr @@ fun store -> - (* Try creating a file *) - let file = Store.create_file store in - Store.File.set file "Hello" >>= fun () -> - Persistence.save_exn file >>= fun file_sr -> - let file_sr = Vat.import_exn client file_sr in (* todo: get rid of this step *) - (* Shut down server *) - Lwt.async (fun () -> Lwt_switch.turn_off server_switch); - let broken, set_broken = Lwt.wait () in - Capability.when_broken (Lwt.wakeup set_broken) file; - broken >>= fun _ex -> - assert (Capability.problem file <> None); - (* Restart server *) - start_server ~switch () >>= fun _server -> - (* Reconnect client *) - Sturdy_ref.with_cap_exn file_sr @@ fun file -> - Store.File.get file >>= fun data -> - Alcotest.(check string) "Read file" "Hello" data; - Lwt.return_unit - -let test_file_store _switch = - Lwt_io.with_temp_dir ~prefix:"capnp-tests-" @@ fun tmpdir -> - let module S = Capnp_rpc_unix.File_store in - let s = S.create tmpdir in - Alcotest.(check (option reject)) "Missing file" None @@ S.load s ~digest:"missing"; - let module Builder = Testlib.Api.Builder.Simple in - let module Reader = Testlib.Api.Reader.Simple in - let data = - let b = Builder.init_root () in - Builder.text_set b "Test"; - Builder.to_reader b - in - S.save s ~digest:"!/.." data; - Alcotest.(check (option string)) "Restored" (Some "Test") @@ Option.map Reader.text_get (S.load s ~digest:"!/.."); - Lwt.return_unit - -let capnp_error = Alcotest.of_pp Capnp_rpc.Exception.pp - -let test_await_settled _switch = - (* Ok *) - let p, r = Capability.promise () in - let check = Capability.await_settled p in - Capability.resolve_ok r @@ Echo.local (); - check >>= fun check -> - Alcotest.(check (result unit capnp_error)) "Check await success" (Ok ()) check; - Capability.dec_ref p; - (* Error *) - let p, r = Capability.promise () in - let check = Capability.await_settled p in - let err = Capnp_rpc.Exception.v "Test" in - Capability.resolve_exn r err; - check >>= fun check -> - Alcotest.(check (result unit capnp_error)) "Check await failure" (Error err) check; - Lwt.return_unit - -(* The client disconnects before the server has finished loading the bootstrap object. *) -let test_late_bootstrap switch = - let connected, set_connected = Lwt.wait () in - let service, set_service = Lwt.wait () in - let module Loader = struct - type t = unit - let hash () = `SHA256 - let make_sturdy () _id = assert false - let load () _sr _name = - Lwt.wakeup_later set_connected (); - service - end in - let table = Capnp_rpc_net.Restorer.Table.of_loader (module Loader) () in - let restore = Restorer.of_table table in - let client_switch = Lwt_switch.create () in - make_vats_full ~client_switch ~server_switch:switch ~restore () >>= fun cs -> - let service = get_bootstrap cs in - connected >>= fun () -> - Lwt_switch.turn_off client_switch >>= fun () -> - Lwt.wakeup set_service @@ Capnp_rpc_net.Restorer.grant @@ Echo.local (); - service >>= fun _ -> - Lwt.return () - -let run name fn = Alcotest_lwt.test_case_sync name `Quick fn - -let rpc_tests = [ - run_lwt "Simple" (test_simple ~serve_tls:false); - run_lwt "Crypto" (test_simple ~serve_tls:true); - run_lwt "Bad crypto" test_bad_crypto ~expected_warnings:1; - run_lwt "Parallel" test_parallel; - run_lwt "Embargo" test_embargo; - run_lwt "Resolve" test_resolve; - run_lwt "Registry" test_registry; - run_lwt "Calculator" test_calculator; - run_lwt "Calculator 2" test_calculator2; - run_lwt "Cancel" test_cancel; - run_lwt "Indexing" test_indexing; - run "Options" test_options; - run "Sturdy URI" test_sturdy_uri; - run_lwt "Sturdy self" test_sturdy_self; - run_lwt "Table restorer" test_table_restorer; - run_lwt "Fn restorer" test_fn_restorer; - run_lwt "Broken ref" test_broken; - run "Broken ref 2" test_broken2; - run "Broken ref 3" test_broken3; - run "Broken ref 4" test_broken4; - run_lwt "Parallel connect" test_parallel_connect; - run_lwt "Parallel fails" test_parallel_fails; - run_lwt "Crossed calls" test_crossed_calls; - run_lwt "Store" test_store; - run_lwt "File store" test_file_store; - run_lwt "Await settled" test_await_settled; - run_lwt "Late bootstrap" test_late_bootstrap; -] - -let () = - Alcotest_lwt.run ~and_exit:false "capnp-rpc" [ - "lwt", rpc_tests; - ] |> Lwt_main.run diff --git a/test-lwt/test_lwt.mli b/test-lwt/test_lwt.mli deleted file mode 100644 index 9c0cbe895..000000000 --- a/test-lwt/test_lwt.mli +++ /dev/null @@ -1 +0,0 @@ -(* (no API) *) diff --git a/test/dune b/test/dune index 9f136be98..4c951ae6e 100644 --- a/test/dune +++ b/test/dune @@ -1,4 +1,5 @@ (test + (package capnp-rpc-unix) (name test) - (package capnp-rpc) - (libraries capnp-rpc alcotest logs.fmt testbed)) + (libraries capnp-rpc capnp-rpc-unix testlib logs.fmt + mirage-crypto-rng-eio testbed eio_main)) diff --git a/test/proto/dune b/test/proto/dune new file mode 100644 index 000000000..76abb6d50 --- /dev/null +++ b/test/proto/dune @@ -0,0 +1,4 @@ +(test + (name test) + (package capnp-rpc) + (libraries capnp-rpc.proto alcotest logs.fmt testbed)) diff --git a/test/proto/test.ml b/test/proto/test.ml new file mode 100644 index 000000000..3ee460817 --- /dev/null +++ b/test/proto/test.ml @@ -0,0 +1,1612 @@ +module Core_types = Testbed.Capnp_direct.Core_types +module Request = Testbed.Capnp_direct.String_content.Request +module Response = Testbed.Capnp_direct.String_content.Response +module Test_utils = Testbed.Test_utils +module Services = Testbed.Services +module CS = Testbed.Connection.Pair ( ) (* A client-server pair *) +module RO_array = Capnp_rpc_proto.RO_array +module Error = Capnp_rpc_proto.Error +module Exception = Capnp_rpc_proto.Exception +module Local_struct_promise = Testbed.Capnp_direct.Local_struct_promise +module Cap_proxy = Testbed.Capnp_direct.Cap_proxy + +module C = CS.C +module S = CS.S + +let inc_ref = Core_types.inc_ref +let dec_ref = Core_types.dec_ref +let with_inc_ref x = inc_ref x; (x :> Core_types.cap) + +let response_equal a b = + let a_caps = Core_types.Response_payload.snapshot_caps a in + let b_caps = Core_types.Response_payload.snapshot_caps b in + Response.data a = Response.data b && + RO_array.equal (=) a_caps b_caps + +let error = Alcotest.of_pp Capnp_rpc_proto.Error.pp +let response = Alcotest.testable Core_types.Response_payload.pp response_equal +let response_promise = Alcotest.(option (result response error)) + +let exn = Alcotest.of_pp Capnp_rpc_proto.Exception.pp + +let call target msg caps = + let caps = List.map (fun x -> (x :> Core_types.cap)) caps in + List.iter Core_types.inc_ref caps; + let results, resolver = Local_struct_promise.make () in + let msg = + Testbed.Capnp_direct.String_content.Request.v msg + |> Core_types.Request_payload.with_caps (RO_array.of_list caps) + in + target#call resolver msg; + results + +let call_for_cap target msg caps = + let q = call target msg caps in + let cap = q#cap 0 in + dec_ref q; + cap + +(* Takes ownership of caps *) +let resolve_ok (ans:#Core_types.struct_resolver) msg caps = + let caps = List.map (fun x -> (x :> Core_types.cap)) caps in + let msg = + Testbed.Capnp_direct.String_content.Request.v msg + |> Core_types.Response_payload.with_caps (RO_array.of_list caps) + in + Core_types.resolve_ok ans msg + +let test_simple_connection () = + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags (Services.echo_service ()) in + let servce_promise = C.bootstrap c in + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; + S.handle_msg s ~expect:"finish"; + let q = call servce_promise "my-content" [] in + S.handle_msg s ~expect:"call:my-content"; + C.handle_msg c ~expect:"return:got:my-content"; + let expected = Request.v "got:my-content" in + Alcotest.(check response_promise) "Client got call response" (Some (Ok expected)) q#response; + dec_ref q; + dec_ref servce_promise; + CS.flush c s; + CS.check_finished c s + +let init_pair ~bootstrap_service = + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags bootstrap_service in + let bs = C.bootstrap c in + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; + S.handle_msg s ~expect:"finish"; + c, s, bs + +(* The server gets an object and then sends it back. When the object arrives back + at the client, it must be the original (local) object, not a proxy. *) +let test_return () = + let c, s, bs = init_pair ~bootstrap_service:(Services.echo_service ()) in + (* Pass callback *) + let slot = ref (Request.v "empty") in + let local = Services.swap_service slot in + let q = call bs "c1" [local] in + dec_ref local; + (* Server echos args back *) + S.handle_msg s ~expect:"call:c1"; + C.handle_msg c ~expect:"return:got:c1"; + let expected = Response.v "got:c1" + |> Core_types.Response_payload.with_caps (RO_array.of_list [(local :> Core_types.cap)]) + in + Alcotest.(check response_promise) "Client got response" (Some (Ok expected)) q#response; + dec_ref bs; + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"release"; + C.handle_msg c ~expect:"release"; + dec_ref q; + CS.check_finished c s + +let test_return_error () = + let c, s, bs = init_pair ~bootstrap_service:(Core_types.broken_cap (Exception.v "test-error")) in + (* Pass callback *) + let slot = ref (Request.v "empty") in + let local = Services.swap_service slot in + let q = call bs "call" [local] in + dec_ref local; + (* Server echos args back *) + CS.flush c s; + Alcotest.(check response_promise) "Client got response" (Some (Error (Error.exn "test-error"))) q#response; + dec_ref q; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +let test_share_cap () = + let c, s, bs = init_pair ~bootstrap_service:(Services.echo_service ()) in + let q = call bs "msg" [bs; bs] in + dec_ref bs; + S.handle_msg s ~expect:"call:msg"; + S.handle_msg s ~expect:"release"; (* Server drops [bs] export *) + (* Server re-exports [bs] as result of echo *) + C.handle_msg c ~expect:"return:got:msg"; + dec_ref q; + CS.flush c s; + CS.check_finished c s + +(* The server gets an object and then sends it back. Messages pipelined to + the object must arrive before ones sent directly. *) +let test_local_embargo () = + let c, s, bs = init_pair ~bootstrap_service:(Services.echo_service ()) in + let local = Services.logger () in + let q = call bs "Get service" [local] in + let service = q#cap 0 in + let m1 = call service "Message-1" [] in + S.handle_msg s ~expect:"call:Get service"; + C.handle_msg c ~expect:"return:got:Get service"; + dec_ref q; + (* We've received the bootstrap reply, so we know that [service] is local, + but the pipelined message we sent to it via [s] hasn't arrived yet. *) + let m2 = call service "Message-2" [] in + S.handle_msg s ~expect:"call:Message-1"; + C.handle_msg c ~expect:"call:Message-1"; (* Gets pipelined message back *) + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"return:take-from-other"; (* Get results of Message-1 directly *) + C.handle_msg c ~expect:"disembargo-reply"; + Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; + Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; + (* Clean up *) + dec_ref m1; + dec_ref m2; + dec_ref local; + dec_ref bs; + dec_ref service; + CS.flush c s; + CS.check_finished c s + +(* As above, but this time it resolves to a promised answer. *) +let test_local_embargo_2 () = + let server_main = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:server_main in + let local = Services.logger () in + let local_reg = Services.manual () in (* A registry that provides access to [local]. *) + let q1 = call bs "q1" [local_reg] in (* Give the server our registry and get back [local]. *) + let service = q1#cap 0 in (* Service is a promise for local *) + dec_ref q1; + let m1 = call service "Message-1" [] in (* First message to service *) + S.handle_msg s ~expect:"call:q1"; + let proxy_to_local_reg, a1 = server_main#pop1 "q1" in + (* The server will now make a call on the client registry, and then tell the client + to use the (unknown) result of that for [service]. *) + let q2 = call proxy_to_local_reg "q2" [] in + dec_ref proxy_to_local_reg; + let proxy_to_local = q2#cap 0 in + resolve_ok a1 "a1" [proxy_to_local]; + (* [proxy_to_local] is now owned by [a1]. *) + dec_ref q2; + C.handle_msg c ~expect:"call:q2"; + let a2 = local_reg#pop0 "q2" in + C.handle_msg c ~expect:"release"; + C.handle_msg c ~expect:"return:a1"; + (* The client now knows that [a1/0] is a local promise, but it can't use it directly yet because + of the pipelined messages. It sends a disembargo request down the old [q1/0] path and waits for + it to arrive back at the local promise. *) + resolve_ok a2 "a2" [local]; + (* Message-2 must be embargoed so that it arrives after Message-1. *) + let m2 = call service "Message-2" [] in + S.handle_msg s ~expect:"call:Message-1"; + C.handle_msg c ~expect:"call:Message-1"; (* Gets pipelined message back *) + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"return:take-from-other"; (* Get results of Message-1 directly *) + C.handle_msg c ~expect:"disembargo-reply"; + Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; + Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; + (* Clean up *) + dec_ref m1; + dec_ref m2; + dec_ref bs; + dec_ref service; + dec_ref local_reg; + CS.flush c s; + CS.check_finished c s + +(* Embargo on a resolve message *) +let test_local_embargo_3 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.logger () in + let q1 = call bs "q1" [local] in + S.handle_msg s ~expect:"call:q1"; + let proxy_to_logger, a1 = service#pop1 "q1" in + let promise = Cap_proxy.local_promise () in + resolve_ok a1 "a1" [promise]; + C.handle_msg c ~expect:"return:a1"; + let service = q1#cap 0 in + let m1 = call service "Message-1" [] in + promise#resolve proxy_to_logger; + C.handle_msg c ~expect:"resolve"; + (* We've received the resolve message, so we know that [service] is local, + but the pipelined message we sent to it via [s] hasn't arrived yet. *) + let m2 = call service "Message-2" [] in + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"call:Message-1"; + C.handle_msg c ~expect:"call:Message-1"; (* Gets pipelined message back *) + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"return:take-from-other"; (* Get results of Message-1 directly *) + C.handle_msg c ~expect:"disembargo-reply"; + Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; + Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; + (* Clean up *) + dec_ref m1; + dec_ref m2; + dec_ref local; + dec_ref q1; + dec_ref bs; + dec_ref service; + CS.flush c s; + CS.check_finished c s + +(* Embargo a local answer that doesn't have the specified cap. *) +let test_local_embargo_4 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.echo_service () in + let q1 = call bs "q1" [local] in + let broken = q1#cap 0 in + let qp = call broken "pipeline" [] in + S.handle_msg s ~expect:"call:q1"; + let proxy_to_local, a1 = service#pop1 "q1" in + let q2 = call proxy_to_local "q2" [] in + resolve_ok a1 "a1" [q2#cap 0]; + dec_ref q2; + C.handle_msg c ~expect:"call:q2"; + C.handle_msg c ~expect:"return:a1"; + (* At this point, the client knows that [broken] is its own answer to [q2], which is an error. + It therefore does not try to disembargo it. *) + Alcotest.(check string) "Error not embargoed" + "Failed: Invalid capability index!" + (Fmt.str "%t" broken#shortest#pp); + (* Clean up *) + dec_ref qp; + dec_ref local; + dec_ref proxy_to_local; + dec_ref q1; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +(* A remote answer resolves to a remote promise, which doesn't require an embargo. + However, when that promise resolves to a local service, we *do* need an embargo + (because we pipelined over the answer), even though we didn't pipeline over the + import. *) +let test_local_embargo_5 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.logger () in + let q1 = call bs "q1" [local] in + let test = q1#cap 0 in + let m1 = call test "Message-1" [] in + S.handle_msg s ~expect:"call:q1"; + let proxy_to_local, a1 = service#pop1 "q1" in + let server_promise = Cap_proxy.local_promise () in + resolve_ok a1 "a1" [server_promise]; + C.handle_msg c ~expect:"return:a1"; + (* [test] is now known to be at [service]; no embargo needed. + The server now resolves it to a client service. *) + server_promise#resolve proxy_to_local; + C.handle_msg c ~expect:"resolve"; + let m2 = call test "Message-2" [] in + CS.flush c s; + Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; + Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; + CS.flush c s; + (* Clean up *) + dec_ref m1; + dec_ref m2; + dec_ref local; + dec_ref test; + dec_ref q1; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +(* We pipeline a message to a question, and then discover that it resolves + to a local answer, which points to a capability at the peer. As the peer + is already bouncing the pipelined message back to us, we need to embargo + the new cap until the server's question is finished. *) +let test_local_embargo_6 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.manual () in + (* Client calls the server, giving it [local]. *) + let target = call_for_cap bs "q1" [local] in + let m1 = call target "Message-1" [] in + S.handle_msg s ~expect:"call:q1"; + let proxy_to_local, a1 = service#pop1 "q1" in + (* Server makes a call on [local] and uses that promise to answer [q1]. *) + let q2 = call proxy_to_local "q2" [] in + resolve_ok a1 "a1" [q2#cap 0]; + C.handle_msg c ~expect:"call:q2"; + S.handle_msg s ~expect:"call:Message-1"; (* Forwards pipelined call back to the client *) + (* Client resolves a2 to [bs]. *) + let a2 = local#pop0 "q2" in + resolve_ok a2 "a2" [bs]; + (* Server gets response to q2, that [q2#cap 0] is [bs]. + Although we don't actually care about this, it still embargoes it: *) + S.handle_msg s ~expect:"return:a2"; + (* Client gets results from q1 - need to embargo it until we've forwarded the pipelined message + back to the server. *) + C.handle_msg c ~expect:"return:a1"; + Logs.info (fun f -> f "target = %t" target#pp); + let m2 = call target "Message-2" [] in (* Client tries to send message-2, but it gets embargoed *) + dec_ref target; + S.handle_msg s ~expect:"disembargo-request"; + S.handle_msg s ~expect:"finish"; (* Finish for q1 *) + C.handle_msg c ~expect:"call:Message-1"; (* Pipelined message-1 arrives at client *) + C.handle_msg c ~expect:"return:take-from-other"; + C.handle_msg c ~expect:"disembargo-request"; (* (the server is doing its own embargo on q2) *) + S.handle_msg s ~expect:"call:Message-1"; + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"disembargo-reply"; (* (the server is doing its own embargo on q2) *) + C.handle_msg c ~expect:"disembargo-reply"; + S.handle_msg s ~expect:"call:Message-2"; + let am1 = service#pop0 "Message-1" in + let am2 = service#pop0 "Message-2" in + resolve_ok am1 "m1" []; + resolve_ok am2 "m2" []; + dec_ref m1; + dec_ref m2; + dec_ref q2; + dec_ref proxy_to_local; + dec_ref local; + CS.flush c s; + CS.check_finished c s + +(* The client tries to disembargo via a switchable. *) +let test_local_embargo_7 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.manual () in + (* Client calls the server, giving it [local]. *) + let q1 = call bs "q1" [local] in + let target = q1#cap 0 in + dec_ref q1; + let m1 = call target "Message-1" [] in + S.handle_msg s ~expect:"call:q1"; + let proxy_to_local, a1 = service#pop1 "q1" in + (* Server makes a call on [local] and uses that promise to answer [q1]. *) + let q2 = call proxy_to_local "q2" [] in + resolve_ok a1 "a1" [q2#cap 0]; + dec_ref q2; + C.handle_msg c ~expect:"call:q2"; + S.handle_msg s ~expect:"call:Message-1"; (* Forwards pipelined call back to the client *) + (* Client resolves a2 to a local promise. *) + let client_promise = Cap_proxy.local_promise () in + let a2 = local#pop0 "q2" in + resolve_ok a2 "a2" [with_inc_ref client_promise]; + (* Client gets answer to a1 and sends disembargo. *) + C.handle_msg c ~expect:"return:a1"; + let m2 = call target "Message-2" [] in + S.handle_msg s ~expect:"return:a2"; + (* At this point, the server's answer to q1 is a switchable, because it expects the client + to resolve the promise at some point in the future. *) + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"call:Message-1"; (* Pipelined message-1 arrives at client *) + C.handle_msg c ~expect:"return:take-from-other"; + C.handle_msg c ~expect:"disembargo-reply"; + let client_logger = Services.logger () in + inc_ref client_logger; + client_promise#resolve (client_logger :> Core_types.cap); + dec_ref client_promise; + CS.flush c s; + Alcotest.(check string) "Pipelined arrived first" "Message-1" client_logger#pop; + Alcotest.(check string) "Embargoed arrived second" "Message-2" client_logger#pop; + dec_ref m1; + dec_ref m2; + dec_ref client_logger; + dec_ref proxy_to_local; + dec_ref local; + dec_ref bs; + dec_ref target; + CS.flush c s; + CS.check_finished c s + +let test_local_embargo_8 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.manual () in + (* Client calls the server, giving it [local]. *) + let q1 = call bs "q1" [local] in + let target = q1#cap 0 in + dec_ref q1; + S.handle_msg s ~expect:"call:q1"; + let proxy_to_local, a1 = service#pop1 "q1" in + (* Server makes a call on [local] and uses that promise to answer [q1]. *) + let q2 = call proxy_to_local "q2" [] in + (* Client resolves a2 to a local promise. *) + C.handle_msg c ~expect:"call:q2"; + let a2 = local#pop0 "q2" in + let local_promise = Cap_proxy.local_promise () in + resolve_ok a2 "a2" [local_promise]; + (* The server then answers q1 with that [local_promise]. *) + S.handle_msg s ~expect:"return:a2"; + resolve_ok a1 "a1" [q2#cap 0]; + dec_ref q2; + C.handle_msg c ~expect:"finish"; + (* The client resolves the local promise to a remote one *) + let q3 = call bs "q3" [] in + let remote_promise = q3#cap 0 in + let m1 = call target "Message-1" [] in + local_promise#resolve remote_promise; + S.handle_msg s ~expect:"call:q3"; + S.handle_msg s ~expect:"call:Message-1"; (* Forwards pipelined call back to the client *) + S.handle_msg s ~expect:"resolve"; + (* Client gets answer to a1 and sends disembargo. *) + C.handle_msg c ~expect:"return:a1"; + (* We now know that [target] is [remote_promise], but we need to embargo it until Message-1 + arrives back at the client. *) + let m2 = call target "Message-2" [] in + C.handle_msg c ~expect:"call:Message-1"; (* Forwards pipelined call back to the server again *) + S.handle_msg s ~expect:"disembargo-request"; + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"call:Message-1"; + C.handle_msg c ~expect:"return:take-from-other"; (* Reply to client's first Message-1 *) + S.handle_msg s ~expect:"finish"; + C.handle_msg c ~expect:"disembargo-request"; (* Server is also doing its own embargo *) + C.handle_msg c ~expect:"disembargo-reply"; (* Client now disembargoes Message-2 *) + S.handle_msg s ~expect:"disembargo-reply"; + C.handle_msg c ~expect:"release"; + C.handle_msg c ~expect:"finish"; + S.handle_msg s ~expect:"call:Message-2"; + let logger = Services.logger () in + let a3 = service#pop0 "q3" in + inc_ref logger; + resolve_ok a3 "a3" [logger]; + Alcotest.(check string) "Pipelined arrived first" "Message-1" logger#pop; + Alcotest.(check string) "Embargoed arrived second" "Message-2" logger#pop; + dec_ref m1; + dec_ref m2; + dec_ref q3; + dec_ref target; + dec_ref proxy_to_local; + dec_ref logger; + dec_ref bs; + dec_ref local; + CS.flush c s; + CS.check_finished c s + +(* m1 and m2 are sent in order on the same reference, [pts2]. + They must arrive in order too. *) +let _test_local_embargo_9 () = + let client_bs = Services.manual () in + let service_bs = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags ~client_bs:(with_inc_ref client_bs) + ~server_tags:Test_utils.server_tags (with_inc_ref service_bs) in + (* The client gets the server's bootstrap. *) + let service = C.bootstrap c in + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; + S.handle_msg s ~expect:"finish"; + (* The server gets the client's bootstrap. *) + let ptc0 = S.bootstrap s in (* The first proxy-to-client *) + C.handle_msg c ~expect:"bootstrap"; + S.handle_msg s ~expect:"return:(boot)"; + C.handle_msg c ~expect:"finish"; + (* The client calls the server. *) + let pts1 = call_for_cap service "service.ptc0" [] in (* will become [ptc0] *) + let pts2 = call_for_cap service "service.ptc1" [] in (* will become [ptc1] *) + S.handle_msg s ~expect:"call:service.ptc0"; + S.handle_msg s ~expect:"call:service.ptc1"; + (* The server calls the client. *) + let ptc1 = call_for_cap ptc0 "client.self" [] in (* [ptc1] will become [ptc0] *) + C.handle_msg c ~expect:"call:client.self"; + (* The client handles the server's request by returning [pts1], which will become [ptc0]. *) + let ptc0_resolver = client_bs#pop0 "client.self" in + resolve_ok ptc0_resolver "reply" [pts1]; + (* The server handles the client's requests by returning [ptc0] (the client's bootstrap) + and [ptc1], which will resolve to the client's bootstrap later. *) + let pts0_resolver = service_bs#pop0 "service.ptc0" in + resolve_ok pts0_resolver "ptc0" [ptc0]; + let pts1_resolver = service_bs#pop0 "service.ptc1" in + resolve_ok pts1_resolver "ptc1" [with_inc_ref ptc1]; + (* The client pipelines a message to the server: *) + let m1 = call pts2 "m1" [] in + (* The client gets replies to its questions: *) + C.handle_msg c ~expect:"return:ptc0"; (* Resolves pts1 to client_bs (only used for pipelining) *) + C.handle_msg c ~expect:"return:ptc1"; (* Resolves pts2 to embargoed(pts1) (embargoed because of [m1]) *) + (* The client knows [ptc1] is local, but has embargoed it. + [m1] must arrive back at the client before the disembargo. *) + let m2 = call pts2 "m2" [] in + S.handle_msg s ~expect:"return:reply"; + S.handle_msg s ~expect:"call:m1"; (* Server forwards m1 back to client *) + C.handle_msg c ~expect:"call:m1"; (* Client forwards m1 back to server *) + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"return:take-from-other"; + C.handle_msg c ~expect:"disembargo-reply"; + (* Client does a second disembargo *) + S.handle_msg s ~expect:"finish"; + C.handle_msg c ~expect:"finish"; + S.handle_msg s ~expect:"call:m1"; (* Server forwards m1 back to client again *) + C.handle_msg c ~expect:"call:m1"; (* m1 finally arrives *) + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"return:take-from-other"; + C.handle_msg c ~expect:"finish"; + C.handle_msg c ~expect:"disembargo-reply"; + (* At this point, the client knows [m1] must have arrived by now and delivers m2. *) + let am1 = client_bs#pop0 "m1" in + let am2 = client_bs#pop0 "m2" in + resolve_ok am1 "am1" []; + resolve_ok am2 "am2" []; + dec_ref pts2; + dec_ref ptc1; + dec_ref client_bs; + dec_ref service_bs; + dec_ref service; + dec_ref m1; + dec_ref m2; + CS.flush c s; + CS.check_finished c s + +(* We still need embargoes with self-results-to=yourself. *) +let test_local_embargo_10 () = + let service_1 = Services.manual () in (* At the client *) + let c, s = CS.create + ~client_tags:Test_utils.client_tags + ~server_tags:Test_utils.server_tags (Services.echo_service ()) + in + let proxy_to_echo = C.bootstrap c in + CS.flush c s; + (* The client asks for a service, which will resolve to [service_1]. + It pipelines it a message [q1], and then pipelines [m1] on the result of that. + The server will forward [q1] back to the client and tell it to take the answer + from that. Because the client already sent [m1] over the result, it must + embargo it and wait before sending [m2]. *) + let q0 = call proxy_to_echo "echo" [service_1] in + let bs = q0#cap 0 in + dec_ref q0; + (* bs is a promise for the client's own [service_1]. *) + let q1 = call bs "q1" [] in + let target = q1#cap 0 in + let m1 = call target "M-1" [] in + S.handle_msg s ~expect:"call:echo"; + S.handle_msg s ~expect:"call:q1"; + S.handle_msg s ~expect:"call:M-1"; + C.handle_msg c ~expect:"return:got:echo"; + S.handle_msg s ~expect:"disembargo-request"; (* Client disembargoing bootstrap *) + C.handle_msg c ~expect:"call:q1"; + let aq1 = service_1#pop0 "q1" in + resolve_ok aq1 "aq1" [with_inc_ref service_1]; + C.handle_msg c ~expect:"return:take-from-other"; (* Return for client's q1 - use aq1 *) + (* At this point, the client knows that [target] is [service_1], but must embargo it until + it knows that "M-1" has been delivered. *) + let m2 = call target "M-2" [] in + C.handle_msg c ~expect:"call:M-1"; (* Pipelined call arrives back *) + C.handle_msg c ~expect:"return:take-from-other"; (* Return for M-1 *) + C.handle_msg c ~expect:"disembargo-reply"; (* Disembargo of [bs]. *) + S.handle_msg s ~expect:"finish"; (* Bootstrap *) + S.handle_msg s ~expect:"return:sent-elsewhere"; (* For forwarded q1 *) + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"release"; + C.handle_msg c ~expect:"disembargo-reply"; + let am1 = service_1#pop0 "M-1" in + let am2 = service_1#pop0 "M-2" in + resolve_ok am1 "am1" []; + resolve_ok am2 "am2" []; + dec_ref q1; + dec_ref m1; + dec_ref m2; + dec_ref target; + dec_ref bs; + dec_ref proxy_to_echo; + dec_ref service_1; + CS.flush c s; + CS.check_finished c s + +let test_local_embargo_11 () = + let client_bs = Services.manual () in + let server_bs = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags ~client_bs + ~server_tags:Test_utils.server_tags server_bs + in + let to_server_bs = C.bootstrap c in + let to_client_bs = S.bootstrap s in + CS.flush c s; + let q1 = call_for_cap to_server_bs "q1" [] in + let to_server_bs_2 = C.bootstrap c in + let q2 = call_for_cap to_client_bs "q2" [] in + S.handle_msg s ~expect:"call:q1"; + resolve_ok (server_bs#pop0 "q1") "a1" [with_inc_ref q2]; + let q3 = call q1 "q3" [] in + C.handle_msg c ~expect:"call:q2"; + resolve_ok (client_bs#pop0 "q2") "a2" [with_inc_ref to_server_bs_2]; + S.handle_msg s ~expect:"bootstrap"; + (* Client gets a1, resolving q1 to the already-answered q2's cap 0. + As q3 was pipelined over q1 and q2's cap 0 is currently a remote-promise + (q2), it embargoes q1. *) + C.handle_msg c ~expect:"return:a1"; + (* to_server_bs_2 resolves. No embargo is needed: *) + C.handle_msg c ~expect:"return:(boot)"; + S.handle_msg s ~expect:"call:q3"; (* Pipelined q3 arrives, forwarded to q2 *) + C.handle_msg c ~expect:"call:q3"; (* q3 back at client, sent to bootstrap call *) + C.handle_msg c ~expect:"return:take-from-other"; (* use forwarded call for answer to q3 *) + S.handle_msg s ~expect:"return:a2"; (* q2 = server_bs, embargoed due to q3 forwarding *) + (* note: probably shouldn't mark paths as dirty when just forwarding, but should still work *) + C.handle_msg c ~expect:"disembargo-request"; + S.handle_msg s ~expect:"disembargo-request"; + C.handle_msg c ~expect:"disembargo-reply"; (* Second embargo not needed, as remote *) + dec_ref to_server_bs; + dec_ref to_server_bs_2; + dec_ref to_client_bs; + dec_ref q1; + dec_ref q2; + dec_ref q3; + CS.flush c s; + CS.check_finished c s + +let test_local_embargo_12 () = + let server_bs = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:server_bs in + (* Client calls [bs], passing a local promise as the argument. *) + let x, xr = Local_struct_promise.make () in (* x will become broken *) + let x0 = x#cap 0 in + let q1 = call bs "q1" [x0] in + (* Client resolves local promise to the (about to fail) promise q1:2 *) + resolve_ok xr "x" [with_inc_ref (q1#cap 2)]; + (* Client pipelines q2 over q1:0 *) + let q2 = call (q1#cap 0) "q2" [] in + (* Server handles q1. The result is a promise for the result of a call to q1:2, + which will fail. *) + S.handle_msg s ~expect:"call:q1"; + let to_x0, a1 = server_bs#pop1 "q1" in + let y = call_for_cap to_x0 "q3" [] in + resolve_ok a1 "a1" [y]; + C.handle_msg c ~expect:"call:q3"; (* q3 arrives at client and is forwarded to q1 (to=yourself) *) + S.handle_msg s ~expect:"resolve"; (* [to_x0 = q3#2]. *) + C.handle_msg c ~expect:"return:a1"; (* [q1 = q3#0] *) + (* Client has pipelined over q1, so embargoes it. *) + S.handle_msg s ~expect:"call:q2"; (* Server forwards q2 back along q3, replies with take-from-other(q4) *) + C.handle_msg c ~expect:"release"; (* Server will use q3 instead of i0 for to_x0 *) + C.handle_msg c ~expect:"call:q2"; (* Client forwards q2 to q1#2 *) + S.handle_msg s ~expect:"call:q3"; (* q3 arrives at a1#2, which doesn't exist *) + (* Server replies with results-sent-elsewhere. Is this correct? It's really an error. *) + C.handle_msg c ~expect:"return:take-from-other"; (* Take from q2=q4 *) + CS.dump c s; + S.handle_msg s ~expect:"return:take-from-other"; (* Take from broken answer *) + C.handle_msg c ~expect:"return:sent-elsewhere"; + S.handle_msg s ~expect:"disembargo-request"; (* Client wants to clear q1 to disembargo x *) + C.handle_msg c ~expect:"disembargo-reply"; + (* As [x] is now broken, no further disembargoes should be sent. *) + dec_ref q1; + dec_ref q2; + dec_ref bs; + dec_ref x; + dec_ref x0; + dec_ref to_x0; + CS.flush c s; + CS.check_finished c s + +let test_local_embargo_13 () = + let client_bs = Services.manual () in + let server_bs = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags ~client_bs + ~server_tags:Test_utils.server_tags server_bs + in + let to_client = S.bootstrap s in + let to_server = C.bootstrap c in + CS.flush c s; + let broken = Core_types.broken_cap (Capnp_rpc_proto.Exception.v "broken") in (* (at server) *) + (* Server calls client, passing a broken cap. + Due to a protocol limitation, we first send this as an export and then break it. *) + let q1 = call_for_cap to_client "q1" [broken] in + (* The client calls the server, and pipelines over the result *) + let q2 = call_for_cap to_server "q2" [] in + let q3 = call q2 "q3" [] in + (* Client gets exported (soon to be broken) cap and echoes it back. *) + C.handle_msg c ~expect:"call:q1"; + let to_broken, a1 = client_bs#pop1 "q1" in + resolve_ok a1 "a1" [to_broken]; + (* Server replies to q2 with q1. *) + S.handle_msg s ~expect:"call:q2"; + let a2 = server_bs#pop0 "q2" in + resolve_ok a2 "a2" [q1]; + C.handle_msg c ~expect:"resolve"; (* Client discovers to_broken is broken *) + S.handle_msg s ~expect:"call:q3"; (* Server gets q3, forwards to q1 *) + C.handle_msg c ~expect:"return:a2"; (* Client gets q2 = q1, embargoes due to q3 *) + C.handle_msg c ~expect:"call:q3"; (* Client forwards q3 to broken *) + (* Not sure if we need to forward q3 here, since we know the target is broken. *) + (* When q2 embargo is done, client must not do a second embargo, since q2 is now broken. *) + dec_ref q2; + dec_ref q3; + dec_ref to_server; + dec_ref to_client; + CS.flush c s; + CS.check_finished c s + +let test_local_embargo_14 () = + let client_bs = Services.manual () in (* Bootstrap for vat 0 *) + let server_bs = Services.manual () in (* Bootstrap for vat 1 *) + let c, s = CS.create + ~client_tags:Test_utils.client_tags ~client_bs + ~server_tags:Test_utils.server_tags server_bs + in + let to_server = C.bootstrap c in + let to_client = S.bootstrap s in + CS.flush c s; + let client_via_q1 = call_for_cap to_server "q1" [] in + S.handle_msg s ~expect:"call:q1"; + resolve_ok (server_bs#pop0 "q1") "a1" [to_client]; + let q2 = call client_via_q1 "q2" [] in + let server_via_q2 = q2#cap 0 in + let broken = q2#cap 2 in + C.handle_msg c ~expect:"return:a1"; + (* We sent q2 down q1, so the client will embargo client_via_q1 *) + S.handle_msg s ~expect:"call:q2"; (* Forwards q2 back to client as q2' *) + C.handle_msg c ~expect:"call:q2"; (* client_bs gets q2'. *) + let q3 = call broken "q3" [] in + C.handle_msg c ~expect:"return:take-from-other"; (* Client learns q2 = q2' *) + (* Client embargoes q2, due to q3 *) + let m1 = call server_via_q2 "m1" [] in + Logs.info (fun f -> f "server_via_q2 = %t" server_via_q2#pp); + resolve_ok (client_bs#pop0 "q2") "a2" [to_server]; + Logs.info (fun f -> f "server_via_q2 = %t" server_via_q2#pp); + let m2 = call server_via_q2 "m2" [] in + CS.flush c s; + let _ = server_bs#pop0 "m1" in + let _ = server_bs#pop0 "m2" in + dec_ref client_via_q1; + dec_ref server_via_q2; + dec_ref broken; + dec_ref q2; + dec_ref q3; + dec_ref m1; + dec_ref m2; + CS.flush c s; + CS.check_finished c s + +let test_local_embargo_15 () = + let client_bs = Services.manual () in + let server_bs = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags ~client_bs + ~server_tags:Test_utils.server_tags server_bs + in + let to_server = C.bootstrap c in + let to_client = S.bootstrap s in + let x1 = call_for_cap to_server "q1" [] in + CS.flush c s; + let x2 = call_for_cap to_client "q2" [] in + let x3 = call_for_cap to_client "q3" [] in + CS.flush c s; + resolve_ok (server_bs#pop0 "q1") "reply" [with_inc_ref x3]; + resolve_ok (client_bs#pop0 "q2") "reply" [with_inc_ref x1]; + let m1 = call x2 "m1" [] in + S.handle_msg s ~expect:"return:reply"; (* q2 = x3 *) + let m2 = call x2 "m2" [] in + let local_promise = Cap_proxy.local_promise () in + resolve_ok (client_bs#pop0 "q3") "reply" [with_inc_ref local_promise]; + local_promise#resolve (with_inc_ref to_server); + dec_ref local_promise; + CS.flush c s; + let am1 = server_bs#pop0 "m1" in + let am2 = server_bs#pop0 "m2" in + resolve_ok am1 "am1" []; + resolve_ok am2 "am2" []; + dec_ref m1; + dec_ref m2; + dec_ref x1; + dec_ref x2; + dec_ref x3; + dec_ref to_server; + dec_ref to_client; + CS.flush c s; + CS.check_finished c s + +(* The field must still be useable after the struct is released. *) +let test_fields () = + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags (Services.echo_service ()) in + let f0 = C.bootstrap c in + let q1 = call f0 "c1" [] in + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; (* [bs] resolves *) + S.handle_msg s ~expect:"call:c1"; + S.handle_msg s ~expect:"finish"; + C.handle_msg c ~expect:"return:got:c1"; + Alcotest.(check response_promise) "Echo response" (Some (Ok (Response.v "got:c1"))) q1#response; + dec_ref q1; + let q2 = call f0 "c2" [] in + CS.flush c s; + Alcotest.(check response_promise) "Echo response 2" (Some (Ok (Response.v "got:c2"))) q2#response; + dec_ref q2; + dec_ref f0; + CS.flush c s; + CS.check_finished c s + +let test_cancel () = + let service = Services.manual () in + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags + (service :> Core_types.cap) in + let f0 = C.bootstrap c in + let q1 = call f0 "c1" [] in + let prom = q1#cap 0 in + dec_ref q1; (* Client doesn't cancel q1 because we're using prom *) + let _q2 = call prom "p1" [] in + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; (* [bs] resolves *) + S.handle_msg s ~expect:"call:c1"; + S.handle_msg s ~expect:"call:p1"; + S.handle_msg s ~expect:"finish"; (* bootstrap *) + let a1 = service#pop0 "c1" in + resolve_ok a1 "a1" []; + C.handle_msg c ~expect:"return:Invalid capability index!"; + C.handle_msg c ~expect:"return:a1"; + dec_ref f0; + CS.flush c s; + CS.check_finished c s + +(* Actually sends a cancel *) +let test_cancel_2 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let q1 = call bs "c1" [] in + dec_ref q1; (* Client cancels *) + S.handle_msg s ~expect:"call:c1"; + S.handle_msg s ~expect:"finish"; (* cancel *) + let a1 = service#pop0 "c1" in + let echo = Services.echo_service () in + resolve_ok a1 "a1" [echo]; + C.handle_msg c ~expect:"return:(cancelled)"; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +(* Don't forget to release the returned cap if the question was cancelled. *) +let test_cancel_3 () = + let service = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags + ~server_tags:Test_utils.server_tags service + in + let proxy_to_service = C.bootstrap c in + let q1 = call proxy_to_service "q1" [] in + S.handle_msg s ~expect:"bootstrap"; + S.handle_msg s ~expect:"call:q1"; + resolve_ok (service#pop0 "q1") "reply" [Core_types.null]; + C.handle_msg c ~expect:"return:(boot)"; + dec_ref q1; + C.handle_msg c ~expect:"return:reply"; + dec_ref proxy_to_service; + CS.flush c s; + CS.check_finished c s + +(* Asking for the same field twice gives the same object. *) +let test_duplicates () = + let service = Services.manual () in + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags + (service :> Core_types.cap) in + let f0 = C.bootstrap c in + let q1 = call f0 "c1" [] in + dec_ref f0; + let x1 = q1#cap 0 in + let x2 = q1#cap 0 in + dec_ref q1; + assert (x1 = x2); + dec_ref x1; + dec_ref x2; + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; (* [bs] resolves *) + S.handle_msg s ~expect:"call:c1"; + S.handle_msg s ~expect:"finish"; (* bootstrap question *) + S.handle_msg s ~expect:"release"; (* bootstrap cap *) + let a1 = service#pop0 "c1" in + resolve_ok a1 "a1" []; + C.handle_msg c ~expect:"return:a1"; + S.handle_msg s ~expect:"finish"; (* c1 *) + CS.check_finished c s + +(* Exporting a cap twice reuses the existing export. *) +let test_single_export () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let local = Services.echo_service () in + let q1 = call bs "q1" [local; local] in + let q2 = call bs "q2" [local] in + Alcotest.(check int) "One export" 1 (C.stats c).n_exports; + S.handle_msg s ~expect:"call:q1"; + S.handle_msg s ~expect:"call:q2"; + dec_ref q1; + dec_ref q2; + let ignore msg = + let got, a = service#pop_n msg in + RO_array.iter dec_ref got; + resolve_ok a "a" [] + in + ignore "q1"; + ignore "q2"; + dec_ref local; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +(* Exporting a field of a remote promise sends a promised answer desc. *) +let test_shorten_field () = + let service = Services.manual () in + let logger = Services.logger () in + let c, s, bs = init_pair ~bootstrap_service:service in + let q1 = call bs "q1" [] in + let proxy_to_logger = q1#cap 0 in + let q2 = call bs "q2" [proxy_to_logger] in + S.handle_msg s ~expect:"call:q1"; + let a1 = service#pop0 "q1" in + resolve_ok a1 "a1" [logger]; + S.handle_msg s ~expect:"call:q2"; + let direct_to_logger, a2 = service#pop1 "q2" in + assert (direct_to_logger#shortest = (logger :> Core_types.cap)); + resolve_ok a2 "a2" []; + dec_ref direct_to_logger; + dec_ref bs; + dec_ref proxy_to_logger; + dec_ref q1; + dec_ref q2; + CS.flush c s; + CS.check_finished c s + +let ensure_is_cycle_error (x:#Core_types.struct_ref) : unit = + match x#response with + | Some (Error (`Exception ex)) + when (String.starts_with ~prefix:"Attempt to create a cycle detected:" ex.Exception.reason) -> () + | _ -> Alcotest.fail (Fmt.str "Not a cycle error: %t" x#pp) + +let ensure_is_cycle_error_cap cap = + match cap#problem with + | Some ex when (String.starts_with ~prefix:" () + | _ -> Alcotest.fail (Fmt.str "Not a cycle error: %t" cap#pp) + +let test_cycle () = + (* Cap cycles *) + let module P = Testbed.Capnp_direct.Cap_proxy in + let p1 = P.local_promise () in + let p2 = P.local_promise () in + p1#resolve (p2 :> Core_types.cap); + p2#resolve (p1 :> Core_types.cap); + ensure_is_cycle_error (call p2 "test" []); + (* Connect struct to its own field *) + let p1, p1r = Local_struct_promise.make () in + let c = p1#cap 0 in + inc_ref c; + resolve_ok p1r "msg" [c]; + ensure_is_cycle_error_cap c; + dec_ref c; + dec_ref p1; + (* Connect struct to itself *) + let p1, p1r = Local_struct_promise.make () in + p1r#resolve p1; + ensure_is_cycle_error p1; + dec_ref p1 + +(* Resolve a promise with an answer that includes the result of a pipelined + call on the promise itself. *) +let test_cycle_2 () = + let s1, s1r = Local_struct_promise.make () in + let s2 = call (s1#cap 0) "get-s2" [] in + resolve_ok s1r "a7" [s2#cap 0]; + ensure_is_cycle_error_cap (s1#cap 0); + dec_ref s2; + dec_ref s1 + +(* It's not a cycle if one field resolves to another. *) +let test_cycle_3 () = + let echo = Services.echo_service () in + let a1, a1r = Local_struct_promise.make () in + resolve_ok a1r "a1" [a1#cap 1; (echo :> Core_types.cap)]; + let target = a1#cap 1 in + let q2 = call target "q2" [] in + Alcotest.(check response_promise) "Field 1 OK" + (Some (Ok (Response.v "got:q2"))) + q2#response; + dec_ref q2; + dec_ref target; + dec_ref a1 + +(* Check ref-counting when resolving loops. *) +let test_cycle_4 () = + let echo = Services.echo_service () in + let a1, a1r = Local_struct_promise.make () in + let f0 = a1#cap 0 in + resolve_ok a1r "a1" [a1#cap 1; (echo :> Core_types.cap)]; + dec_ref f0; + dec_ref a1; + Logs.info (fun f -> f "echo = %t" echo#pp); + Alcotest.(check bool) "Echo released" true echo#released + +(* A field depends on the struct. *) +let test_cycle_5 () = + let a, ar = Local_struct_promise.make () in + let b, br = Local_struct_promise.make () in + let c, cr = Local_struct_promise.make () in + Alcotest.(check (result unit reject)) "Not a cycle" (Ok ()) @@ br#set_blocker (c :> Core_types.base_ref); + Alcotest.(check (result unit reject)) "Not a cycle" (Ok ()) @@ cr#set_blocker (a :> Core_types.base_ref); + let b0 = b#cap 0 in + let reply = + Response.v "reply" + |> Core_types.Response_payload.with_caps (RO_array.of_list [b0]) + in + let x = Core_types.return reply in + ar#resolve x; + Logs.info (fun f -> f "a = %t" a#pp); + ensure_is_cycle_error_cap (a#cap 0); + dec_ref a + +(* A blocker depends on itself. *) +let test_cycle_6 () = + let a, ar = Local_struct_promise.make () in + let a0 = a#cap 0 in + a0#call ar (Request.v "loop"); + Logs.info (fun f -> f "a0 = %t" a#pp) + +(* The server returns an answer containing a promise. Later, it resolves the promise + to a resource at the client. The client must be able to invoke the service locally. *) +let test_resolve () = + let service = Services.manual () in + let client_logger = Services.logger () in + let c, s, proxy_to_service = init_pair ~bootstrap_service:service in + (* The client makes a call and gets a reply, but the reply contains a promise. *) + let q1 = call proxy_to_service "q1" [client_logger] in + dec_ref proxy_to_service; + S.handle_msg s ~expect:"call:q1"; + let proxy_to_logger, a1 = service#pop1 "q1" in + let promise = Cap_proxy.local_promise () in + inc_ref promise; + resolve_ok a1 "a1" [promise]; + C.handle_msg c ~expect:"return:a1"; + (* The server now resolves the promise *) + promise#resolve proxy_to_logger; + dec_ref promise; + CS.flush c s; + (* The client can now use the logger directly *) + let x = q1#cap 0 in + let q2 = call x "test-message" [] in + Alcotest.(check string) "Got message directly" "test-message" client_logger#pop; + dec_ref x; + dec_ref q1; + dec_ref q2; + dec_ref client_logger; + CS.flush c s; + CS.check_finished c s + +(* The server resolves an export after the client has released it. + The client releases the new target. *) +let test_resolve_2 () = + let service = Services.manual () in + let client_logger = Services.logger () in + let c, s, proxy_to_service = init_pair ~bootstrap_service:service in + (* The client makes a call and gets a reply, but the reply contains a promise. *) + let q1 = call proxy_to_service "q1" [client_logger] in + dec_ref client_logger; + dec_ref proxy_to_service; + S.handle_msg s ~expect:"call:q1"; + let proxy_to_logger, a1 = service#pop1 "q1" in + let promise = Cap_proxy.local_promise () in + resolve_ok a1 "a1" [promise]; + C.handle_msg c ~expect:"return:a1"; + (* The client doesn't care about the result and releases it *) + dec_ref q1; + (* The server now resolves the promise. The client must release the new target. *) + promise#resolve proxy_to_logger; + CS.flush c s; + CS.check_finished c s + +(* The server returns a promise, but by the time it resolves the server + has removed the export. It must not send a resolve message. *) +let test_resolve_3 () = + let service = Services.manual () in + let c, s, proxy_to_service = init_pair ~bootstrap_service:service in + (* Make a call, get a promise, and release it *) + let q1 = call proxy_to_service "q1" [] in + S.handle_msg s ~expect:"call:q1"; + let a1 = service#pop0 "q1" in + let a1_promise = Cap_proxy.local_promise () in + inc_ref a1_promise; + resolve_ok a1 "a1" [a1_promise]; + C.handle_msg c ~expect:"return:a1"; + dec_ref q1; + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"release"; + (* Make another call, get a settled export this time. *) + let q2 = call proxy_to_service "q2" [] in + S.handle_msg s ~expect:"call:q2"; + CS.flush c s; + let a2 = service#pop0 "q2" in + let echo = Services.echo_service () in + inc_ref echo; + resolve_ok a2 "a2" [echo]; + C.handle_msg c ~expect:"return:a2"; + (* Service now resolves first answer *) + a1_promise#resolve (echo :> Core_types.cap); + dec_ref a1_promise; + dec_ref proxy_to_service; + CS.flush c s; + dec_ref q2; + CS.flush c s; + CS.check_finished c s + +(* Resolving a remote's export to another export, which we haven't seen yet. + We must add the new import to the table before looking it up to set the + disembargo target. *) +let test_resolve_4 () = + let service = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags + ~server_tags:Test_utils.server_tags service + in + let to_server = C.bootstrap c in + let x = Cap_proxy.local_promise () in + let q1 = call to_server "q1" [x] in + x#resolve (Services.manual () :> Core_types.cap); + CS.flush c s; + let to_x, a1 = service#pop1 "q1" in + resolve_ok a1 "a1" []; + dec_ref to_x; + dec_ref q1; + dec_ref x; + dec_ref to_server; + CS.flush c s; + CS.check_finished c s + +(* Finishing a question releases multiple imports *) +let test_resolve_5 () = + let service = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags + ~server_tags:Test_utils.server_tags service + in + let promise = Cap_proxy.local_promise () in + let to_service = C.bootstrap c in + let q1 = call to_service "q1" [promise] in + S.handle_msg s ~expect:"bootstrap"; + S.handle_msg s ~expect:"call:q1"; + let to_promise, a1 = service#pop1 "q1" in + resolve_ok a1 "a1" [to_promise]; + C.handle_msg c ~expect:"return:(boot)"; + promise#resolve (Services.manual () :> Core_types.cap); + C.handle_msg c ~expect:"return:a1"; + S.handle_msg s ~expect:"finish"; (* Bootstrap *) + S.handle_msg s ~expect:"resolve"; + S.handle_msg s ~expect:"finish"; + dec_ref q1; + dec_ref to_service; + dec_ref promise; + CS.flush c s; + CS.check_finished c s + +(* When a proxy is released it must be removed from the import, + which may need to hang around for forwarding. *) +let test_resolve_6 () = + let client_bs = Services.manual () in + let server_bs = Services.manual () in + let c, s = CS.create + ~client_tags:Test_utils.client_tags ~client_bs + ~server_tags:Test_utils.server_tags server_bs + in + let to_server = C.bootstrap c in + let to_client = S.bootstrap s in + CS.flush c s; + let x = call_for_cap to_server "q1" [] in + let y = call_for_cap to_client "q2" [] in + S.handle_msg s ~expect:"call:q1"; + resolve_ok (server_bs#pop0 "q1") "a1" [to_client; Core_types.null]; + C.handle_msg c ~expect:"call:q2"; + resolve_ok (client_bs#pop0 "q2") "a2" [x]; + C.handle_msg c ~expect:"return:a1"; + C.handle_msg c ~expect:"resolve"; + S.handle_msg s ~expect:"return:a2"; + C.handle_msg c ~expect:"finish"; + S.handle_msg s ~expect:"finish"; + S.handle_msg s ~expect:"release"; + dec_ref y; + dec_ref to_server; + CS.flush c s; + CS.check_finished c s + +let test_resolve_7 () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let promise, resolver = Local_struct_promise.make () in + let bs_promise = promise#cap 0 in (* Local promise *) + let x1 = call_for_cap bs_promise "q1" [] in (* Never resolves *) + let x2 = call_for_cap bs_promise "q2" [] in (* Will resolve to null *) + let q3 = call x1 "q3" [x2] in + let q4 = call bs "q4" [x2] in + (* Resolving [bs_promise] to [bs] sends q1, q3 and q2 over the network. + [x2] is marked as blocked on [bs_promise], but [bs_promise] is no longer blocked. + Must not misinterpret this as [x2] being sender-hosted (not blocked on anything)! *) + resolve_ok resolver "reply" [bs]; + Logs.info (fun f -> f "bs=%t" bs#pp); + S.handle_msg s ~expect:"call:q4"; + let to_x2, a4 = service#pop1 "q4" in + dec_ref to_x2; + CS.flush c s; + let a1 = service#pop0 "q1" in + let a2 = service#pop0 "q2" in + resolve_ok a2 "reply" [Core_types.null]; + CS.dump c s; + CS.flush c s; + (* Clean up *) + resolve_ok a1 "a1" []; + resolve_ok a4 "a4" []; + dec_ref x1; + dec_ref x2; + dec_ref q3; + dec_ref q4; + dec_ref bs_promise; + dec_ref promise; + CS.flush c s; + CS.check_finished c s + +(* Returning an already-broken capability. *) +let test_broken_return () = + let err = Exception.v "Broken" in + let broken = Core_types.broken_cap err in + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags broken in + let bs = C.bootstrap c in + Alcotest.check (Alcotest.option exn) "Initially a promise" None bs#problem; + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; + C.handle_msg c ~expect:"resolve"; + S.handle_msg s ~expect:"finish"; + Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) bs#problem; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +let test_broken_call () = + let err = Exception.v "Broken" in + let broken = Core_types.broken_cap err in + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let q1 = call bs "q1" [broken] in + S.handle_msg s ~expect:"call:q1"; + let broken_proxy, a1 = service#pop1 "q1" in + Alcotest.check (Alcotest.option exn) "Initially a promise" None broken_proxy#problem; + S.handle_msg s ~expect:"resolve"; + Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) broken_proxy#problem; + resolve_ok a1 "a1" []; + dec_ref broken_proxy; + dec_ref bs; + dec_ref q1; + CS.flush c s; + CS.check_finished c s + +(* Server returns a capability reference that later breaks. *) +let test_broken_later () = + let err = Exception.v "Broken" in + let broken = Core_types.broken_cap err in + let promise = Cap_proxy.local_promise () in + let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags promise in + let bs = C.bootstrap c in + Alcotest.check (Alcotest.option exn) "Initially a promise" None bs#problem; + S.handle_msg s ~expect:"bootstrap"; + C.handle_msg c ~expect:"return:(boot)"; + S.handle_msg s ~expect:"finish"; + (* Server breaks promise *) + promise#resolve broken; + C.handle_msg c ~expect:"resolve"; + Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) bs#problem; + dec_ref bs; + CS.flush c s; + CS.check_finished c s + +let test_broken_connection () = + let service = Services.echo_service () in + let c, s, bs = init_pair ~bootstrap_service:service in + let q1 = call bs "Message-1" [] in + CS.flush c s; + Alcotest.check response_promise "Echo reply" + (Some (Ok (Response.v "got:Message-1"))) + q1#response; + dec_ref q1; + let err = Exception.v "Connection lost" in + C.disconnect c err; + S.disconnect s err; + Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) bs#problem; + dec_ref bs + +let test_ref_counts () = + let objects = Hashtbl.create 3 in + let make () = + let o = object (self) + inherit Core_types.service + val id = Capnp_rpc_proto.Debug.OID.next () + method call results _ = Core_types.resolve_ok results (Response.v "answer") + method! private release = Hashtbl.remove objects self + method! pp f = Fmt.pf f "Service(%a, %t)" Capnp_rpc_proto.Debug.OID.pp id self#pp_refcount + end in + Hashtbl.add objects o true; + o + in + (* Test structs and fields *) + let promise, resolver = Local_struct_promise.make () in + let f0 = promise#cap 0 in + f0#when_more_resolved dec_ref; + let fields = [f0; promise#cap 1] in + resolve_ok resolver "ok" [make (); make ()]; + let fields2 = [promise#cap 0; promise#cap 2] in + dec_ref promise; + List.iter dec_ref fields; + List.iter dec_ref fields2; + Alcotest.(check int) "Fields released" 0 (Hashtbl.length objects); + (* With pipelining *) + let promise, resolver = Local_struct_promise.make () in + let f0 = promise#cap 0 in + let q1 = call f0 "q1" [] in + f0#when_more_resolved dec_ref; + resolve_ok resolver "ok" [make ()]; + dec_ref f0; + dec_ref promise; + dec_ref q1; + Alcotest.(check int) "Fields released" 0 (Hashtbl.length objects); + (* Test local promise *) + let promise = Cap_proxy.local_promise () in + promise#when_more_resolved dec_ref; + promise#resolve (make ()); + dec_ref promise; + Alcotest.(check int) "Local promise released" 0 (Hashtbl.length objects); + Gc.full_major () + +module Level0 = struct + (* Client is level 0, server is level 1. + We don't have a level 0 implementation, so we'll do it manually. + Luckily, level 0 is very easy. *) + + type t = { + from_server : [S.EP.Out.t | `Unimplemented of S.EP.In.t] Queue.t; + to_server : [S.EP.In.t | `Unimplemented of S.EP.Out.t] Queue.t; + } + + let send t m = Queue.add m t.to_server + + let qid_of_int x = S.EP.In.QuestionId.of_uint32 (Stdint.Uint32.of_int x) + + let init ~bootstrap = + let from_server = Queue.create () in + let to_server = Queue.create () in + let c = { from_server; to_server } in + let s = S.create ~tags:Test_utils.server_tags from_server to_server ~bootstrap in + send c @@ `Bootstrap (qid_of_int 0, ""); + S.handle_msg s ~expect:"bootstrap"; + send c @@ `Finish (qid_of_int 0, false); + S.handle_msg s ~expect:"finish"; + let bs = + match Queue.pop from_server with + | `Return (_, `Results (_, caps), false) -> + begin match RO_array.get_exn caps 0 with + | `SenderHosted id -> id + | _ -> assert false + end + | _ -> assert false + in + c, s, bs + + let expect t expected = + match Queue.pop t.from_server with + | msg -> Alcotest.(check string) "Read message from server" expected (Testbed.Connection.summary_of_msg msg) + | exception Queue.Empty -> Alcotest.fail "No messages found!" + + let expect_bs t = + let bs_request = Queue.pop t.from_server in + match bs_request with + | `Bootstrap (qid, "") -> qid + | _ -> Alcotest.fail (Fmt.str "Expecting bootstrap, got %s" (Testbed.Connection.summary_of_msg bs_request)) + + let expect_call t expected = + match Queue.pop t.from_server with + | `Call (qid, _, msg, _, _) -> + Alcotest.(check string) "Get call" expected @@ Request.data msg; + qid + | request -> Alcotest.fail (Fmt.str "Expecting call, got %s" (Testbed.Connection.summary_of_msg request)) + + let call t target ~qid msg = + send t @@ `Call (qid_of_int qid, `ReceiverHosted target, Request.v msg, RO_array.empty, `Caller) + + let finish t ~qid = + send t @@ `Finish (qid_of_int qid, true) +end + +(* Pretend that the peer only supports level 0, and therefore + sets the auto-release flags. *) +let test_auto_release () = + let service = Services.manual () in + let c, s, bs = Level0.init ~bootstrap:service in + let send = Level0.send c in + (* Client makes a call. *) + Level0.call c ~qid:0 bs "q0"; + S.handle_msg s ~expect:"call:q0"; + (* Server replies with some caps, which the client doesn't understand. *) + let a0 = service#pop0 "q0" in + let echo_service = Services.echo_service () in + resolve_ok a0 "a0" [echo_service]; + Level0.expect c "return:a0"; + (* Client asks it to drop all caps *) + Level0.finish c ~qid:0; + S.handle_msg s ~expect:"finish"; + Alcotest.(check bool) "Echo released" true echo_service#released; + (* Now test the other direction. Service invokes bootstap on client. *) + let proxy_to_client = S.bootstrap s in + let logger = Services.logger () in + let q1 = call proxy_to_client "q1" [logger] in + dec_ref logger; + let bs_qid = Level0.expect_bs c in + let client_bs_id = S.EP.In.ExportId.zero in + send @@ `Return (bs_qid, `Results (Response.v "bs", RO_array.of_list [`SenderHosted client_bs_id]), true); + let q1_qid = Level0.expect_call c "q1" in + send @@ `Return (q1_qid, `Results (Response.v "a1", RO_array.empty), true); + S.handle_msg s ~expect:"return:bs"; + S.handle_msg s ~expect:"return:a1"; + Alcotest.(check bool) "Logger released" true logger#released; + dec_ref proxy_to_client; + (* Clean up. + A real level-0 client would just disconnect, but release cleanly so we can + check nothing else was leaked. *) + dec_ref q1; + send @@ `Release (S.EP.Out.ExportId.zero, 1); + S.handle_msg s ~expect:"release"; + try S.check_finished s ~name:"Server" + with ex -> + Logs.err (fun f -> f "Error: %a@\n%a" Fmt.exn ex S.dump s); + raise ex + +(* We send a resolve to a level 0 implementation, which echoes it back as + "unimplemented". We release the cap. *) +let test_unimplemented () = + let service = Services.manual () in + let c, s, bs = Level0.init ~bootstrap:service in + (* The client makes a call on [service] and gets back a promise. *) + Level0.call c ~qid:0 bs "q0"; + S.handle_msg s ~expect:"call:q0"; + let a0 = service#pop0 "q0" in + let promise = Cap_proxy.local_promise () in + inc_ref promise; + resolve_ok a0 "a0" [promise]; + (* The server resolves the promise *) + let echo_service = Services.echo_service () in + promise#resolve (echo_service :> Core_types.cap); + dec_ref promise; + (* The client doesn't understand the resolve message. *) + Level0.expect c "return:a0"; + Level0.finish c ~qid:0; + S.handle_msg s ~expect:"finish"; + let resolve = + match Queue.pop c.from_server with + | `Resolve _ as r -> r + | _ -> assert false + in + Level0.send c @@ `Unimplemented resolve; + S.handle_msg s ~expect:"unimplemented"; + (* The server releases the export. *) + Alcotest.(check bool) "Echo released" true echo_service#released; + (* The server tries to get the client's bootstrap object *) + let bs = S.bootstrap s in + let q2 = call bs "q2" [] in + (* The client doesn't support bootstrap or call *) + let bs_msg = + match Queue.pop c.from_server with + | `Bootstrap _ as bs -> bs + | _ -> assert false + in + Level0.send c @@ `Unimplemented bs_msg; + let call_msg = + match Queue.pop c.from_server with + | `Call _ as call -> call + | _ -> assert false + in + Level0.send c @@ `Unimplemented call_msg; + S.handle_msg s ~expect:"unimplemented"; + S.handle_msg s ~expect:"unimplemented"; + dec_ref bs; + Alcotest.(check response_promise) "Server got error" + (Some (Error (Error.exn ~ty:`Unimplemented "Call message not implemented by peer!"))) + q2#response; + dec_ref q2; + (* Clean up. + A real level-0 client would just disconnect, but release cleanly so we can + check nothing else was leaked. *) + Level0.send c @@ `Release (S.EP.Out.ExportId.zero, 1); + S.handle_msg s ~expect:"release"; + try S.check_finished s ~name:"Server" + with ex -> + Logs.err (fun f -> f "Error: %a@\n%a" Fmt.exn ex S.dump s); + raise ex + +(* The client's only reference to an import is a callback on the import itself. + The import must not be released, even though the leak detector would normally + do that. *) +let test_import_callbacks () = + let service = Services.manual () in + let c, s, bs = init_pair ~bootstrap_service:service in + let q1 = call bs "q1" [] in + S.handle_msg s ~expect:"call:q1"; + let a1 = service#pop0 "q1" in + let promise = Cap_proxy.local_promise () in + resolve_ok a1 "a1" [promise]; + C.handle_msg c ~expect:"return:a1"; + let ok = + let r = ref "-" in + let f1 = q1#cap 0 in + f1#when_more_resolved (fun x -> + r := "resolved"; + dec_ref x; + dec_ref f1 + ); + r + in + dec_ref q1; + Gc.full_major (); + promise#resolve (Core_types.broken_cap (Capnp_rpc_proto.Exception.v "broken")); + CS.flush c s; + dec_ref bs; + Alcotest.(check string) "ok set" "resolved" !ok; + CS.flush c s; + CS.check_finished c s + +let tests = [ + "Return", `Quick, test_return; + "Return error", `Quick, test_return_error; + "Connection", `Quick, test_simple_connection; + "Local embargo", `Quick, test_local_embargo; + "Local embargo 2", `Quick, test_local_embargo_2; + "Local embargo 3", `Quick, test_local_embargo_3; + "Local embargo 4", `Quick, test_local_embargo_4; + "Local embargo 5", `Quick, test_local_embargo_5; + "Local embargo 6", `Quick, test_local_embargo_6; + "Local embargo 7", `Quick, test_local_embargo_7; + "Local embargo 8", `Quick, test_local_embargo_8; + "Local embargo 9", `Quick, _test_local_embargo_9; + "Local embargo 10", `Quick, test_local_embargo_10; + "Local embargo 11", `Quick, test_local_embargo_11; + "Local embargo 12", `Quick, test_local_embargo_12; + "Local embargo 13", `Quick, test_local_embargo_13; + "Local embargo 14", `Quick, test_local_embargo_14; + "Local embargo 15", `Quick, test_local_embargo_15; + "Shared cap", `Quick, test_share_cap; + "Fields", `Quick, test_fields; + "Cancel", `Quick, test_cancel; + "Cancel 2", `Quick, test_cancel_2; + "Cancel 3", `Quick, test_cancel_3; + "Duplicates", `Quick, test_duplicates; + "Re-export", `Quick, test_single_export; + "Shorten field", `Quick, test_shorten_field; + "Cycle", `Quick, test_cycle; + "Cycle 2", `Quick, test_cycle_2; + "Cycle 3", `Quick, test_cycle_3; + "Cycle 4", `Quick, test_cycle_4; + "Cycle 5", `Quick, test_cycle_5; + "Cycle 6", `Quick, test_cycle_6; + "Resolve", `Quick, test_resolve; + "Resolve 2", `Quick, test_resolve_2; + "Resolve 3", `Quick, test_resolve_3; + "Resolve 4", `Quick, test_resolve_4; + "Resolve 5", `Quick, test_resolve_5; + "Resolve 6", `Quick, test_resolve_6; + "Resolve 7", `Quick, test_resolve_7; + "Ref-counts", `Quick, test_ref_counts; + "Auto-release", `Quick, test_auto_release; + "Unimplemented", `Quick, test_unimplemented; + "Broken return", `Quick, test_broken_return; + "Broken call", `Quick, test_broken_call; + "Broken later", `Quick, test_broken_later; + "Broken connection", `Quick, test_broken_connection; + "Import callbacks", `Quick, test_import_callbacks; +] |> List.map (fun (name, speed, test) -> + name, speed, (fun () -> + Testbed.Capnp_direct.ref_leaks := 0; + test (); + Gc.full_major (); + if !Testbed.Capnp_direct.ref_leaks > 0 then ( + Alcotest.fail "Reference leaks detected!"; + ) + ) + ) + +let () = + Printexc.record_backtrace true; + Alcotest.run ~and_exit:false "capnp-rpc" [ + "core", tests; + ] diff --git a/test/test.mli b/test/proto/test.mli similarity index 100% rename from test/test.mli rename to test/proto/test.mli diff --git a/test/testbed/capnp_direct.ml b/test/proto/testbed/capnp_direct.ml similarity index 72% rename from test/testbed/capnp_direct.ml rename to test/proto/testbed/capnp_direct.ml index 40a446e47..9539530a7 100644 --- a/test/testbed/capnp_direct.ml +++ b/test/proto/testbed/capnp_direct.ml @@ -17,7 +17,7 @@ module String_content = struct type response = request type 'a msg = { data : string; - caps : Capnp_rpc.S.attachments; + caps : Capnp_rpc_proto.S.attachments; } module Request = struct @@ -30,7 +30,7 @@ module String_content = struct let v data = { data; - caps = Capnp_rpc.S.No_attachments; + caps = Capnp_rpc_proto.S.No_attachments; } let data t = t.data @@ -42,12 +42,12 @@ module String_content = struct module Response = Request - let ref_leak_detected fn = + let ref_leak_detected _ fn = fn (); incr ref_leaks end -module Core_types = Capnp_rpc.Core_types(String_content) +module Core_types = Capnp_rpc_proto.Core_types(String_content) module Network_types = struct type provision_id @@ -56,9 +56,9 @@ module Network_types = struct type join_key_part end -module type ENDPOINT = Capnp_rpc.Message_types.ENDPOINT with +module type ENDPOINT = Capnp_rpc_proto.Message_types.ENDPOINT with module Core_types = Core_types and module Network_types = Network_types -module Local_struct_promise = Capnp_rpc.Local_struct_promise.Make(Core_types) -module Cap_proxy = Capnp_rpc.Cap_proxy.Make(Core_types) +module Local_struct_promise = Capnp_rpc_proto.Local_struct_promise.Make(Core_types) +module Cap_proxy = Capnp_rpc_proto.Cap_proxy.Make(Core_types) diff --git a/test/testbed/connection.ml b/test/proto/testbed/connection.ml similarity index 85% rename from test/testbed/connection.ml rename to test/proto/testbed/connection.ml index d52e2f6cc..f161c3df8 100644 --- a/test/testbed/connection.ml +++ b/test/proto/testbed/connection.ml @@ -1,11 +1,11 @@ -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array module Request = Capnp_direct.String_content.Request module Response = Capnp_direct.String_content.Response let src = Logs.Src.create "test-net" ~doc:"Cap'n Proto RPC tests" module Log = (val Logs.src_log src: Logs.LOG) -module Stats = Capnp_rpc.Stats +module Stats = Capnp_rpc_proto.Stats let stats_t = Alcotest.of_pp Stats.pp let summary_of_msg = function @@ -13,7 +13,7 @@ let summary_of_msg = function | `Bootstrap _ -> "bootstrap" | `Call (_, _, msg, _, _) -> "call:" ^ (Request.data msg) | `Return (_, `Results (msg, _), _) -> "return:" ^ (Response.data msg) - | `Return (_, `Exception ex, _) -> "return:" ^ ex.Capnp_rpc.Exception.reason + | `Return (_, `Exception ex, _) -> "return:" ^ ex.Capnp_rpc_proto.Exception.reason | `Return (_, `Cancelled, _) -> "return:(cancelled)" | `Return (_, `AcceptFromThirdParty, _) -> "return:accept" | `Return (_, `ResultsSentElsewhere, _) -> "return:sent-elsewhere" @@ -47,15 +47,15 @@ module type ENDPOINT = sig val bootstrap : t -> cap - val stats : t -> Capnp_rpc.Stats.t + val stats : t -> Capnp_rpc_proto.Stats.t val check_invariants : t -> unit val check_finished : t -> name:string -> unit - val disconnect : t -> Capnp_rpc.Exception.t -> unit + val disconnect : t -> Capnp_rpc_proto.Exception.t -> unit end module Endpoint (EP : Capnp_direct.ENDPOINT) = struct - module Conn = Capnp_rpc.CapTP.Make(EP) + module Conn = Capnp_rpc_proto.CapTP.Make(EP) type t = { conn : Conn.t; @@ -78,16 +78,18 @@ module Endpoint (EP : Capnp_direct.ENDPOINT) = struct | None -> None | Some bootstrap -> Some (fun k -> function | "" -> Capnp_direct.Core_types.inc_ref bootstrap; k @@ Ok bootstrap - | _ -> k @@ Error (Capnp_rpc.Exception.v "Only a main interface is available") + | _ -> k @@ Error (Capnp_rpc_proto.Exception.v "Only a main interface is available") ) + let fork fn = fn () + let create ?bootstrap ~tags (xmit_queue:[EP.Out.t | `Unimplemented of EP.In.t] Queue.t) (recv_queue:[EP.In.t | `Unimplemented of EP.Out.t] Queue.t) = let queue_send x = Queue.add (x :> [EP.Out.t | `Unimplemented of EP.In.t]) xmit_queue in let bootstrap = (bootstrap :> EP.Core_types.cap option) in let restore = restore_single bootstrap in - let conn = Conn.create ?restore ~tags ~queue_send in + let conn = Conn.create ?restore ~tags ~queue_send ~fork in { conn; recv_queue; @@ -117,7 +119,7 @@ module Endpoint (EP : Capnp_direct.ENDPOINT) = struct pop_msg ?expect t |> Conn.handle_msg t.conn; Conn.check t.conn with ex -> - Logs.err (fun f -> f ~tags:(Conn.tags t.conn) "@[%a:@,%a@]" Capnp_rpc.Debug.pp_exn ex Conn.dump t.conn); + Logs.err (fun f -> f ~tags:(Conn.tags t.conn) "@[%a:@,%a@]" Capnp_rpc_proto.Debug.pp_exn ex Conn.dump t.conn); raise ex let maybe_handle_msg t = @@ -131,7 +133,7 @@ module Endpoint (EP : Capnp_direct.ENDPOINT) = struct let stats t = Conn.stats t.conn - let finished = Capnp_rpc.Exception.v "Tests finished" + let finished = Capnp_rpc_proto.Exception.v "Tests finished" let check_invariants t = Conn.check t.conn @@ -149,12 +151,12 @@ module Endpoint (EP : Capnp_direct.ENDPOINT) = struct end module Pair ( ) = struct - module Table_types = Capnp_rpc.Message_types.Table_types ( ) - module ProtoC = Capnp_rpc.Message_types.Endpoint(Capnp_direct.Core_types)(Capnp_direct.Network_types)(Table_types) + module Table_types = Capnp_rpc_proto.Message_types.Table_types ( ) + module ProtoC = Capnp_rpc_proto.Message_types.Endpoint(Capnp_direct.Core_types)(Capnp_direct.Network_types)(Table_types) module ProtoS = struct module Core_types = Capnp_direct.Core_types module Network_types = Capnp_direct.Network_types - module Table = Capnp_rpc.Message_types.Flip(ProtoC.Table) + module Table = Capnp_rpc_proto.Message_types.Flip(ProtoC.Table) module In = ProtoC.Out module Out = ProtoC.In end diff --git a/test/testbed/connection.mli b/test/proto/testbed/connection.mli similarity index 86% rename from test/testbed/connection.mli rename to test/proto/testbed/connection.mli index 4da5a04ed..5a8c4c7dc 100644 --- a/test/testbed/connection.mli +++ b/test/proto/testbed/connection.mli @@ -14,7 +14,7 @@ val summary_of_msg : _ * [< `AcceptFromThirdParty | `Cancelled - | `Exception of Capnp_rpc.Exception.t + | `Exception of Capnp_rpc_proto.Exception.t | `Results of Response.t * _ | `ResultsSentElsewhere | `TakeFromOtherQuestion of _] * @@ -42,16 +42,16 @@ module type ENDPOINT = sig val bootstrap : t -> cap - val stats : t -> Capnp_rpc.Stats.t + val stats : t -> Capnp_rpc_proto.Stats.t val check_invariants : t -> unit val check_finished : t -> name:string -> unit - val disconnect : t -> Capnp_rpc.Exception.t -> unit + val disconnect : t -> Capnp_rpc_proto.Exception.t -> unit end -module Endpoint (EP : Capnp_direct.ENDPOINT) : ENDPOINT +module Endpoint : Capnp_direct.ENDPOINT -> ENDPOINT module Pair ( ) : sig module C : ENDPOINT diff --git a/test/proto/testbed/dune b/test/proto/testbed/dune new file mode 100644 index 000000000..0127df9a1 --- /dev/null +++ b/test/proto/testbed/dune @@ -0,0 +1,3 @@ +(library + (name testbed) + (libraries astring fmt logs logs.fmt capnp-rpc.proto alcotest)) diff --git a/test/testbed/services.ml b/test/proto/testbed/services.ml similarity index 91% rename from test/testbed/services.ml rename to test/proto/testbed/services.ml index 6ec671555..c741f604c 100644 --- a/test/testbed/services.ml +++ b/test/proto/testbed/services.ml @@ -2,14 +2,14 @@ open Capnp_direct.Core_types module Msg = Capnp_direct.String_content -module RO_array = Capnp_rpc.RO_array +module RO_array = Capnp_rpc_proto.RO_array class virtual test_service = object inherit service as super val mutable released = false val virtual name : string - val id = Capnp_rpc.Debug.OID.next () + val id = Capnp_rpc_proto.Debug.OID.next () method released = released method! release = assert (not released); released <- true; @@ -17,7 +17,7 @@ class virtual test_service = object method! pp f = Fmt.pf f "%s(%a, %t)" name - Capnp_rpc.Debug.OID.pp id + Capnp_rpc_proto.Debug.OID.pp id super#pp_refcount end @@ -41,7 +41,7 @@ let manual () = object (self) method pop_n msg = match Queue.pop queue with - | exception Queue.Empty -> Capnp_rpc.Debug.failf "Empty queue (expecting %S)" msg + | exception Queue.Empty -> Fmt.failwith "Empty queue (expecting %S)" msg | actual, answer -> Alcotest.(check string) ("Expecting " ^ msg) msg actual.Msg.data; let args = Request_payload.snapshot_caps actual in diff --git a/test/testbed/test_utils.ml b/test/proto/testbed/test_utils.ml similarity index 95% rename from test/testbed/test_utils.ml rename to test/proto/testbed/test_utils.ml index c176a4c74..abea146e8 100644 --- a/test/testbed/test_utils.ml +++ b/test/proto/testbed/test_utils.ml @@ -27,7 +27,7 @@ let reporter = | None -> unknown in let peer = Logs.Tag.find peer_tag tags in - let qid = Logs.Tag.find Capnp_rpc.Debug.qid_tag tags in + let qid = Logs.Tag.find Capnp_rpc_proto.Debug.qid_tag tags in let print _ = Fmt.(pf stdout) "%a@." pp_qid qid; over (); diff --git a/test/test.ml b/test/test.ml index 1786f6491..d26cb7ee3 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,1614 +1,803 @@ -open Astring +open Eio.Std +open Testlib +open Capnp_rpc.Std +open Capnp_rpc_net -module Core_types = Testbed.Capnp_direct.Core_types -module Request = Testbed.Capnp_direct.String_content.Request -module Response = Testbed.Capnp_direct.String_content.Response module Test_utils = Testbed.Test_utils -module Services = Testbed.Services -module CS = Testbed.Connection.Pair ( ) (* A client-server pair *) -module RO_array = Capnp_rpc.RO_array -module Error = Capnp_rpc.Error + +module Vat = Capnp_rpc_unix.Vat +module CapTP = Capnp_rpc_unix.CapTP +module Tls_wrapper = Capnp_rpc_net.Tls_wrapper module Exception = Capnp_rpc.Exception -module Local_struct_promise = Testbed.Capnp_direct.Local_struct_promise -module Cap_proxy = Testbed.Capnp_direct.Cap_proxy - -module C = CS.C -module S = CS.S - -let inc_ref = Core_types.inc_ref -let dec_ref = Core_types.dec_ref -let with_inc_ref x = inc_ref x; (x :> Core_types.cap) - -let response_equal a b = - let a_caps = Core_types.Response_payload.snapshot_caps a in - let b_caps = Core_types.Response_payload.snapshot_caps b in - Response.data a = Response.data b && - RO_array.equal (=) a_caps b_caps - -let error = Alcotest.of_pp Capnp_rpc.Error.pp -let response = Alcotest.testable Core_types.Response_payload.pp response_equal -let response_promise = Alcotest.(option (result response error)) - -let exn = Alcotest.of_pp Capnp_rpc.Exception.pp - -let call target msg caps = - let caps = List.map (fun x -> (x :> Core_types.cap)) caps in - List.iter Core_types.inc_ref caps; - let results, resolver = Local_struct_promise.make () in - let msg = - Testbed.Capnp_direct.String_content.Request.v msg - |> Core_types.Request_payload.with_caps (RO_array.of_list caps) - in - target#call resolver msg; - results - -let call_for_cap target msg caps = - let q = call target msg caps in - let cap = q#cap 0 in - dec_ref q; - cap - -(* Takes ownership of caps *) -let resolve_ok (ans:#Core_types.struct_resolver) msg caps = - let caps = List.map (fun x -> (x :> Core_types.cap)) caps in - let msg = - Testbed.Capnp_direct.String_content.Request.v msg - |> Core_types.Response_payload.with_caps (RO_array.of_list caps) - in - Core_types.resolve_ok ans msg - -let test_simple_connection () = - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags (Services.echo_service ()) in - let servce_promise = C.bootstrap c in - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; - S.handle_msg s ~expect:"finish"; - let q = call servce_promise "my-content" [] in - S.handle_msg s ~expect:"call:my-content"; - C.handle_msg c ~expect:"return:got:my-content"; - let expected = Request.v "got:my-content" in - Alcotest.(check response_promise) "Client got call response" (Some (Ok expected)) q#response; - dec_ref q; - dec_ref servce_promise; - CS.flush c s; - CS.check_finished c s - -let init_pair ~bootstrap_service = - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags bootstrap_service in - let bs = C.bootstrap c in - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; - S.handle_msg s ~expect:"finish"; - c, s, bs - -(* The server gets an object and then sends it back. When the object arrives back - at the client, it must be the original (local) object, not a proxy. *) -let test_return () = - let c, s, bs = init_pair ~bootstrap_service:(Services.echo_service ()) in - (* Pass callback *) - let slot = ref (Request.v "empty") in - let local = Services.swap_service slot in - let q = call bs "c1" [local] in - dec_ref local; - (* Server echos args back *) - S.handle_msg s ~expect:"call:c1"; - C.handle_msg c ~expect:"return:got:c1"; - let expected = Response.v "got:c1" - |> Core_types.Response_payload.with_caps (RO_array.of_list [(local :> Core_types.cap)]) + +exception Simulated_failure + +let ( let/ ) x f = f (x ()) +let ( and/ ) x y () = Fiber.pair x y + +let _debug () = + Logs.Src.set_level Capnp_rpc.Debug.src (Some Logs.Debug) + +type cs = { + client : Vat.t; + client_cancel : unit -> unit; + server : Vat.t; + server_cancel : unit -> unit; +} + +let next_port = ref 8000 + +let get_test_address name = + match Sys.os_type with + | "Win32" -> + (* No Unix-domain sockets on Windows *) + let port = !next_port in + incr next_port; + `TCP ("127.0.0.1", port) + | _ -> + `Unix (Filename.(concat (Filename.get_temp_dir_name ())) name) + +(* Have the client ask the server for its bootstrap object, and return the + resulting client-side proxy to it. *) +let get_bootstrap cs = + let id = Restorer.Id.public "" in + let sr = Vat.sturdy_uri cs.server id |> Vat.import_exn cs.client in + Sturdy_ref.connect_exn sr + +module Utils = struct + [@@@ocaml.warning "-32"] + + let dump cs = + Logs.info (fun f -> f ~tags:Test_utils.client_tags "%a" Vat.dump cs.client); + Logs.info (fun f -> f ~tags:Test_utils.server_tags "%a" Vat.dump cs.server) +end + +let cap_equal_exn a b = + match Capability.equal a b with + | Ok x -> x + | Error `Unsettled -> Alcotest.failf "Can't compare %a and %a: not settled!" + Capability.pp a + Capability.pp b + +let cap = Alcotest.testable Capability.pp cap_equal_exn + +let () = Logs.(set_level (Some Logs.Warning)) +let server_key = lazy (Auth.Secret_key.generate ()) +let client_key = lazy (Auth.Secret_key.generate ()) +let bad_key = lazy (Auth.Secret_key.generate ()) +let () = Logs.(set_level (Some Logs.Info)) + +let server_pem = lazy (`PEM (Auth.Secret_key.to_pem_data (Lazy.force server_key))) + +(* Run [fn ~sw] in a daemon fiber with a sub-switch. + Return a function to cancel the switch and the result of [fn]. *) +let fork_with_cancel ~sw ~tags fn = + let x, set_x = Promise.create () in + Fiber.fork_daemon ~sw (fun () -> + let is_cancelled = ref false in + try + Switch.run @@ fun sw -> + let cancel () = is_cancelled := true; Switch.fail sw Simulated_failure in + Promise.resolve set_x (cancel, fn ~sw); + Fiber.await_cancel () + with Simulated_failure when !is_cancelled -> + Logs.info (fun f -> f ~tags "Vat shut down by simulated failure"); + `Stop_daemon + ); + Promise.await x + +let make_vats_full ?(serve_tls=false) ~sw ~net ~restore () = + let server_cancel, server = + let server_config = + let addr = get_test_address "capnp-rpc-test-server" in + Capnp_rpc_unix.Vat_config.create ~secret_key:(Lazy.force server_pem) ~serve_tls addr + in + let tags = Test_utils.server_tags in + fork_with_cancel ~sw ~tags (Capnp_rpc_unix.serve ~net ~tags ~restore server_config) in - Alcotest.(check response_promise) "Client got response" (Some (Ok expected)) q#response; - dec_ref bs; - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"release"; - C.handle_msg c ~expect:"release"; - dec_ref q; - CS.check_finished c s - -let test_return_error () = - let c, s, bs = init_pair ~bootstrap_service:(Core_types.broken_cap (Exception.v "test-error")) in - (* Pass callback *) - let slot = ref (Request.v "empty") in - let local = Services.swap_service slot in - let q = call bs "call" [local] in - dec_ref local; - (* Server echos args back *) - CS.flush c s; - Alcotest.(check response_promise) "Client got response" (Some (Error (Error.exn "test-error"))) q#response; - dec_ref q; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -let test_share_cap () = - let c, s, bs = init_pair ~bootstrap_service:(Services.echo_service ()) in - let q = call bs "msg" [bs; bs] in - dec_ref bs; - S.handle_msg s ~expect:"call:msg"; - S.handle_msg s ~expect:"release"; (* Server drops [bs] export *) - (* Server re-exports [bs] as result of echo *) - C.handle_msg c ~expect:"return:got:msg"; - dec_ref q; - CS.flush c s; - CS.check_finished c s - -(* The server gets an object and then sends it back. Messages pipelined to - the object must arrive before ones sent directly. *) -let test_local_embargo () = - let c, s, bs = init_pair ~bootstrap_service:(Services.echo_service ()) in - let local = Services.logger () in - let q = call bs "Get service" [local] in - let service = q#cap 0 in - let m1 = call service "Message-1" [] in - S.handle_msg s ~expect:"call:Get service"; - C.handle_msg c ~expect:"return:got:Get service"; - dec_ref q; - (* We've received the bootstrap reply, so we know that [service] is local, - but the pipelined message we sent to it via [s] hasn't arrived yet. *) - let m2 = call service "Message-2" [] in - S.handle_msg s ~expect:"call:Message-1"; - C.handle_msg c ~expect:"call:Message-1"; (* Gets pipelined message back *) - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"return:take-from-other"; (* Get results of Message-1 directly *) - C.handle_msg c ~expect:"disembargo-reply"; - Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; - Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; - (* Clean up *) - dec_ref m1; - dec_ref m2; - dec_ref local; - dec_ref bs; - dec_ref service; - CS.flush c s; - CS.check_finished c s - -(* As above, but this time it resolves to a promised answer. *) -let test_local_embargo_2 () = - let server_main = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:server_main in - let local = Services.logger () in - let local_reg = Services.manual () in (* A registry that provides access to [local]. *) - let q1 = call bs "q1" [local_reg] in (* Give the server our registry and get back [local]. *) - let service = q1#cap 0 in (* Service is a promise for local *) - dec_ref q1; - let m1 = call service "Message-1" [] in (* First message to service *) - S.handle_msg s ~expect:"call:q1"; - let proxy_to_local_reg, a1 = server_main#pop1 "q1" in - (* The server will now make a call on the client registry, and then tell the client - to use the (unknown) result of that for [service]. *) - let q2 = call proxy_to_local_reg "q2" [] in - dec_ref proxy_to_local_reg; - let proxy_to_local = q2#cap 0 in - resolve_ok a1 "a1" [proxy_to_local]; - (* [proxy_to_local] is now owned by [a1]. *) - dec_ref q2; - C.handle_msg c ~expect:"call:q2"; - let a2 = local_reg#pop0 "q2" in - C.handle_msg c ~expect:"release"; - C.handle_msg c ~expect:"return:a1"; - (* The client now knows that [a1/0] is a local promise, but it can't use it directly yet because - of the pipelined messages. It sends a disembargo request down the old [q1/0] path and waits for - it to arrive back at the local promise. *) - resolve_ok a2 "a2" [local]; - (* Message-2 must be embargoed so that it arrives after Message-1. *) - let m2 = call service "Message-2" [] in - S.handle_msg s ~expect:"call:Message-1"; - C.handle_msg c ~expect:"call:Message-1"; (* Gets pipelined message back *) - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"return:take-from-other"; (* Get results of Message-1 directly *) - C.handle_msg c ~expect:"disembargo-reply"; - Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; - Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; - (* Clean up *) - dec_ref m1; - dec_ref m2; - dec_ref bs; - dec_ref service; - dec_ref local_reg; - CS.flush c s; - CS.check_finished c s - -(* Embargo on a resolve message *) -let test_local_embargo_3 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.logger () in - let q1 = call bs "q1" [local] in - S.handle_msg s ~expect:"call:q1"; - let proxy_to_logger, a1 = service#pop1 "q1" in - let promise = Cap_proxy.local_promise () in - resolve_ok a1 "a1" [promise]; - C.handle_msg c ~expect:"return:a1"; - let service = q1#cap 0 in - let m1 = call service "Message-1" [] in - promise#resolve proxy_to_logger; - C.handle_msg c ~expect:"resolve"; - (* We've received the resolve message, so we know that [service] is local, - but the pipelined message we sent to it via [s] hasn't arrived yet. *) - let m2 = call service "Message-2" [] in - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"call:Message-1"; - C.handle_msg c ~expect:"call:Message-1"; (* Gets pipelined message back *) - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"return:take-from-other"; (* Get results of Message-1 directly *) - C.handle_msg c ~expect:"disembargo-reply"; - Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; - Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; - (* Clean up *) - dec_ref m1; - dec_ref m2; - dec_ref local; - dec_ref q1; - dec_ref bs; - dec_ref service; - CS.flush c s; - CS.check_finished c s - -(* Embargo a local answer that doesn't have the specified cap. *) -let test_local_embargo_4 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.echo_service () in - let q1 = call bs "q1" [local] in - let broken = q1#cap 0 in - let qp = call broken "pipeline" [] in - S.handle_msg s ~expect:"call:q1"; - let proxy_to_local, a1 = service#pop1 "q1" in - let q2 = call proxy_to_local "q2" [] in - resolve_ok a1 "a1" [q2#cap 0]; - dec_ref q2; - C.handle_msg c ~expect:"call:q2"; - C.handle_msg c ~expect:"return:a1"; - (* At this point, the client knows that [broken] is its own answer to [q2], which is an error. - It therefore does not try to disembargo it. *) - Alcotest.(check string) "Error not embargoed" - "Failed: Invalid capability index!" - (Fmt.str "%t" broken#shortest#pp); - (* Clean up *) - dec_ref qp; - dec_ref local; - dec_ref proxy_to_local; - dec_ref q1; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -(* A remote answer resolves to a remote promise, which doesn't require an embargo. - However, when that promise resolves to a local service, we *do* need an embargo - (because we pipelined over the answer), even though we didn't pipeline over the - import. *) -let test_local_embargo_5 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.logger () in - let q1 = call bs "q1" [local] in - let test = q1#cap 0 in - let m1 = call test "Message-1" [] in - S.handle_msg s ~expect:"call:q1"; - let proxy_to_local, a1 = service#pop1 "q1" in - let server_promise = Cap_proxy.local_promise () in - resolve_ok a1 "a1" [server_promise]; - C.handle_msg c ~expect:"return:a1"; - (* [test] is now known to be at [service]; no embargo needed. - The server now resolves it to a client service. *) - server_promise#resolve proxy_to_local; - C.handle_msg c ~expect:"resolve"; - let m2 = call test "Message-2" [] in - CS.flush c s; - Alcotest.(check string) "Pipelined arrived first" "Message-1" local#pop; - Alcotest.(check string) "Embargoed arrived second" "Message-2" local#pop; - CS.flush c s; - (* Clean up *) - dec_ref m1; - dec_ref m2; - dec_ref local; - dec_ref test; - dec_ref q1; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -(* We pipeline a message to a question, and then discover that it resolves - to a local answer, which points to a capability at the peer. As the peer - is already bouncing the pipelined message back to us, we need to embargo - the new cap until the server's question is finished. *) -let test_local_embargo_6 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.manual () in - (* Client calls the server, giving it [local]. *) - let target = call_for_cap bs "q1" [local] in - let m1 = call target "Message-1" [] in - S.handle_msg s ~expect:"call:q1"; - let proxy_to_local, a1 = service#pop1 "q1" in - (* Server makes a call on [local] and uses that promise to answer [q1]. *) - let q2 = call proxy_to_local "q2" [] in - resolve_ok a1 "a1" [q2#cap 0]; - C.handle_msg c ~expect:"call:q2"; - S.handle_msg s ~expect:"call:Message-1"; (* Forwards pipelined call back to the client *) - (* Client resolves a2 to [bs]. *) - let a2 = local#pop0 "q2" in - resolve_ok a2 "a2" [bs]; - (* Server gets response to q2, that [q2#cap 0] is [bs]. - Although we don't actually care about this, it still embargoes it: *) - S.handle_msg s ~expect:"return:a2"; - (* Client gets results from q1 - need to embargo it until we've forwarded the pipelined message - back to the server. *) - C.handle_msg c ~expect:"return:a1"; - Logs.info (fun f -> f "target = %t" target#pp); - let m2 = call target "Message-2" [] in (* Client tries to send message-2, but it gets embargoed *) - dec_ref target; - S.handle_msg s ~expect:"disembargo-request"; - S.handle_msg s ~expect:"finish"; (* Finish for q1 *) - C.handle_msg c ~expect:"call:Message-1"; (* Pipelined message-1 arrives at client *) - C.handle_msg c ~expect:"return:take-from-other"; - C.handle_msg c ~expect:"disembargo-request"; (* (the server is doing its own embargo on q2) *) - S.handle_msg s ~expect:"call:Message-1"; - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"disembargo-reply"; (* (the server is doing its own embargo on q2) *) - C.handle_msg c ~expect:"disembargo-reply"; - S.handle_msg s ~expect:"call:Message-2"; - let am1 = service#pop0 "Message-1" in - let am2 = service#pop0 "Message-2" in - resolve_ok am1 "m1" []; - resolve_ok am2 "m2" []; - dec_ref m1; - dec_ref m2; - dec_ref q2; - dec_ref proxy_to_local; - dec_ref local; - CS.flush c s; - CS.check_finished c s - -(* The client tries to disembargo via a switchable. *) -let test_local_embargo_7 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.manual () in - (* Client calls the server, giving it [local]. *) - let q1 = call bs "q1" [local] in - let target = q1#cap 0 in - dec_ref q1; - let m1 = call target "Message-1" [] in - S.handle_msg s ~expect:"call:q1"; - let proxy_to_local, a1 = service#pop1 "q1" in - (* Server makes a call on [local] and uses that promise to answer [q1]. *) - let q2 = call proxy_to_local "q2" [] in - resolve_ok a1 "a1" [q2#cap 0]; - dec_ref q2; - C.handle_msg c ~expect:"call:q2"; - S.handle_msg s ~expect:"call:Message-1"; (* Forwards pipelined call back to the client *) - (* Client resolves a2 to a local promise. *) - let client_promise = Cap_proxy.local_promise () in - let a2 = local#pop0 "q2" in - resolve_ok a2 "a2" [with_inc_ref client_promise]; - (* Client gets answer to a1 and sends disembargo. *) - C.handle_msg c ~expect:"return:a1"; - let m2 = call target "Message-2" [] in - S.handle_msg s ~expect:"return:a2"; - (* At this point, the server's answer to q1 is a switchable, because it expects the client - to resolve the promise at some point in the future. *) - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"call:Message-1"; (* Pipelined message-1 arrives at client *) - C.handle_msg c ~expect:"return:take-from-other"; - C.handle_msg c ~expect:"disembargo-reply"; - let client_logger = Services.logger () in - inc_ref client_logger; - client_promise#resolve (client_logger :> Core_types.cap); - dec_ref client_promise; - CS.flush c s; - Alcotest.(check string) "Pipelined arrived first" "Message-1" client_logger#pop; - Alcotest.(check string) "Embargoed arrived second" "Message-2" client_logger#pop; - dec_ref m1; - dec_ref m2; - dec_ref client_logger; - dec_ref proxy_to_local; - dec_ref local; - dec_ref bs; - dec_ref target; - CS.flush c s; - CS.check_finished c s - -let test_local_embargo_8 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.manual () in - (* Client calls the server, giving it [local]. *) - let q1 = call bs "q1" [local] in - let target = q1#cap 0 in - dec_ref q1; - S.handle_msg s ~expect:"call:q1"; - let proxy_to_local, a1 = service#pop1 "q1" in - (* Server makes a call on [local] and uses that promise to answer [q1]. *) - let q2 = call proxy_to_local "q2" [] in - (* Client resolves a2 to a local promise. *) - C.handle_msg c ~expect:"call:q2"; - let a2 = local#pop0 "q2" in - let local_promise = Cap_proxy.local_promise () in - resolve_ok a2 "a2" [local_promise]; - (* The server then answers q1 with that [local_promise]. *) - S.handle_msg s ~expect:"return:a2"; - resolve_ok a1 "a1" [q2#cap 0]; - dec_ref q2; - C.handle_msg c ~expect:"finish"; - (* The client resolves the local promise to a remote one *) - let q3 = call bs "q3" [] in - let remote_promise = q3#cap 0 in - let m1 = call target "Message-1" [] in - local_promise#resolve remote_promise; - S.handle_msg s ~expect:"call:q3"; - S.handle_msg s ~expect:"call:Message-1"; (* Forwards pipelined call back to the client *) - S.handle_msg s ~expect:"resolve"; - (* Client gets answer to a1 and sends disembargo. *) - C.handle_msg c ~expect:"return:a1"; - (* We now know that [target] is [remote_promise], but we need to embargo it until Message-1 - arrives back at the client. *) - let m2 = call target "Message-2" [] in - C.handle_msg c ~expect:"call:Message-1"; (* Forwards pipelined call back to the server again *) - S.handle_msg s ~expect:"disembargo-request"; - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"call:Message-1"; - C.handle_msg c ~expect:"return:take-from-other"; (* Reply to client's first Message-1 *) - S.handle_msg s ~expect:"finish"; - C.handle_msg c ~expect:"disembargo-request"; (* Server is also doing its own embargo *) - C.handle_msg c ~expect:"disembargo-reply"; (* Client now disembargoes Message-2 *) - S.handle_msg s ~expect:"disembargo-reply"; - C.handle_msg c ~expect:"release"; - C.handle_msg c ~expect:"finish"; - S.handle_msg s ~expect:"call:Message-2"; - let logger = Services.logger () in - let a3 = service#pop0 "q3" in - inc_ref logger; - resolve_ok a3 "a3" [logger]; - Alcotest.(check string) "Pipelined arrived first" "Message-1" logger#pop; - Alcotest.(check string) "Embargoed arrived second" "Message-2" logger#pop; - dec_ref m1; - dec_ref m2; - dec_ref q3; - dec_ref target; - dec_ref proxy_to_local; - dec_ref logger; - dec_ref bs; - dec_ref local; - CS.flush c s; - CS.check_finished c s - -(* m1 and m2 are sent in order on the same reference, [pts2]. - They must arrive in order too. *) -let _test_local_embargo_9 () = - let client_bs = Services.manual () in - let service_bs = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags ~client_bs:(with_inc_ref client_bs) - ~server_tags:Test_utils.server_tags (with_inc_ref service_bs) in - (* The client gets the server's bootstrap. *) - let service = C.bootstrap c in - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; - S.handle_msg s ~expect:"finish"; - (* The server gets the client's bootstrap. *) - let ptc0 = S.bootstrap s in (* The first proxy-to-client *) - C.handle_msg c ~expect:"bootstrap"; - S.handle_msg s ~expect:"return:(boot)"; - C.handle_msg c ~expect:"finish"; - (* The client calls the server. *) - let pts1 = call_for_cap service "service.ptc0" [] in (* will become [ptc0] *) - let pts2 = call_for_cap service "service.ptc1" [] in (* will become [ptc1] *) - S.handle_msg s ~expect:"call:service.ptc0"; - S.handle_msg s ~expect:"call:service.ptc1"; - (* The server calls the client. *) - let ptc1 = call_for_cap ptc0 "client.self" [] in (* [ptc1] will become [ptc0] *) - C.handle_msg c ~expect:"call:client.self"; - (* The client handles the server's request by returning [pts1], which will become [ptc0]. *) - let ptc0_resolver = client_bs#pop0 "client.self" in - resolve_ok ptc0_resolver "reply" [pts1]; - (* The server handles the client's requests by returning [ptc0] (the client's bootstrap) - and [ptc1], which will resolve to the client's bootstrap later. *) - let pts0_resolver = service_bs#pop0 "service.ptc0" in - resolve_ok pts0_resolver "ptc0" [ptc0]; - let pts1_resolver = service_bs#pop0 "service.ptc1" in - resolve_ok pts1_resolver "ptc1" [with_inc_ref ptc1]; - (* The client pipelines a message to the server: *) - let m1 = call pts2 "m1" [] in - (* The client gets replies to its questions: *) - C.handle_msg c ~expect:"return:ptc0"; (* Resolves pts1 to client_bs (only used for pipelining) *) - C.handle_msg c ~expect:"return:ptc1"; (* Resolves pts2 to embargoed(pts1) (embargoed because of [m1]) *) - (* The client knows [ptc1] is local, but has embargoed it. - [m1] must arrive back at the client before the disembargo. *) - let m2 = call pts2 "m2" [] in - S.handle_msg s ~expect:"return:reply"; - S.handle_msg s ~expect:"call:m1"; (* Server forwards m1 back to client *) - C.handle_msg c ~expect:"call:m1"; (* Client forwards m1 back to server *) - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"return:take-from-other"; - C.handle_msg c ~expect:"disembargo-reply"; - (* Client does a second disembargo *) - S.handle_msg s ~expect:"finish"; - C.handle_msg c ~expect:"finish"; - S.handle_msg s ~expect:"call:m1"; (* Server forwards m1 back to client again *) - C.handle_msg c ~expect:"call:m1"; (* m1 finally arrives *) - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"return:take-from-other"; - C.handle_msg c ~expect:"finish"; - C.handle_msg c ~expect:"disembargo-reply"; - (* At this point, the client knows [m1] must have arrived by now and delivers m2. *) - let am1 = client_bs#pop0 "m1" in - let am2 = client_bs#pop0 "m2" in - resolve_ok am1 "am1" []; - resolve_ok am2 "am2" []; - dec_ref pts2; - dec_ref ptc1; - dec_ref client_bs; - dec_ref service_bs; - dec_ref service; - dec_ref m1; - dec_ref m2; - CS.flush c s; - CS.check_finished c s - -(* We still need embargoes with self-results-to=yourself. *) -let test_local_embargo_10 () = - let service_1 = Services.manual () in (* At the client *) - let c, s = CS.create - ~client_tags:Test_utils.client_tags - ~server_tags:Test_utils.server_tags (Services.echo_service ()) + let client_cancel, client = + let tags = Test_utils.client_tags in + fork_with_cancel ~sw ~tags (Vat.create ~tags ~secret_key:client_key net) in - let proxy_to_echo = C.bootstrap c in - CS.flush c s; - (* The client asks for a service, which will resolve to [service_1]. - It pipelines it a message [q1], and then pipelines [m1] on the result of that. - The server will forward [q1] back to the client and tell it to take the answer - from that. Because the client already sent [m1] over the result, it must - embargo it and wait before sending [m2]. *) - let q0 = call proxy_to_echo "echo" [service_1] in - let bs = q0#cap 0 in - dec_ref q0; - (* bs is a promise for the client's own [service_1]. *) - let q1 = call bs "q1" [] in - let target = q1#cap 0 in - let m1 = call target "M-1" [] in - S.handle_msg s ~expect:"call:echo"; - S.handle_msg s ~expect:"call:q1"; - S.handle_msg s ~expect:"call:M-1"; - C.handle_msg c ~expect:"return:got:echo"; - S.handle_msg s ~expect:"disembargo-request"; (* Client disembargoing bootstrap *) - C.handle_msg c ~expect:"call:q1"; - let aq1 = service_1#pop0 "q1" in - resolve_ok aq1 "aq1" [with_inc_ref service_1]; - C.handle_msg c ~expect:"return:take-from-other"; (* Return for client's q1 - use aq1 *) - (* At this point, the client knows that [target] is [service_1], but must embargo it until - it knows that "M-1" has been delivered. *) - let m2 = call target "M-2" [] in - C.handle_msg c ~expect:"call:M-1"; (* Pipelined call arrives back *) - C.handle_msg c ~expect:"return:take-from-other"; (* Return for M-1 *) - C.handle_msg c ~expect:"disembargo-reply"; (* Disembargo of [bs]. *) - S.handle_msg s ~expect:"finish"; (* Bootstrap *) - S.handle_msg s ~expect:"return:sent-elsewhere"; (* For forwarded q1 *) - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"release"; - C.handle_msg c ~expect:"disembargo-reply"; - let am1 = service_1#pop0 "M-1" in - let am2 = service_1#pop0 "M-2" in - resolve_ok am1 "am1" []; - resolve_ok am2 "am2" []; - dec_ref q1; - dec_ref m1; - dec_ref m2; - dec_ref target; - dec_ref bs; - dec_ref proxy_to_echo; - dec_ref service_1; - CS.flush c s; - CS.check_finished c s - -let test_local_embargo_11 () = - let client_bs = Services.manual () in - let server_bs = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags ~client_bs - ~server_tags:Test_utils.server_tags server_bs + { + client; + client_cancel; + server; + server_cancel; + } + +let with_vats ?serve_tls ~net ~service fn = + Switch.run @@ fun sw -> + let id = Restorer.Id.public "" in + let restore = Restorer.single id service in + Switch.on_release sw (fun () -> Capability.dec_ref service); + fn @@ make_vats_full ?serve_tls ~sw ~net ~restore (); + Logs.info (fun f -> f "Test finished; shutting down vats..."); + (* Check for leaks while the vat is still running. *) + Gc.full_major (); + Fiber.yield () + +(* Generic runner for Alcotest. *) +let run_eio ~net name ?(expected_warnings=0) fn = + Alcotest.test_case name `Quick @@ fun () -> + let warnings_at_start = Logs.(err_count () + warn_count ()) in + Logs.info (fun f -> f "Start test-case"); + fn ~net; + Gc.full_major (); + let warnings_at_end = Logs.(err_count () + warn_count ()) in + Alcotest.(check int) "Check log for warnings" expected_warnings (warnings_at_end - warnings_at_start) + +let test_simple ~net ~serve_tls = + with_vats ~net ~serve_tls ~service:(Echo.local ()) @@ fun cs -> + let service = get_bootstrap cs in + let reply = Echo.ping service "ping" in + Alcotest.(check string) "Ping response" "got:0:ping" reply; + Capability.dec_ref service + +let test_bad_crypto ~net = + with_vats ~net ~serve_tls:true ~service:(Echo.local ()) @@ fun cs -> + let id = Restorer.Id.public "" in + let uri = Vat.sturdy_uri cs.server id in + let bad_digest = Auth.Secret_key.digest ~hash:`SHA256 (Lazy.force bad_key) in + let uri = Auth.Digest.add_to_uri bad_digest uri in + let sr = Capnp_rpc_unix.Vat.import_exn cs.client uri in + let old_warnings = Logs.warn_count () in + match Sturdy_ref.connect sr with + | Ok _ -> Alcotest.fail "Wrong TLS key should have been rejected" + | Error e -> + let msg = Fmt.to_to_string Capnp_rpc.Exception.pp e in + assert (String.starts_with ~prefix:"Failed: TLS connection failed: TLS failure: authentication failure" msg); + Logs.info (fun f -> f "Wait for server to log warning..."); + while Logs.warn_count () = old_warnings do + Fiber.yield () + done + +let test_parallel ~net = + with_vats ~net ~service:(Echo.local ()) @@ fun cs -> + Switch.run @@ fun sw -> + let service = get_bootstrap cs in + let reply1 = Fiber.fork_promise ~sw (fun () -> Echo.ping service ~slow:true "ping1") in + Echo.ping service "ping2" |> Alcotest.(check string) "Ping2 response" "got:1:ping2"; + assert (Promise.peek reply1 = None); + Echo.unblock service; + Promise.await_exn reply1 |> Alcotest.(check string) "Ping1 response" "got:0:ping1"; + Capability.dec_ref service + +let test_registry ~net = + Switch.run @@ fun sw -> + let registry_impl = Registry.local ~sw () in + with_vats ~net ~service:registry_impl @@ fun cs -> + let registry = get_bootstrap cs in + Capability.with_ref (Registry.echo_service registry) @@ fun echo_service -> + Registry.unblock registry; + Echo.ping echo_service "ping" |> Alcotest.(check string) "Ping response" "got:0:ping"; + Capability.dec_ref registry + +let test_embargo ~net = + Switch.run @@ fun sw -> + let registry_impl = Registry.local ~sw () in + let local_echo = Echo.local () in + with_vats ~net ~service:registry_impl @@ fun cs -> + let registry = get_bootstrap cs in + Registry.set_echo_service registry local_echo; + Capability.dec_ref local_echo; + let echo_service = Registry.echo_service registry in + let reply1 = Fiber.fork_promise ~sw (fun () -> Echo.ping echo_service "ping") in + Registry.unblock registry; + Promise.await_exn reply1 |> Alcotest.(check string) "Ping response" "got:0:ping"; + (* Flush, to ensure we resolve the echo_service's location. *) + Echo.ping echo_service "ping" |> Alcotest.(check string) "Ping response" "got:1:ping"; + (* Test local connection. *) + Echo.ping echo_service "ping" |> Alcotest.(check string) "Ping response" "got:2:ping"; + Capability.dec_ref echo_service; + Capability.dec_ref registry + +let test_resolve ~net = + Switch.run @@ fun sw -> + let registry_impl = Registry.local ~sw () in + let local_echo = Echo.local () in + with_vats ~net ~service:registry_impl @@ fun cs -> + let registry = get_bootstrap cs in + Registry.set_echo_service registry local_echo; + Capability.dec_ref local_echo; + let echo_service = Registry.echo_service_promise registry in + let reply1 = Fiber.fork_promise ~sw (fun () -> Echo.ping echo_service "ping") in + Registry.unblock registry; + Promise.await_exn reply1 |> Alcotest.(check string) "Ping response" "got:0:ping"; + (* Flush, to ensure we resolve the echo_service's location. *) + Echo.ping echo_service "ping" |> Alcotest.(check string) "Ping response" "got:1:ping"; + (* Test local connection. *) + Echo.ping echo_service "ping" |> Alcotest.(check string) "Ping response" "got:2:ping"; + Capability.dec_ref echo_service; + Capability.dec_ref registry + +(* todo: we stop waiting and we send a finish message, but we don't currently + abort the service operation. *) +let test_cancel ~net = + with_vats ~net ~service:(Echo.local ()) @@ fun cs -> + let service = get_bootstrap cs in + Fiber.first + (fun () -> + ignore (Echo.ping service ~slow:true "ping1" : string); + assert false + ) + (fun () -> + Echo.ping service "ping" |> Alcotest.(check string) "Ping response" "got:1:ping" + ); + Echo.unblock service; + Echo.ping service "ping" |> Alcotest.(check string) "Ping response" "got:2:ping"; + Capability.dec_ref service + +let float = Alcotest.testable Fmt.float (=) + +let test_calculator ~net = + let open Calc in + Switch.run @@ fun sw -> + let service = Calc.local ~sw in + with_vats ~net ~service @@ fun cs -> + let c = get_bootstrap cs in + Calc.evaluate c (Float 1.) |> Value.final_read |> Alcotest.check float "Simple calc" 1.; + let local_add = Calc.Fn.add in + let expr = Expr.(Call (local_add, [Float 1.; Float 2.])) in + Calc.evaluate c expr |> Value.final_read |> Alcotest.check float "Complex with local fn" 3.; + let remote_add = Calc.getOperator c `Add in + Calc.Fn.call remote_add [5.; 3.] |> Alcotest.check float "Check fn" 8.; + let expr = Expr.(Call (remote_add, [Float 1.; Float 2.])) in + Calc.evaluate c expr |> Value.final_read |> Alcotest.check float "Complex with remote fn" 3.; + Capability.dec_ref remote_add; + Capability.dec_ref c + +let test_calculator2 ~net = + let open Calc in + Switch.run @@ fun sw -> + let service = Calc.local ~sw in + with_vats ~net ~service @@ fun cs -> + let c = get_bootstrap cs in + let remote_add = Calc.getOperator c `Add in + let remote_mul = Calc.getOperator c `Multiply in + let expr = Expr.(Call (remote_mul, [Float 4.; Float 6.])) in + let result = Calc.evaluate c expr in + let/ add3 () = + let expr = Expr.(Call (remote_add, [Prev result; Float 3.])) in + Calc.evaluate c expr |> Value.final_read + and/ add5 () = + let expr = Expr.(Call (remote_add, [Prev result; Float 5.])) in + Calc.evaluate c expr |> Value.final_read in - let to_server_bs = C.bootstrap c in - let to_client_bs = S.bootstrap s in - CS.flush c s; - let q1 = call_for_cap to_server_bs "q1" [] in - let to_server_bs_2 = C.bootstrap c in - let q2 = call_for_cap to_client_bs "q2" [] in - S.handle_msg s ~expect:"call:q1"; - resolve_ok (server_bs#pop0 "q1") "a1" [with_inc_ref q2]; - let q3 = call q1 "q3" [] in - C.handle_msg c ~expect:"call:q2"; - resolve_ok (client_bs#pop0 "q2") "a2" [with_inc_ref to_server_bs_2]; - S.handle_msg s ~expect:"bootstrap"; - (* Client gets a1, resolving q1 to the already-answered q2's cap 0. - As q3 was pipelined over q1 and q2's cap 0 is currently a remote-promise - (q2), it embargoes q1. *) - C.handle_msg c ~expect:"return:a1"; - (* to_server_bs_2 resolves. No embargo is needed: *) - C.handle_msg c ~expect:"return:(boot)"; - S.handle_msg s ~expect:"call:q3"; (* Pipelined q3 arrives, forwarded to q2 *) - C.handle_msg c ~expect:"call:q3"; (* q3 back at client, sent to bootstrap call *) - C.handle_msg c ~expect:"return:take-from-other"; (* use forwarded call for answer to q3 *) - S.handle_msg s ~expect:"return:a2"; (* q2 = server_bs, embargoed due to q3 forwarding *) - (* note: probably shouldn't mark paths as dirty when just forwarding, but should still work *) - C.handle_msg c ~expect:"disembargo-request"; - S.handle_msg s ~expect:"disembargo-request"; - C.handle_msg c ~expect:"disembargo-reply"; (* Second embargo not needed, as remote *) - dec_ref to_server_bs; - dec_ref to_server_bs_2; - dec_ref to_client_bs; - dec_ref q1; - dec_ref q2; - dec_ref q3; - CS.flush c s; - CS.check_finished c s - -let test_local_embargo_12 () = - let server_bs = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:server_bs in - (* Client calls [bs], passing a local promise as the argument. *) - let x, xr = Local_struct_promise.make () in (* x will become broken *) - let x0 = x#cap 0 in - let q1 = call bs "q1" [x0] in - (* Client resolves local promise to the (about to fail) promise q1:2 *) - resolve_ok xr "x" [with_inc_ref (q1#cap 2)]; - (* Client pipelines q2 over q1:0 *) - let q2 = call (q1#cap 0) "q2" [] in - (* Server handles q1. The result is a promise for the result of a call to q1:2, - which will fail. *) - S.handle_msg s ~expect:"call:q1"; - let to_x0, a1 = server_bs#pop1 "q1" in - let y = call_for_cap to_x0 "q3" [] in - resolve_ok a1 "a1" [y]; - C.handle_msg c ~expect:"call:q3"; (* q3 arrives at client and is forwarded to q1 (to=yourself) *) - S.handle_msg s ~expect:"resolve"; (* [to_x0 = q3#2]. *) - C.handle_msg c ~expect:"return:a1"; (* [q1 = q3#0] *) - (* Client has pipelined over q1, so embargoes it. *) - S.handle_msg s ~expect:"call:q2"; (* Server forwards q2 back along q3, replies with take-from-other(q4) *) - C.handle_msg c ~expect:"release"; (* Server will use q3 instead of i0 for to_x0 *) - C.handle_msg c ~expect:"call:q2"; (* Client forwards q2 to q1#2 *) - S.handle_msg s ~expect:"call:q3"; (* q3 arrives at a1#2, which doesn't exist *) - (* Server replies with results-sent-elsewhere. Is this correct? It's really an error. *) - C.handle_msg c ~expect:"return:take-from-other"; (* Take from q2=q4 *) - CS.dump c s; - S.handle_msg s ~expect:"return:take-from-other"; (* Take from broken answer *) - C.handle_msg c ~expect:"return:sent-elsewhere"; - S.handle_msg s ~expect:"disembargo-request"; (* Client wants to clear q1 to disembargo x *) - C.handle_msg c ~expect:"disembargo-reply"; - (* As [x] is now broken, no further disembargoes should be sent. *) - dec_ref q1; - dec_ref q2; - dec_ref bs; - dec_ref x; - dec_ref x0; - dec_ref to_x0; - CS.flush c s; - CS.check_finished c s - -let test_local_embargo_13 () = - let client_bs = Services.manual () in - let server_bs = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags ~client_bs - ~server_tags:Test_utils.server_tags server_bs + Alcotest.check float "First" 27.0 add3; + Alcotest.check float "Second" 29.0 add5; + Capability.dec_ref result; + Capability.dec_ref remote_add; + Capability.dec_ref remote_mul; + Capability.dec_ref c + +(* Like [Calc.getOperator t `Multiply], but using [Capability.call] to check that works. *) +let get_mul_direct t = + let module Api = Calculator.MakeRPC(Capnp_rpc) in + let open Api.Client.Calculator.GetOperator in + let req, p = Capability.Request.create ~message_size:200 Params.init_pointer in + Params.op_set p Api.Builder.Calculator.Operator.Multiply; + let q = Capability.call t method_id req in + let mul = Results.func_get_pipelined q in + Capnp_rpc.StructRef.dec_ref q; + mul + +let test_calculator3 ~net = + Switch.run @@ fun sw -> + let service = Calc.local ~sw in + with_vats ~net ~service @@ fun cs -> + let c = get_bootstrap cs in + let remote_mul = get_mul_direct c in + let expr = Calc.Expr.(Call (remote_mul, [Float 4.; Float 6.])) in + let result = Calc.evaluate c expr |> Calc.Value.final_read in + Alcotest.check float "Result" 24.0 result; + Capability.dec_ref remote_mul; + Capability.dec_ref c + +let test_indexing ~net = + Switch.run @@ fun sw -> + let registry_impl = Registry.local ~sw () in + with_vats ~net ~service:registry_impl @@ fun cs -> + let registry = get_bootstrap cs in + let echo_service, version = Registry.complex registry in + Echo.ping echo_service "ping" |> Alcotest.(check string) "Ping response" "got:0:ping"; + Registry.Version.read version |> Alcotest.(check string) "Version response" "0.1"; + Capability.dec_ref registry; + Capability.dec_ref echo_service; + Capability.dec_ref version + +let cmd_result t = + let pp f (x : ('a Cmdliner.Cmd.eval_ok, Cmdliner.Cmd.eval_error) result) = + match x with + | Ok (`Help) -> Fmt.string f "help" + | Ok (`Version) -> Fmt.string f "version" + | Ok (`Ok x) -> Alcotest.pp t f x + | _ -> Fmt.string f "error" in - let to_client = S.bootstrap s in - let to_server = C.bootstrap c in - CS.flush c s; - let broken = Core_types.broken_cap (Capnp_rpc.Exception.v "broken") in (* (at server) *) - (* Server calls client, passing a broken cap. - Due to a protocol limitation, we first send this as an export and then break it. *) - let q1 = call_for_cap to_client "q1" [broken] in - (* The client calls the server, and pipelines over the result *) - let q2 = call_for_cap to_server "q2" [] in - let q3 = call q2 "q3" [] in - (* Client gets exported (soon to be broken) cap and echoes it back. *) - C.handle_msg c ~expect:"call:q1"; - let to_broken, a1 = client_bs#pop1 "q1" in - resolve_ok a1 "a1" [to_broken]; - (* Server replies to q2 with q1. *) - S.handle_msg s ~expect:"call:q2"; - let a2 = server_bs#pop0 "q2" in - resolve_ok a2 "a2" [q1]; - C.handle_msg c ~expect:"resolve"; (* Client discovers to_broken is broken *) - S.handle_msg s ~expect:"call:q3"; (* Server gets q3, forwards to q1 *) - C.handle_msg c ~expect:"return:a2"; (* Client gets q2 = q1, embargoes due to q3 *) - C.handle_msg c ~expect:"call:q3"; (* Client forwards q3 to broken *) - (* Not sure if we need to forward q3 here, since we know the target is broken. *) - (* When q2 embargo is done, client must not do a second embargo, since q2 is now broken. *) - dec_ref q2; - dec_ref q3; - dec_ref to_server; - dec_ref to_client; - CS.flush c s; - CS.check_finished c s - -let test_local_embargo_14 () = - let client_bs = Services.manual () in (* Bootstrap for vat 0 *) - let server_bs = Services.manual () in (* Bootstrap for vat 1 *) - let c, s = CS.create - ~client_tags:Test_utils.client_tags ~client_bs - ~server_tags:Test_utils.server_tags server_bs + let equal a b = + match a, b with + | Ok (`Ok a), Ok (`Ok b) -> Alcotest.equal t a b + | _ -> a = b in - let to_server = C.bootstrap c in - let to_client = S.bootstrap s in - CS.flush c s; - let client_via_q1 = call_for_cap to_server "q1" [] in - S.handle_msg s ~expect:"call:q1"; - resolve_ok (server_bs#pop0 "q1") "a1" [to_client]; - let q2 = call client_via_q1 "q2" [] in - let server_via_q2 = q2#cap 0 in - let broken = q2#cap 2 in - C.handle_msg c ~expect:"return:a1"; - (* We sent q2 down q1, so the client will embargo client_via_q1 *) - S.handle_msg s ~expect:"call:q2"; (* Forwards q2 back to client as q2' *) - C.handle_msg c ~expect:"call:q2"; (* client_bs gets q2'. *) - let q3 = call broken "q3" [] in - C.handle_msg c ~expect:"return:take-from-other"; (* Client learns q2 = q2' *) - (* Client embargoes q2, due to q3 *) - let m1 = call server_via_q2 "m1" [] in - Logs.info (fun f -> f "server_via_q2 = %t" server_via_q2#pp); - resolve_ok (client_bs#pop0 "q2") "a2" [to_server]; - Logs.info (fun f -> f "server_via_q2 = %t" server_via_q2#pp); - let m2 = call server_via_q2 "m2" [] in - CS.flush c s; - let _ = server_bs#pop0 "m1" in - let _ = server_bs#pop0 "m2" in - dec_ref client_via_q1; - dec_ref server_via_q2; - dec_ref broken; - dec_ref q2; - dec_ref q3; - dec_ref m1; - dec_ref m2; - CS.flush c s; - CS.check_finished c s - -let test_local_embargo_15 () = - let client_bs = Services.manual () in - let server_bs = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags ~client_bs - ~server_tags:Test_utils.server_tags server_bs + Alcotest.testable pp equal + +let vat_config = Alcotest.testable Capnp_rpc_unix.Vat_config.pp Capnp_rpc_unix.Vat_config.equal + +let config_result = cmd_result vat_config + +let test_options () = + let term = Cmdliner.Cmd.(v (info "main") Capnp_rpc_unix.Vat_config.cmd) in + let config = Cmdliner.Cmd.eval_value + ~argv:[| "main"; "--capnp-secret-key-file=key.pem"; "--capnp-listen-address"; "unix:/run/socket" |] term in + let expected = + Result.ok (`Ok (Capnp_rpc_unix.Vat_config.create + ~secret_key:(`File "key.pem") + (`Unix "/run/socket"))) in - let to_server = C.bootstrap c in - let to_client = S.bootstrap s in - let x1 = call_for_cap to_server "q1" [] in - CS.flush c s; - let x2 = call_for_cap to_client "q2" [] in - let x3 = call_for_cap to_client "q3" [] in - CS.flush c s; - resolve_ok (server_bs#pop0 "q1") "reply" [with_inc_ref x3]; - resolve_ok (client_bs#pop0 "q2") "reply" [with_inc_ref x1]; - let m1 = call x2 "m1" [] in - S.handle_msg s ~expect:"return:reply"; (* q2 = x3 *) - let m2 = call x2 "m2" [] in - let local_promise = Cap_proxy.local_promise () in - resolve_ok (client_bs#pop0 "q3") "reply" [with_inc_ref local_promise]; - local_promise#resolve (with_inc_ref to_server); - dec_ref local_promise; - CS.flush c s; - let am1 = server_bs#pop0 "m1" in - let am2 = server_bs#pop0 "m2" in - resolve_ok am1 "am1" []; - resolve_ok am2 "am2" []; - dec_ref m1; - dec_ref m2; - dec_ref x1; - dec_ref x2; - dec_ref x3; - dec_ref to_server; - dec_ref to_client; - CS.flush c s; - CS.check_finished c s - -(* The field must still be useable after the struct is released. *) -let test_fields () = - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags (Services.echo_service ()) in - let f0 = C.bootstrap c in - let q1 = call f0 "c1" [] in - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; (* [bs] resolves *) - S.handle_msg s ~expect:"call:c1"; - S.handle_msg s ~expect:"finish"; - C.handle_msg c ~expect:"return:got:c1"; - Alcotest.(check response_promise) "Echo response" (Some (Ok (Response.v "got:c1"))) q1#response; - dec_ref q1; - let q2 = call f0 "c2" [] in - CS.flush c s; - Alcotest.(check response_promise) "Echo response 2" (Some (Ok (Response.v "got:c2"))) q2#response; - dec_ref q2; - dec_ref f0; - CS.flush c s; - CS.check_finished c s - -let test_cancel () = - let service = Services.manual () in - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags - (service :> Core_types.cap) in - let f0 = C.bootstrap c in - let q1 = call f0 "c1" [] in - let prom = q1#cap 0 in - dec_ref q1; (* Client doesn't cancel q1 because we're using prom *) - let _q2 = call prom "p1" [] in - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; (* [bs] resolves *) - S.handle_msg s ~expect:"call:c1"; - S.handle_msg s ~expect:"call:p1"; - S.handle_msg s ~expect:"finish"; (* bootstrap *) - let a1 = service#pop0 "c1" in - resolve_ok a1 "a1" []; - C.handle_msg c ~expect:"return:Invalid capability index!"; - C.handle_msg c ~expect:"return:a1"; - dec_ref f0; - CS.flush c s; - CS.check_finished c s - -(* Actually sends a cancel *) -let test_cancel_2 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let q1 = call bs "c1" [] in - dec_ref q1; (* Client cancels *) - S.handle_msg s ~expect:"call:c1"; - S.handle_msg s ~expect:"finish"; (* cancel *) - let a1 = service#pop0 "c1" in - let echo = Services.echo_service () in - resolve_ok a1 "a1" [echo]; - C.handle_msg c ~expect:"return:(cancelled)"; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -(* Don't forget to release the returned cap if the question was cancelled. *) -let test_cancel_3 () = - let service = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags - ~server_tags:Test_utils.server_tags service + Alcotest.check config_result "Unix, same address" expected config; + let expected = + Result.ok (`Ok (Capnp_rpc_unix.Vat_config.create + ~secret_key:(`File "key.pem") + ~public_address:(`TCP ("1.2.3.4", 7001)) + (`TCP ("0.0.0.0", 7000)))) in - let proxy_to_service = C.bootstrap c in - let q1 = call proxy_to_service "q1" [] in - S.handle_msg s ~expect:"bootstrap"; - S.handle_msg s ~expect:"call:q1"; - resolve_ok (service#pop0 "q1") "reply" [Core_types.null]; - C.handle_msg c ~expect:"return:(boot)"; - dec_ref q1; - C.handle_msg c ~expect:"return:reply"; - dec_ref proxy_to_service; - CS.flush c s; - CS.check_finished c s - -(* Asking for the same field twice gives the same object. *) -let test_duplicates () = - let service = Services.manual () in - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags - (service :> Core_types.cap) in - let f0 = C.bootstrap c in - let q1 = call f0 "c1" [] in - dec_ref f0; - let x1 = q1#cap 0 in - let x2 = q1#cap 0 in - dec_ref q1; - assert (x1 = x2); - dec_ref x1; - dec_ref x2; - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; (* [bs] resolves *) - S.handle_msg s ~expect:"call:c1"; - S.handle_msg s ~expect:"finish"; (* bootstrap question *) - S.handle_msg s ~expect:"release"; (* bootstrap cap *) - let a1 = service#pop0 "c1" in - resolve_ok a1 "a1" []; - C.handle_msg c ~expect:"return:a1"; - S.handle_msg s ~expect:"finish"; (* c1 *) - CS.check_finished c s - -(* Exporting a cap twice reuses the existing export. *) -let test_single_export () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let local = Services.echo_service () in - let q1 = call bs "q1" [local; local] in - let q2 = call bs "q2" [local] in - Alcotest.(check int) "One export" 1 (C.stats c).n_exports; - S.handle_msg s ~expect:"call:q1"; - S.handle_msg s ~expect:"call:q2"; - dec_ref q1; - dec_ref q2; - let ignore msg = - let got, a = service#pop_n msg in - RO_array.iter dec_ref got; - resolve_ok a "a" [] + Cmdliner.Cmd.eval_value ~argv:[| "main"; + "--capnp-secret-key-file=key.pem"; + "--capnp-public-address"; "tcp:1.2.3.4:7001"; + "--capnp-listen-address"; "tcp:0.0.0.0:7000" |] term + |> Alcotest.check config_result "Using TCP" expected + +let expect_ok = function + | Error (`Msg m) -> Alcotest.fail m + | Ok x -> x + +let test_sturdy_uri () = + let module Address = Capnp_rpc_unix.Network.Address in + let address = (module Address : Alcotest.TESTABLE with type t = Address.t) in + let sturdy_ref = Alcotest.pair address Alcotest.string in + let check msg expected_uri sr = + let uri = Address.to_uri sr in + Alcotest.(check string) msg expected_uri (Uri.to_string uri); + let sr2 = Address.parse_uri uri |> expect_ok in + Alcotest.check sturdy_ref msg sr sr2 in - ignore "q1"; - ignore "q2"; - dec_ref local; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -(* Exporting a field of a remote promise sends a promised answer desc. *) -let test_shorten_field () = - let service = Services.manual () in - let logger = Services.logger () in - let c, s, bs = init_pair ~bootstrap_service:service in - let q1 = call bs "q1" [] in - let proxy_to_logger = q1#cap 0 in - let q2 = call bs "q2" [proxy_to_logger] in - S.handle_msg s ~expect:"call:q1"; - let a1 = service#pop0 "q1" in - resolve_ok a1 "a1" [logger]; - S.handle_msg s ~expect:"call:q2"; - let direct_to_logger, a2 = service#pop1 "q2" in - assert (direct_to_logger#shortest = (logger :> Core_types.cap)); - resolve_ok a2 "a2" []; - dec_ref direct_to_logger; - dec_ref bs; - dec_ref proxy_to_logger; - dec_ref q1; - dec_ref q2; - CS.flush c s; - CS.check_finished c s - -let ensure_is_cycle_error (x:#Core_types.struct_ref) : unit = - match x#response with - | Some (Error (`Exception ex)) - when (String.is_prefix ~affix:"Attempt to create a cycle detected:" ex.Exception.reason) -> () - | _ -> Alcotest.fail (Fmt.str "Not a cycle error: %t" x#pp) - -let ensure_is_cycle_error_cap cap = - match cap#problem with - | Some ex when (String.is_prefix ~affix:" () - | _ -> Alcotest.fail (Fmt.str "Not a cycle error: %t" cap#pp) - -let test_cycle () = - (* Cap cycles *) - let module P = Testbed.Capnp_direct.Cap_proxy in - let p1 = P.local_promise () in - let p2 = P.local_promise () in - p1#resolve (p2 :> Core_types.cap); - p2#resolve (p1 :> Core_types.cap); - ensure_is_cycle_error (call p2 "test" []); - (* Connect struct to its own field *) - let p1, p1r = Local_struct_promise.make () in - let c = p1#cap 0 in - inc_ref c; - resolve_ok p1r "msg" [c]; - ensure_is_cycle_error_cap c; - dec_ref c; - dec_ref p1; - (* Connect struct to itself *) - let p1, p1r = Local_struct_promise.make () in - p1r#resolve p1; - ensure_is_cycle_error p1; - dec_ref p1 - -(* Resolve a promise with an answer that includes the result of a pipelined - call on the promise itself. *) -let test_cycle_2 () = - let s1, s1r = Local_struct_promise.make () in - let s2 = call (s1#cap 0) "get-s2" [] in - resolve_ok s1r "a7" [s2#cap 0]; - ensure_is_cycle_error_cap (s1#cap 0); - dec_ref s2; - dec_ref s1 - -(* It's not a cycle if one field resolves to another. *) -let test_cycle_3 () = - let echo = Services.echo_service () in - let a1, a1r = Local_struct_promise.make () in - resolve_ok a1r "a1" [a1#cap 1; (echo :> Core_types.cap)]; - let target = a1#cap 1 in - let q2 = call target "q2" [] in - Alcotest.(check response_promise) "Field 1 OK" - (Some (Ok (Response.v "got:q2"))) - q2#response; - dec_ref q2; - dec_ref target; - dec_ref a1 - -(* Check ref-counting when resolving loops. *) -let test_cycle_4 () = - let echo = Services.echo_service () in - let a1, a1r = Local_struct_promise.make () in - let f0 = a1#cap 0 in - resolve_ok a1r "a1" [a1#cap 1; (echo :> Core_types.cap)]; - dec_ref f0; - dec_ref a1; - Logs.info (fun f -> f "echo = %t" echo#pp); - Alcotest.(check bool) "Echo released" true echo#released - -(* A field depends on the struct. *) -let test_cycle_5 () = - let a, ar = Local_struct_promise.make () in - let b, br = Local_struct_promise.make () in - let c, cr = Local_struct_promise.make () in - Alcotest.(check (result unit reject)) "Not a cycle" (Ok ()) @@ br#set_blocker (c :> Core_types.base_ref); - Alcotest.(check (result unit reject)) "Not a cycle" (Ok ()) @@ cr#set_blocker (a :> Core_types.base_ref); - let b0 = b#cap 0 in - let reply = - Response.v "reply" - |> Core_types.Response_payload.with_caps (RO_array.of_list [b0]) + let sr = (`Unix "/sock", Auth.Digest.insecure), "" in + check "Insecure Unix" "capnp://insecure@/sock/" sr; + let sr = (`TCP ("localhost", 7000), Auth.Digest.insecure), "" in + check "Insecure TCP" "capnp://insecure@localhost:7000" sr; + let test_uri = Uri.of_string "capnp://sha-256:s16WV4JeGusAL_nTjvICiQOFqm3LqYrDj3K-HXdMi8s@/" in + let auth = Auth.Digest.from_uri test_uri |> expect_ok in + let sr = (`TCP ("localhost", 7000), auth), "main" in + check "Secure TCP" "capnp://sha-256:s16WV4JeGusAL_nTjvICiQOFqm3LqYrDj3K-HXdMi8s@localhost:7000/bWFpbg" sr; + let sr = (`Unix "/sock", auth), "main" in + check "Secure Unix" "capnp://sha-256:s16WV4JeGusAL_nTjvICiQOFqm3LqYrDj3K-HXdMi8s@/sock/bWFpbg" sr + +let test_sturdy_self ~net = + let service = Echo.local () in + Capability.inc_ref service; + with_vats ~net ~serve_tls:true ~service @@ fun cs -> + let id = Restorer.Id.public "" in + let sr = Vat.sturdy_uri cs.server id |> Vat.import_exn cs.server in + let service2 = Sturdy_ref.connect_exn sr in + Alcotest.check cap "Restore from same vat" service service2; + Capability.dec_ref service2; + Capability.dec_ref service + +let expect_non_exn = function + | Ok x -> x + | Error ex -> Alcotest.failf "expect_non_exn: %a" Capnp_rpc.Exception.pp ex + +let except = Alcotest.testable Capnp_rpc.Exception.pp (=) +let except_ty = Alcotest.testable Capnp_rpc.Exception.pp_ty (=) + +let test_table_restorer ~net:_ = + Switch.run @@ fun sw -> + let make_sturdy id = Uri.make ~path:(Restorer.Id.to_string id) () in + let table = Restorer.Table.create make_sturdy in + let echo_id = Restorer.Id.public "echo" in + let registry_id = Restorer.Id.public "registry" in + let broken_id = Restorer.Id.public "broken" in + let unknown_id = Restorer.Id.public "unknown" in + Restorer.Table.add table echo_id @@ Echo.local (); + Restorer.Table.add table registry_id @@ Registry.local ~sw (); + Restorer.Table.add table broken_id @@ Capability.broken (Capnp_rpc.Exception.v "broken"); + let r = Restorer.of_table table in + let a1 = Restorer.restore r echo_id |> expect_non_exn in + let reply = Echo.ping a1 "ping" in + Alcotest.(check string) "Ping response" "got:0:ping" reply; + let a2 = Restorer.restore r echo_id |> expect_non_exn in + Alcotest.check cap "Same cap" a1 a2; + let r1 = Restorer.restore r registry_id |> expect_non_exn in + assert (a1 <> r1); + let x = Restorer.restore r broken_id |> expect_non_exn in + let expected = Some (Capnp_rpc.Exception.v "broken") in + Alcotest.(check (option except)) "Broken response" expected (Capability.problem x); + let x = Restorer.restore r unknown_id in + let expected = Error (Capnp_rpc.Exception.v "Unknown persistent service ID") in + Alcotest.(check (result reject except)) "Missing mapping" expected x; + Capability.dec_ref a1; + Capability.dec_ref a2; + Capability.dec_ref r1; + Restorer.Table.remove table echo_id; + Restorer.Table.clear table + +module Loader = struct + type t = string -> Restorer.resolution + + let hash _ = `SHA256 + let make_sturdy _ id = Uri.make ~path:(Restorer.Id.to_string id) () + let load t _sr digest = t digest +end + +let test_fn_restorer ~net:_ = + Switch.run @@ fun sw -> + let cap = Alcotest.testable Capability.pp (=) in + let a = Restorer.Id.public "a" in + let b = Restorer.Id.public "b" in + let c = Restorer.Id.public "c" in + let current_c = ref (Restorer.reject (Exception.v "Broken C")) in + let delay = Eio.Condition.create () in + let digest = Restorer.Id.digest (Loader.hash ()) in + let load d = + if d = digest a then Restorer.grant @@ Echo.local () + else if d = digest b then (Eio.Condition.await_no_mutex delay; Restorer.grant @@ Echo.local ()) + else if d = digest c then (Eio.Condition.await_no_mutex delay; !current_c) + else Restorer.unknown_service_id in - let x = Core_types.return reply in - ar#resolve x; - Logs.info (fun f -> f "a = %t" a#pp); - ensure_is_cycle_error_cap (a#cap 0); - dec_ref a - -(* A blocker depends on itself. *) -let test_cycle_6 () = - let a, ar = Local_struct_promise.make () in - let a0 = a#cap 0 in - a0#call ar (Request.v "loop"); - Logs.info (fun f -> f "a0 = %t" a#pp) - -(* The server returns an answer containing a promise. Later, it resolves the promise - to a resource at the client. The client must be able to invoke the service locally. *) -let test_resolve () = - let service = Services.manual () in - let client_logger = Services.logger () in - let c, s, proxy_to_service = init_pair ~bootstrap_service:service in - (* The client makes a call and gets a reply, but the reply contains a promise. *) - let q1 = call proxy_to_service "q1" [client_logger] in - dec_ref proxy_to_service; - S.handle_msg s ~expect:"call:q1"; - let proxy_to_logger, a1 = service#pop1 "q1" in - let promise = Cap_proxy.local_promise () in - inc_ref promise; - resolve_ok a1 "a1" [promise]; - C.handle_msg c ~expect:"return:a1"; - (* The server now resolves the promise *) - promise#resolve proxy_to_logger; - dec_ref promise; - CS.flush c s; - (* The client can now use the logger directly *) - let x = q1#cap 0 in - let q2 = call x "test-message" [] in - Alcotest.(check string) "Got message directly" "test-message" client_logger#pop; - dec_ref x; - dec_ref q1; - dec_ref q2; - dec_ref client_logger; - CS.flush c s; - CS.check_finished c s - -(* The server resolves an export after the client has released it. - The client releases the new target. *) -let test_resolve_2 () = - let service = Services.manual () in - let client_logger = Services.logger () in - let c, s, proxy_to_service = init_pair ~bootstrap_service:service in - (* The client makes a call and gets a reply, but the reply contains a promise. *) - let q1 = call proxy_to_service "q1" [client_logger] in - dec_ref client_logger; - dec_ref proxy_to_service; - S.handle_msg s ~expect:"call:q1"; - let proxy_to_logger, a1 = service#pop1 "q1" in - let promise = Cap_proxy.local_promise () in - resolve_ok a1 "a1" [promise]; - C.handle_msg c ~expect:"return:a1"; - (* The client doesn't care about the result and releases it *) - dec_ref q1; - (* The server now resolves the promise. The client must release the new target. *) - promise#resolve proxy_to_logger; - CS.flush c s; - CS.check_finished c s - -(* The server returns a promise, but by the time it resolves the server - has removed the export. It must not send a resolve message. *) -let test_resolve_3 () = - let service = Services.manual () in - let c, s, proxy_to_service = init_pair ~bootstrap_service:service in - (* Make a call, get a promise, and release it *) - let q1 = call proxy_to_service "q1" [] in - S.handle_msg s ~expect:"call:q1"; - let a1 = service#pop0 "q1" in - let a1_promise = Cap_proxy.local_promise () in - inc_ref a1_promise; - resolve_ok a1 "a1" [a1_promise]; - C.handle_msg c ~expect:"return:a1"; - dec_ref q1; - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"release"; - (* Make another call, get a settled export this time. *) - let q2 = call proxy_to_service "q2" [] in - S.handle_msg s ~expect:"call:q2"; - CS.flush c s; - let a2 = service#pop0 "q2" in - let echo = Services.echo_service () in - inc_ref echo; - resolve_ok a2 "a2" [echo]; - C.handle_msg c ~expect:"return:a2"; - (* Service now resolves first answer *) - a1_promise#resolve (echo :> Core_types.cap); - dec_ref a1_promise; - dec_ref proxy_to_service; - CS.flush c s; - dec_ref q2; - CS.flush c s; - CS.check_finished c s - -(* Resolving a remote's export to another export, which we haven't seen yet. - We must add the new import to the table before looking it up to set the - disembargo target. *) -let test_resolve_4 () = - let service = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags - ~server_tags:Test_utils.server_tags service + let table = Restorer.Table.of_loader ~sw (module Loader) load in + let restorer = Restorer.of_table table in + let restore x = Restorer.restore restorer x in + (* Check that restoring the same ID twice caches the capability. *) + let a1 = restore a |> expect_non_exn in + let a2 = restore a |> expect_non_exn in + Alcotest.check cap "Restore cached" a1 a2; + Capability.dec_ref a1; + Capability.dec_ref a2; + (* But if it's released, the next lookup loads a fresh one. *) + let a3 = restore a |> expect_non_exn in + if a1 = a3 then Alcotest.fail "Returned released cap!"; + Capability.dec_ref a3; + (* Doing two lookups in parallel only does one load. *) + let b1 = Fiber.fork_promise ~sw (fun () -> restore b) in + let b2 = Fiber.fork_promise ~sw (fun () -> restore b) in + assert (Promise.peek b1 = None); + Eio.Condition.broadcast delay; + let b1 = Promise.await_exn b1 |> expect_non_exn in + let b2 = Promise.await_exn b2 |> expect_non_exn in + Alcotest.check cap "Restore delayed cached" b1 b2; + Restorer.Table.clear table; (* (should have no effect) *) + Capability.dec_ref b1; + Capability.dec_ref b2; + (* Failed lookups aren't cached. *) + let c1 = Fiber.fork_promise ~sw (fun () -> restore c) in + Eio.Condition.broadcast delay; + let c1 = Promise.await_exn c1 in + let reject = Alcotest.result cap except in + Alcotest.check reject "C initially fails" (Error (Exception.v "Broken C")) c1; + let c2 = Fiber.fork_promise ~sw (fun () -> restore c) in + let c_service = Echo.local () in + current_c := Restorer.grant c_service; + Eio.Condition.broadcast delay; + let c2 = Promise.await_exn c2 |> expect_non_exn in + Alcotest.check cap "C now works" c_service c2; + Capability.dec_ref c2; + (* Two users; one frees the cap immediately *) + let b1 = + Fiber.fork_promise ~sw @@ fun () -> + restore b |> expect_non_exn |> fun b1 -> + Capability.dec_ref b1; + b1 in - let to_server = C.bootstrap c in - let x = Cap_proxy.local_promise () in - let q1 = call to_server "q1" [x] in - x#resolve (Services.manual () :> Core_types.cap); - CS.flush c s; - let to_x, a1 = service#pop1 "q1" in - resolve_ok a1 "a1" []; - dec_ref to_x; - dec_ref q1; - dec_ref x; - dec_ref to_server; - CS.flush c s; - CS.check_finished c s - -(* Finishing a question releases multiple imports *) -let test_resolve_5 () = - let service = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags - ~server_tags:Test_utils.server_tags service + let b2 = Fiber.fork_promise ~sw (fun () -> restore b) in + Eio.Condition.broadcast delay; + let b1 = Promise.await_exn b1 in + let b2 = Promise.await_exn b2 |> expect_non_exn in + Alcotest.check cap "Cap not freed" b1 b2; + Capability.dec_ref b2 + +let test_broken ~net = + with_vats ~net ~service:(Echo.local ()) @@ fun cs -> + let service = get_bootstrap cs in + Echo.ping service "ping" |> Alcotest.(check string) "Ping response" "got:0:ping"; + let problem, set_problem = Promise.create () in + Capability.when_broken (fun x -> Promise.resolve set_problem x) service; + Alcotest.check (Alcotest.option except) "Still OK" None @@ Capability.problem service; + assert (Promise.peek problem = None); + Logs.info (fun f -> f "Turning off server..."); + cs.server_cancel (); + let problem = Promise.await problem in + Alcotest.check except_ty "Broken callback ran" `Disconnected problem.ty; + assert (Capability.problem service <> None); + try + ignore (Echo.ping service "ping" : string); + Alcotest.fail "Should have failed!" + with Failure _ -> + Capability.dec_ref service + +(* [when_broken] follows promises. *) +let test_broken2 () = + let promise, resolver = Capability.promise () in + let problem = ref None in + Capability.when_broken (fun x -> problem := Some x) promise; + let p2, r2 = Capability.promise () in + Capability.resolve_ok resolver p2; + Alcotest.check (Alcotest.option except) "No problem yet" None !problem; + let ex = Exception.v "Test" in + Capability.resolve_ok r2 (Capability.broken ex); + Alcotest.check (Alcotest.option except) "Now broken" (Some ex) !problem; + () + +let test_broken3 () = + let ex = Exception.v "Test" in + let c = Capability.broken ex in + let problem = ref None in + Capability.when_broken (fun x -> problem := Some x) c; + Alcotest.check (Alcotest.option except) "Broken immediately" (Some ex) !problem + +let test_broken4 () = + let promise, _resolver = Capability.promise () in + let problem = ref None in + Capability.when_broken (fun x -> problem := Some x) promise; + Capability.dec_ref promise; + Alcotest.check (Alcotest.option except) "Released, not called" None !problem + +let test_parallel_connect ~net = + with_vats ~net ~serve_tls:true ~service:(Echo.local ()) @@ fun cs -> + let/ service () = get_bootstrap cs + and/ service2 () = get_bootstrap cs in + Capability.await_settled_exn service; + Capability.await_settled_exn service2; + Alcotest.check cap "Shared connection" service service2; + Capability.dec_ref service; + Capability.dec_ref service2 + +let test_parallel_fails ~net = + with_vats ~net ~serve_tls:true ~service:(Echo.local ()) @@ fun cs -> + let/ service () = get_bootstrap cs + and/ service2 () = get_bootstrap cs in + cs.server_cancel (); + ignore (Capability.await_settled service : _ result); + ignore (Capability.await_settled service2 : _ result); + Alcotest.check cap "Shared failure" service service2; + Capability.dec_ref service; + Capability.dec_ref service2; + (* Restart server (ignore new client) *) + Fiber.yield (); + with_vats ~net ~serve_tls:true ~service:(Echo.local ()) @@ fun cs -> + let service = get_bootstrap cs in + Echo.ping service "ping" |> Alcotest.(check string) "Ping response" "got:0:ping"; + Capability.dec_ref service + +let test_crossed_calls ~net = + (* Would be good to control the ordering here, to test the various cases. + Currently, it's not certain which path is actually tested. *) + Switch.run @@ fun sw -> + let id = Restorer.Id.public "" in + let make_vat ~secret_key ~tags addr = + let service = Echo.local () in + let restore = Restorer.(single id) service in + let config = + let secret_key = `PEM (Auth.Secret_key.to_pem_data secret_key) in + let name = Fmt.str "capnp-rpc-test-%s" addr in + Capnp_rpc_unix.Vat_config.create ~secret_key (get_test_address name) + in + let vat = Capnp_rpc_unix.serve ~net ~sw ~tags ~restore config in + Switch.on_release sw (fun () -> Capability.dec_ref service); + vat in - let promise = Cap_proxy.local_promise () in - let to_service = C.bootstrap c in - let q1 = call to_service "q1" [promise] in - S.handle_msg s ~expect:"bootstrap"; - S.handle_msg s ~expect:"call:q1"; - let to_promise, a1 = service#pop1 "q1" in - resolve_ok a1 "a1" [to_promise]; - C.handle_msg c ~expect:"return:(boot)"; - promise#resolve (Services.manual () :> Core_types.cap); - C.handle_msg c ~expect:"return:a1"; - S.handle_msg s ~expect:"finish"; (* Bootstrap *) - S.handle_msg s ~expect:"resolve"; - S.handle_msg s ~expect:"finish"; - dec_ref q1; - dec_ref to_service; - dec_ref promise; - CS.flush c s; - CS.check_finished c s - -(* When a proxy is released it must be removed from the import, - which may need to hang around for forwarding. *) -let test_resolve_6 () = - let client_bs = Services.manual () in - let server_bs = Services.manual () in - let c, s = CS.create - ~client_tags:Test_utils.client_tags ~client_bs - ~server_tags:Test_utils.server_tags server_bs + let client = make_vat ~secret_key:(Lazy.force client_key) ~tags:Test_utils.client_tags "client" in + let server = make_vat ~secret_key:(Lazy.force server_key) ~tags:Test_utils.server_tags "server" in + let sr_to_client = Capnp_rpc_unix.Vat.sturdy_uri client id |> Vat.import_exn server in + let sr_to_server = Capnp_rpc_unix.Vat.sturdy_uri server id |> Vat.import_exn client in + let/ to_client () = Sturdy_ref.connect_exn sr_to_client + and/ to_server () = Sturdy_ref.connect_exn sr_to_server in + Logs.info (fun f -> f ~tags:Test_utils.client_tags "%a" Capnp_rpc_unix.Vat.dump client); + Logs.info (fun f -> f ~tags:Test_utils.server_tags "%a" Capnp_rpc_unix.Vat.dump server); + let/ s_got () = Echo.ping_result to_client "ping" + and/ c_got () = Echo.ping_result to_server "ping" in + let c_got, s_got = + match c_got, s_got with + | Ok x, Ok y -> (x, y) + | Ok x, Error (`Capnp e) -> + (* Server got an error. Try client again. *) + Logs.info (fun f -> f ~tags:Test_utils.server_tags "%a" Capnp_rpc.Error.pp e); + let to_client = Sturdy_ref.connect_exn sr_to_client in + Capability.with_ref to_client @@ fun to_client -> + Echo.ping to_client "ping" |> fun s_got -> (x, s_got) + | Error (`Capnp e), Ok y -> + (* Client got an error. Try server again. *) + Logs.info (fun f -> f ~tags:Test_utils.client_tags "%a" Capnp_rpc.Error.pp e); + let to_server = Sturdy_ref.connect_exn sr_to_server in + Capability.with_ref to_server @@ fun to_server -> + Echo.ping to_server "ping" |> fun c_got -> (c_got, y) + | Error (`Capnp e1), Error (`Capnp e2) -> + Fmt.failwith "@[Both connections failed!@,%a@,%a@]" + Capnp_rpc.Error.pp e1 + Capnp_rpc.Error.pp e2 in - let to_server = C.bootstrap c in - let to_client = S.bootstrap s in - CS.flush c s; - let x = call_for_cap to_server "q1" [] in - let y = call_for_cap to_client "q2" [] in - S.handle_msg s ~expect:"call:q1"; - resolve_ok (server_bs#pop0 "q1") "a1" [to_client; Core_types.null]; - C.handle_msg c ~expect:"call:q2"; - resolve_ok (client_bs#pop0 "q2") "a2" [x]; - C.handle_msg c ~expect:"return:a1"; - C.handle_msg c ~expect:"resolve"; - S.handle_msg s ~expect:"return:a2"; - C.handle_msg c ~expect:"finish"; - S.handle_msg s ~expect:"finish"; - S.handle_msg s ~expect:"release"; - dec_ref y; - dec_ref to_server; - CS.flush c s; - CS.check_finished c s - -let test_resolve_7 () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let promise, resolver = Local_struct_promise.make () in - let bs_promise = promise#cap 0 in (* Local promise *) - let x1 = call_for_cap bs_promise "q1" [] in (* Never resolves *) - let x2 = call_for_cap bs_promise "q2" [] in (* Will resolve to null *) - let q3 = call x1 "q3" [x2] in - let q4 = call bs "q4" [x2] in - (* Resolving [bs_promise] to [bs] sends q1, q3 and q2 over the network. - [x2] is marked as blocked on [bs_promise], but [bs_promise] is no longer blocked. - Must not misinterpret this as [x2] being sender-hosted (not blocked on anything)! *) - resolve_ok resolver "reply" [bs]; - Logs.info (fun f -> f "bs=%t" bs#pp); - S.handle_msg s ~expect:"call:q4"; - let to_x2, a4 = service#pop1 "q4" in - dec_ref to_x2; - CS.flush c s; - let a1 = service#pop0 "q1" in - let a2 = service#pop0 "q2" in - resolve_ok a2 "reply" [Core_types.null]; - CS.dump c s; - CS.flush c s; - (* Clean up *) - resolve_ok a1 "a1" []; - resolve_ok a4 "a4" []; - dec_ref x1; - dec_ref x2; - dec_ref q3; - dec_ref q4; - dec_ref bs_promise; - dec_ref promise; - CS.flush c s; - CS.check_finished c s - -(* Returning an already-broken capability. *) -let test_broken_return () = - let err = Exception.v "Broken" in - let broken = Core_types.broken_cap err in - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags broken in - let bs = C.bootstrap c in - Alcotest.check (Alcotest.option exn) "Initially a promise" None bs#problem; - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; - C.handle_msg c ~expect:"resolve"; - S.handle_msg s ~expect:"finish"; - Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) bs#problem; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -let test_broken_call () = - let err = Exception.v "Broken" in - let broken = Core_types.broken_cap err in - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let q1 = call bs "q1" [broken] in - S.handle_msg s ~expect:"call:q1"; - let broken_proxy, a1 = service#pop1 "q1" in - Alcotest.check (Alcotest.option exn) "Initially a promise" None broken_proxy#problem; - S.handle_msg s ~expect:"resolve"; - Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) broken_proxy#problem; - resolve_ok a1 "a1" []; - dec_ref broken_proxy; - dec_ref bs; - dec_ref q1; - CS.flush c s; - CS.check_finished c s - -(* Server returns a capability reference that later breaks. *) -let test_broken_later () = - let err = Exception.v "Broken" in - let broken = Core_types.broken_cap err in - let promise = Cap_proxy.local_promise () in - let c, s = CS.create ~client_tags:Test_utils.client_tags ~server_tags:Test_utils.server_tags promise in - let bs = C.bootstrap c in - Alcotest.check (Alcotest.option exn) "Initially a promise" None bs#problem; - S.handle_msg s ~expect:"bootstrap"; - C.handle_msg c ~expect:"return:(boot)"; - S.handle_msg s ~expect:"finish"; - (* Server breaks promise *) - promise#resolve broken; - C.handle_msg c ~expect:"resolve"; - Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) bs#problem; - dec_ref bs; - CS.flush c s; - CS.check_finished c s - -let test_broken_connection () = - let service = Services.echo_service () in - let c, s, bs = init_pair ~bootstrap_service:service in - let q1 = call bs "Message-1" [] in - CS.flush c s; - Alcotest.check response_promise "Echo reply" - (Some (Ok (Response.v "got:Message-1"))) - q1#response; - dec_ref q1; - let err = Exception.v "Connection lost" in - C.disconnect c err; - S.disconnect s err; - Alcotest.check (Alcotest.option exn) "Resolves to broken" (Some err) bs#problem; - dec_ref bs - -let test_ref_counts () = - let objects = Hashtbl.create 3 in - let make () = - let o = object (self) - inherit Core_types.service - val id = Capnp_rpc.Debug.OID.next () - method call results _ = Core_types.resolve_ok results (Response.v "answer") - method! private release = Hashtbl.remove objects self - method! pp f = Fmt.pf f "Service(%a, %t)" Capnp_rpc.Debug.OID.pp id self#pp_refcount - end in - Hashtbl.add objects o true; - o + Alcotest.(check string) "Client's ping response" "got:0:ping" c_got; + Alcotest.(check string) "Server's ping response" "got:0:ping" s_got; + Capability.dec_ref to_client; + Capability.dec_ref to_server + +(* Run test_crossed_calls several times to try to trigger the various behaviours. *) +let test_crossed_calls ~net () = + for _ = 1 to 10 do + test_crossed_calls ~net + done + +let test_store ~net = + Switch.run @@ fun sw -> + (* Persistent server configuration *) + let db = Store.DB.create () in + let config = + let addr = get_test_address "capnp-rpc-test-server" in + Capnp_rpc_unix.Vat_config.create ~secret_key:(Lazy.force server_pem) addr in - (* Test structs and fields *) - let promise, resolver = Local_struct_promise.make () in - let f0 = promise#cap 0 in - f0#when_more_resolved dec_ref; - let fields = [f0; promise#cap 1] in - resolve_ok resolver "ok" [make (); make ()]; - let fields2 = [promise#cap 0; promise#cap 2] in - dec_ref promise; - List.iter dec_ref fields; - List.iter dec_ref fields2; - Alcotest.(check int) "Fields released" 0 (Hashtbl.length objects); - (* With pipelining *) - let promise, resolver = Local_struct_promise.make () in - let f0 = promise#cap 0 in - let q1 = call f0 "q1" [] in - f0#when_more_resolved dec_ref; - resolve_ok resolver "ok" [make ()]; - dec_ref f0; - dec_ref promise; - dec_ref q1; - Alcotest.(check int) "Fields released" 0 (Hashtbl.length objects); - (* Test local promise *) - let promise = Cap_proxy.local_promise () in - promise#when_more_resolved dec_ref; - promise#resolve (make ()); - dec_ref promise; - Alcotest.(check int) "Local promise released" 0 (Hashtbl.length objects); - Gc.full_major () - -module Level0 = struct - (* Client is level 0, server is level 1. - We don't have a level 0 implementation, so we'll do it manually. - Luckily, level 0 is very easy. *) - - type t = { - from_server : [S.EP.Out.t | `Unimplemented of S.EP.In.t] Queue.t; - to_server : [S.EP.In.t | `Unimplemented of S.EP.Out.t] Queue.t; - } - - let send t m = Queue.add m t.to_server - - let qid_of_int x = S.EP.In.QuestionId.of_uint32 (Stdint.Uint32.of_int x) - - let init ~bootstrap = - let from_server = Queue.create () in - let to_server = Queue.create () in - let c = { from_server; to_server } in - let s = S.create ~tags:Test_utils.server_tags from_server to_server ~bootstrap in - send c @@ `Bootstrap (qid_of_int 0, ""); - S.handle_msg s ~expect:"bootstrap"; - send c @@ `Finish (qid_of_int 0, false); - S.handle_msg s ~expect:"finish"; - let bs = - match Queue.pop from_server with - | `Return (_, `Results (_, caps), false) -> - begin match RO_array.get_exn caps 0 with - | `SenderHosted id -> id - | _ -> assert false - end - | _ -> assert false - in - c, s, bs - - let expect t expected = - match Queue.pop t.from_server with - | msg -> Alcotest.(check string) "Read message from server" expected (Testbed.Connection.summary_of_msg msg) - | exception Queue.Empty -> Alcotest.fail "No messages found!" - - let expect_bs t = - let bs_request = Queue.pop t.from_server in - match bs_request with - | `Bootstrap (qid, "") -> qid - | _ -> Alcotest.fail (Fmt.str "Expecting bootstrap, got %s" (Testbed.Connection.summary_of_msg bs_request)) - - let expect_call t expected = - match Queue.pop t.from_server with - | `Call (qid, _, msg, _, _) -> - Alcotest.(check string) "Get call" expected @@ Request.data msg; - qid - | request -> Alcotest.fail (Fmt.str "Expecting call, got %s" (Testbed.Connection.summary_of_msg request)) - - let call t target ~qid msg = - send t @@ `Call (qid_of_int qid, `ReceiverHosted target, Request.v msg, RO_array.empty, `Caller) - - let finish t ~qid = - send t @@ `Finish (qid_of_int qid, true) -end - -(* Pretend that the peer only supports level 0, and therefore - sets the auto-release flags. *) -let test_auto_release () = - let service = Services.manual () in - let c, s, bs = Level0.init ~bootstrap:service in - let send = Level0.send c in - (* Client makes a call. *) - Level0.call c ~qid:0 bs "q0"; - S.handle_msg s ~expect:"call:q0"; - (* Server replies with some caps, which the client doesn't understand. *) - let a0 = service#pop0 "q0" in - let echo_service = Services.echo_service () in - resolve_ok a0 "a0" [echo_service]; - Level0.expect c "return:a0"; - (* Client asks it to drop all caps *) - Level0.finish c ~qid:0; - S.handle_msg s ~expect:"finish"; - Alcotest.(check bool) "Echo released" true echo_service#released; - (* Now test the other direction. Service invokes bootstap on client. *) - let proxy_to_client = S.bootstrap s in - let logger = Services.logger () in - let q1 = call proxy_to_client "q1" [logger] in - dec_ref logger; - let bs_qid = Level0.expect_bs c in - let client_bs_id = S.EP.In.ExportId.zero in - send @@ `Return (bs_qid, `Results (Response.v "bs", RO_array.of_list [`SenderHosted client_bs_id]), true); - let q1_qid = Level0.expect_call c "q1" in - send @@ `Return (q1_qid, `Results (Response.v "a1", RO_array.empty), true); - S.handle_msg s ~expect:"return:bs"; - S.handle_msg s ~expect:"return:a1"; - Alcotest.(check bool) "Logger released" true logger#released; - dec_ref proxy_to_client; - (* Clean up. - A real level-0 client would just disconnect, but release cleanly so we can - check nothing else was leaked. *) - dec_ref q1; - send @@ `Release (S.EP.Out.ExportId.zero, 1); - S.handle_msg s ~expect:"release"; - try S.check_finished s ~name:"Server" - with ex -> - Logs.err (fun f -> f "Error: %a@\n%a" Fmt.exn ex S.dump s); - raise ex - -(* We send a resolve to a level 0 implementation, which echoes it back as - "unimplemented". We release the cap. *) -let test_unimplemented () = - let service = Services.manual () in - let c, s, bs = Level0.init ~bootstrap:service in - (* The client makes a call on [service] and gets back a promise. *) - Level0.call c ~qid:0 bs "q0"; - S.handle_msg s ~expect:"call:q0"; - let a0 = service#pop0 "q0" in - let promise = Cap_proxy.local_promise () in - inc_ref promise; - resolve_ok a0 "a0" [promise]; - (* The server resolves the promise *) - let echo_service = Services.echo_service () in - promise#resolve (echo_service :> Core_types.cap); - dec_ref promise; - (* The client doesn't understand the resolve message. *) - Level0.expect c "return:a0"; - Level0.finish c ~qid:0; - S.handle_msg s ~expect:"finish"; - let resolve = - match Queue.pop c.from_server with - | `Resolve _ as r -> r - | _ -> assert false + let main_id = Restorer.Id.generate () in + let start_server ~sw () = + let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri config in + let table = Store.File.table ~sw ~make_sturdy db in + Switch.on_release sw (fun () -> Restorer.Table.clear table); + let restore = Restorer.of_table table in + let service = Store.local ~restore db in + Restorer.Table.add table main_id service; + Capnp_rpc_unix.serve ~sw ~net ~restore ~tags:Test_utils.server_tags config in - Level0.send c @@ `Unimplemented resolve; - S.handle_msg s ~expect:"unimplemented"; - (* The server releases the export. *) - Alcotest.(check bool) "Echo released" true echo_service#released; - (* The server tries to get the client's bootstrap object *) - let bs = S.bootstrap s in - let q2 = call bs "q2" [] in - (* The client doesn't support bootstrap or call *) - let bs_msg = - match Queue.pop c.from_server with - | `Bootstrap _ as bs -> bs - | _ -> assert false + (* Start server *) + let file, file_sr = + Switch.run (fun server_switch -> + let server = start_server ~sw:server_switch () in + let store_uri = Capnp_rpc_unix.Vat.sturdy_uri server main_id in + (* Set up client *) + let client = Capnp_rpc_unix.client_only_vat ~tags:Test_utils.client_tags ~sw net in + let sr = Capnp_rpc_unix.Vat.import_exn client store_uri in + Sturdy_ref.with_cap_exn sr @@ fun store -> + (* Try creating a file *) + let file = Store.create_file store in + Store.File.set file "Hello"; + let file_sr = Capnp_rpc.Persistence.save_exn file in + let file_sr = Vat.import_exn client file_sr in (* todo: get rid of this step *) + file, file_sr + ) in - Level0.send c @@ `Unimplemented bs_msg; - let call_msg = - match Queue.pop c.from_server with - | `Call _ as call -> call - | _ -> assert false + let broken, set_broken = Promise.create () in + Capability.when_broken (Promise.resolve set_broken) file; + ignore (Promise.await broken : Exception.t); + assert (Capability.problem file <> None); + (* Restart server *) + let _server = start_server ~sw () in + (* Reconnect client *) + Sturdy_ref.with_cap_exn file_sr @@ fun file -> + let data = Store.File.get file in + Alcotest.(check string) "Read file" "Hello" data + +let ( / ) = Eio.Path.( / ) + +let with_temp_dir path fn = + Eio.Path.mkdir path ~perm:0o700; + Fun.protect (fun () -> Eio.Path.with_open_dir path fn) + ~finally:(fun () -> Eio.Path.rmtree path) + +let test_file_store ~dir ~net:_ = + with_temp_dir (dir / "capnp-tests") @@ fun tmpdir -> + let module S = Capnp_rpc_unix.File_store in + let s = S.create tmpdir in + Alcotest.(check (option reject)) "Missing file" None @@ S.load s ~digest:"missing"; + let module Builder = Testlib.Api.Builder.Simple in + let module Reader = Testlib.Api.Reader.Simple in + let data = + let b = Builder.init_root () in + Builder.text_set b "Test"; + Builder.to_reader b in - Level0.send c @@ `Unimplemented call_msg; - S.handle_msg s ~expect:"unimplemented"; - S.handle_msg s ~expect:"unimplemented"; - dec_ref bs; - Alcotest.(check response_promise) "Server got error" - (Some (Error (Error.exn ~ty:`Unimplemented "Call message not implemented by peer!"))) - q2#response; - dec_ref q2; - (* Clean up. - A real level-0 client would just disconnect, but release cleanly so we can - check nothing else was leaked. *) - Level0.send c @@ `Release (S.EP.Out.ExportId.zero, 1); - S.handle_msg s ~expect:"release"; - try S.check_finished s ~name:"Server" - with ex -> - Logs.err (fun f -> f "Error: %a@\n%a" Fmt.exn ex S.dump s); - raise ex - -(* The client's only reference to an import is a callback on the import itself. - The import must not be released, even though the leak detector would normally - do that. *) -let test_import_callbacks () = - let service = Services.manual () in - let c, s, bs = init_pair ~bootstrap_service:service in - let q1 = call bs "q1" [] in - S.handle_msg s ~expect:"call:q1"; - let a1 = service#pop0 "q1" in - let promise = Cap_proxy.local_promise () in - resolve_ok a1 "a1" [promise]; - C.handle_msg c ~expect:"return:a1"; - let ok = - let r = ref "-" in - let f1 = q1#cap 0 in - f1#when_more_resolved (fun x -> - r := "resolved"; - dec_ref x; - dec_ref f1 - ); - r + S.save s ~digest:"!/.." data; + Alcotest.(check (option string)) "Restored" (Some "Test") @@ Option.map Reader.text_get (S.load s ~digest:"!/..") + +let capnp_error = Alcotest.of_pp Capnp_rpc.Exception.pp + +let test_await_settled ~net:_ = + (* Ok *) + Switch.run @@ fun sw -> + let p, r = Capability.promise () in + let check = Fiber.fork_promise ~sw (fun () -> Capability.await_settled p) in + Capability.resolve_ok r @@ Echo.local (); + let check = Promise.await_exn check in + Alcotest.(check (result unit capnp_error)) "Check await success" (Ok ()) check; + Capability.dec_ref p; + (* Error *) + let p, r = Capability.promise () in + let check = Fiber.fork_promise ~sw (fun () -> Capability.await_settled p) in + let err = Capnp_rpc.Exception.v "Test" in + Capability.resolve_exn r err; + let check = Promise.await_exn check in + Alcotest.(check (result unit capnp_error)) "Check await failure" (Error err) check + +(* The client disconnects before the server has finished loading the bootstrap object. *) +let test_late_bootstrap ~net = + Switch.run @@ fun sw -> + let connected, set_connected = Promise.create () in + let service, set_service = Promise.create () in + let module Loader = struct + type t = unit + let hash () = `SHA256 + let make_sturdy () _id = assert false + let load () _sr _name = + Promise.resolve set_connected (); + Promise.await service; + Capnp_rpc_net.Restorer.grant @@ Echo.local () + end in + let table = Capnp_rpc_net.Restorer.Table.of_loader ~sw (module Loader) () in + let restore = Restorer.of_table table in + let cs = make_vats_full ~sw ~restore ~net () in + let service = get_bootstrap cs in + Promise.await connected; + cs.client_cancel (); + let service = Capability.await_settled service |> Result.get_error in + Logs.info (fun f -> f "client got: %a" Capnp_rpc.Exception.pp service); + assert (service.Capnp_rpc.Exception.ty = `Disconnected); + Promise.resolve set_service (); + (* The restorer yields once before returning the cap, + so we wait too, to ensure it's done. *) + Fiber.yield () + +let test_listen_address () = + let location = Alcotest.of_pp Capnp_rpc_unix.Network.Location.pp in + let result = Alcotest.result location Alcotest.string in + let test expected s = + let x = Capnp_rpc_unix.Network.Location.of_string s |> Result.map_error (fun (`Msg m) -> m) in + Alcotest.check result s expected x in - dec_ref q1; - Gc.full_major (); - promise#resolve (Core_types.broken_cap (Capnp_rpc.Exception.v "broken")); - CS.flush c s; - dec_ref bs; - Alcotest.(check string) "ok set" "resolved" !ok; - CS.flush c s; - CS.check_finished c s - -let tests = [ - "Return", `Quick, test_return; - "Return error", `Quick, test_return_error; - "Connection", `Quick, test_simple_connection; - "Local embargo", `Quick, test_local_embargo; - "Local embargo 2", `Quick, test_local_embargo_2; - "Local embargo 3", `Quick, test_local_embargo_3; - "Local embargo 4", `Quick, test_local_embargo_4; - "Local embargo 5", `Quick, test_local_embargo_5; - "Local embargo 6", `Quick, test_local_embargo_6; - "Local embargo 7", `Quick, test_local_embargo_7; - "Local embargo 8", `Quick, test_local_embargo_8; - "Local embargo 9", `Quick, _test_local_embargo_9; - "Local embargo 10", `Quick, test_local_embargo_10; - "Local embargo 11", `Quick, test_local_embargo_11; - "Local embargo 12", `Quick, test_local_embargo_12; - "Local embargo 13", `Quick, test_local_embargo_13; - "Local embargo 14", `Quick, test_local_embargo_14; - "Local embargo 15", `Quick, test_local_embargo_15; - "Shared cap", `Quick, test_share_cap; - "Fields", `Quick, test_fields; - "Cancel", `Quick, test_cancel; - "Cancel 2", `Quick, test_cancel_2; - "Cancel 3", `Quick, test_cancel_3; - "Duplicates", `Quick, test_duplicates; - "Re-export", `Quick, test_single_export; - "Shorten field", `Quick, test_shorten_field; - "Cycle", `Quick, test_cycle; - "Cycle 2", `Quick, test_cycle_2; - "Cycle 3", `Quick, test_cycle_3; - "Cycle 4", `Quick, test_cycle_4; - "Cycle 5", `Quick, test_cycle_5; - "Cycle 6", `Quick, test_cycle_6; - "Resolve", `Quick, test_resolve; - "Resolve 2", `Quick, test_resolve_2; - "Resolve 3", `Quick, test_resolve_3; - "Resolve 4", `Quick, test_resolve_4; - "Resolve 5", `Quick, test_resolve_5; - "Resolve 6", `Quick, test_resolve_6; - "Resolve 7", `Quick, test_resolve_7; - "Ref-counts", `Quick, test_ref_counts; - "Auto-release", `Quick, test_auto_release; - "Unimplemented", `Quick, test_unimplemented; - "Broken return", `Quick, test_broken_return; - "Broken call", `Quick, test_broken_call; - "Broken later", `Quick, test_broken_later; - "Broken connection", `Quick, test_broken_connection; - "Import callbacks", `Quick, test_import_callbacks; -] |> List.map (fun (name, speed, test) -> - name, speed, (fun () -> - Testbed.Capnp_direct.ref_leaks := 0; - test (); - Gc.full_major (); - if !Testbed.Capnp_direct.ref_leaks > 0 then ( - Alcotest.fail "Reference leaks detected!"; - ) - ) - ) + test (Ok (`TCP ("127.0.0.1", 7000))) "tcp:127.0.0.1:7000"; + test (Ok (`TCP ("::1", 7000))) "tcp:[::1]:7000"; + test (Ok (`TCP ("example.org", 7000))) "tcp:example.org:7000"; + test (Ok (`Unix "/run/socket")) "unix:/run/socket"; + test (Error {|Missing port in IPv6 address "[::1]"|}) "tcp:[::1]"; + test (Error {|Invalid port ":1:7000" in listen address "::1:7000"|}) "tcp:::1:7000"; + test (Error {|Missing :PORT in listen address "127.0.0.1"|}) "tcp:127.0.0.1"; + test (Error {|Only tcp:HOST:PORT and unix:PATH addresses are currently supported|}) "http://localhost" + +let run name fn = Alcotest.test_case name `Quick fn + +let rpc_tests ~net ~dir = + let net = Capnp_rpc_unix.Network.v net in + let run_eio = run_eio ~net in + [ + run_eio "Simple" (test_simple ~serve_tls:false); + run_eio "Crypto" (test_simple ~serve_tls:true); + run_eio "Bad crypto" test_bad_crypto ~expected_warnings:1; + run_eio "Parallel" test_parallel; + run_eio "Embargo" test_embargo; + run_eio "Resolve" test_resolve; + run_eio "Registry" test_registry; + run_eio "Calculator" test_calculator; + run_eio "Calculator 2" test_calculator2; + run_eio "Calculator 3" test_calculator3; + run_eio "Cancel" test_cancel; + run_eio "Indexing" test_indexing; + run "Options" test_options; + run "Sturdy URI" test_sturdy_uri; + run_eio "Sturdy self" test_sturdy_self; + run_eio "Table restorer" test_table_restorer; + run_eio "Fn restorer" test_fn_restorer; + run_eio "Broken ref" test_broken; + run "Broken ref 2" test_broken2; + run "Broken ref 3" test_broken3; + run "Broken ref 4" test_broken4; + run_eio "Parallel connect" test_parallel_connect; + run_eio "Parallel fails" test_parallel_fails; + run "Crossed calls" (test_crossed_calls ~net); (* Aborted connections can log warnings *) + run_eio "Store" test_store; + run_eio "File store" (test_file_store ~dir); + run_eio "Await settled" test_await_settled; + run_eio "Late bootstrap" test_late_bootstrap; + run "Listen address" test_listen_address; + ] let () = - Printexc.record_backtrace true; + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + (* Eio_unix.Ctf.with_tracing "/tmp/trace.ctf" @@ fun () -> *) Alcotest.run ~and_exit:false "capnp-rpc" [ - "core", tests; + "eio", rpc_tests ~net:env#net ~dir:env#cwd; ] diff --git a/test/testbed/dune b/test/testbed/dune deleted file mode 100644 index e4664bff2..000000000 --- a/test/testbed/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name testbed) - (libraries astring fmt logs logs.fmt capnp-rpc alcotest asetmap)) diff --git a/unix/capnp_rpc_unix.ml b/unix/capnp_rpc_unix.ml index 260b34984..d7edcbffa 100644 --- a/unix/capnp_rpc_unix.ml +++ b/unix/capnp_rpc_unix.ml @@ -1,19 +1,13 @@ -open Astring -open Lwt.Infix +open Eio.Std module Log = Capnp_rpc.Debug.Log -module Unix_flow = Unix_flow - -let () = Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna) - -type flow = Unix_flow.flow module CapTP = Vat_network.CapTP module Vat = Vat_network.Vat module Network = Network module Vat_config = Vat_config module File_store = File_store -module Sturdy_ref = Capnp_rpc_lwt.Sturdy_ref +module Sturdy_ref = Capnp_rpc.Sturdy_ref let error fmt = fmt |> Fmt.kstr @@ fun msg -> @@ -66,7 +60,7 @@ end let sturdy_uri = let of_string s = - if String.is_prefix s ~affix:"capnp://" then parse_uri s + if String.starts_with s ~prefix:"capnp://" then parse_uri s else if Sys.file_exists s then Cap_file.load_uri s else error "Expected a URI starting with \"capnp://\" \ or the path to a file containing such a URI, but got %S." s @@ -95,8 +89,8 @@ module Console = struct clear (); messages := msg :: !messages; show (); - Lwt.finalize f - (fun () -> + Fun.protect f + ~finally:(fun () -> clear (); let rec remove_first = function | [] -> assert false @@ -104,13 +98,12 @@ module Console = struct | x :: xs -> x :: remove_first xs in messages := remove_first !messages; - show (); - Lwt.return_unit + show () ) end let addr_of_sr sr = - match Capnp_rpc_net.Capnp_address.parse_uri (Capnp_rpc_lwt.Cast.sturdy_to_raw sr)#to_uri_with_secrets with + match Capnp_rpc_net.Capnp_address.parse_uri (Capnp_rpc.Cast.sturdy_to_raw sr)#to_uri_with_secrets with | Ok ((addr, _auth), _id) -> addr | Error (`Msg m) -> failwith m @@ -122,7 +115,7 @@ let rec connect_with_progress ?(mode=`Auto) sr = let did_log = ref false in Log.info (fun f -> did_log := true; f "Connecting to %a..." pp sr); if !did_log then ( - Sturdy_ref.connect sr >|= function + match Sturdy_ref.connect sr with | Ok _ as x -> Log.info (fun f -> f "Connected to %a" pp sr); x | Error _ as e -> e ) else ( @@ -133,108 +126,91 @@ let rec connect_with_progress ?(mode=`Auto) sr = ) | `Batch -> Fmt.epr "Connecting to %a... %!" pp sr; - begin Sturdy_ref.connect sr >|= function + begin match Sturdy_ref.connect sr with | Ok _ as x -> Fmt.epr "OK@."; x | Error _ as x -> Fmt.epr "ERROR@."; x end | `Console -> - let x = Sturdy_ref.connect sr in - Lwt.choose [Lwt_unix.sleep 0.5; Lwt.map ignore x] >>= fun () -> - if Lwt.is_sleeping x then ( - Console.with_msg (Fmt.str "[ connecting to %a ]" pp sr) - (fun () -> x) - ) else x + Switch.run ~name:"connect_with_progress" @@ fun sw -> + Fiber.fork_daemon ~sw (fun () -> + Eio_unix.sleep 0.5; + Console.with_msg (Fmt.str "[ connecting to %a ]" pp sr) Fiber.await_cancel + ); + Sturdy_ref.connect sr | `Silent -> Sturdy_ref.connect sr let with_cap_exn ?progress sr f = - connect_with_progress ?mode:progress sr >>= function + match connect_with_progress ?mode:progress sr with | Error ex -> Fmt.failwith "%a" Capnp_rpc.Exception.pp ex - | Ok x -> Capnp_rpc_lwt.Capability.with_ref x f + | Ok x -> Capnp_rpc.Capability.with_ref x f let handle_connection ?tags ~secret_key vat client = - Lwt.catch (fun () -> - let switch = Lwt_switch.create () in - let raw_flow = Unix_flow.connect ~switch client in - Network.accept_connection ~switch ~secret_key raw_flow >>= function - | Error (`Msg msg) -> - Log.warn (fun f -> f ?tags "Rejecting new connection: %s" msg); - Lwt.return_unit - | Ok ep -> - Vat.add_connection vat ~switch ~mode:`Accept ep >|= fun (_ : CapTP.t) -> - () - ) - (fun ex -> - Log.err (fun f -> f "Uncaught exception handling connection: %a" Fmt.exn ex); - Lwt.return_unit - ) + match Network.accept_connection ~secret_key client with + | Error (`Msg msg) -> + Log.warn (fun f -> f ?tags "Rejecting new connection: %s" msg) + | Ok ep -> Vat.run_connection vat ~mode:`Accept ep ignore -let addr_of_host host = - match Unix.gethostbyname host with - | exception Not_found -> - Capnp_rpc.Debug.failf "Unknown host %S" host - | addr -> - if Array.length addr.Unix.h_addr_list = 0 then - Capnp_rpc.Debug.failf "No addresses found for host name %S" host - else - addr.Unix.h_addr_list.(0) - -let serve ?switch ?tags ?restore config = +let create_server ?tags ?restore ~sw ~net config = let {Vat_config.backlog; secret_key = _; serve_tls; listen_address; public_address} = config in let vat = let auth = Vat_config.auth config in let secret_key = lazy (fst (Lazy.force config.secret_key)) in - Vat.create ?switch ?tags ?restore ~address:(public_address, auth) ~secret_key () + Vat.create ?tags ?restore ~sw ~address:(public_address, auth) ~secret_key net in let socket = match listen_address with - | `Unix path -> - begin match Unix.lstat path with - | { Unix.st_kind = Unix.S_SOCK; _ } -> Unix.unlink path - | _ -> () - | exception Unix.Unix_error(Unix.ENOENT, _, _) -> () - end; - let socket = Unix.(socket PF_UNIX SOCK_STREAM 0) in - Unix.bind socket (Unix.ADDR_UNIX path); - socket + | `Unix _ as addr -> Eio.Net.listen ~sw ~backlog ~reuse_addr:true net addr | `TCP (host, port) -> - let socket = Unix.(socket PF_INET SOCK_STREAM 0) in - Unix.setsockopt socket Unix.SO_REUSEADDR true; - Unix.setsockopt socket Unix.SO_KEEPALIVE true; - Keepalive.try_set_idle socket 60; - Unix.bind socket (Unix.ADDR_INET (addr_of_host host, port)); - socket + match Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) with + | [] -> Fmt.failwith "No addresses found for host name %S" host + | addr :: _ -> + let socket = Eio.Net.listen ~sw ~backlog ~reuse_addr:true net addr in + let unix_socket = Eio_unix.Resource.fd_opt socket |> Option.get in + Eio_unix.Fd.use_exn "keep-alive" unix_socket @@ fun unix_socket -> + Unix.setsockopt unix_socket Unix.SO_KEEPALIVE true; + Keepalive.try_set_idle unix_socket 60; + socket in - Unix.listen socket backlog; Log.info (fun f -> f ?tags "Waiting for %s connections on %a" - (if serve_tls then "(encrypted)" else "UNENCRYPTED") - Vat_config.Listen_address.pp listen_address); - let lwt_socket = Lwt_unix.of_unix_file_descr socket in - let rec loop () = - Lwt_switch.check switch; - Lwt_unix.accept lwt_socket >>= fun (client, _addr) -> - Log.info (fun f -> f ?tags "Accepting new connection"); - let secret_key = if serve_tls then Some (Vat_config.secret_key config) else None in - Lwt.async (fun () -> handle_connection ?tags ~secret_key vat client); - loop () - in - Lwt.async (fun () -> - Lwt.catch - (fun () -> - let th = loop () in - Lwt_switch.add_hook switch (fun () -> Lwt.cancel th; Lwt.return_unit); - th - ) - (function - | Lwt.Canceled -> Lwt.return_unit - | ex -> Lwt.fail ex - ) - >>= fun () -> - Lwt_unix.close lwt_socket + (if serve_tls then "(encrypted)" else "UNENCRYPTED") + Vat_config.Listen_address.pp listen_address); + vat, socket + +let listen ?tags ~sw (config, vat, socket) = + while true do + (* This is like [Eio.Net.accept_fork], but using [fork_daemon] instead of [fork]. *) + let child_started = ref false in + let client, addr = Eio.Net.accept ~sw socket in + Fun.protect ~finally:(fun () -> if !child_started = false then Eio.Net.close client) + (fun () -> + Log.info (fun f -> f ?tags "Accepting new connection from %a" Eio.Net.Sockaddr.pp addr); + Fiber.fork_daemon ~sw (fun () -> + match + child_started := true; + let secret_key = if config.Vat_config.serve_tls then Some (Vat_config.secret_key config) else None in + handle_connection ?tags ~secret_key vat client + with + | () -> Eio.Net.close client; `Stop_daemon + | exception ex -> + Eio.Net.close client; + Fiber.check (); + Log.info (fun f -> f ?tags "Error handling connection from %a: %a" Eio.Net.Sockaddr.pp addr Eio.Exn.pp ex); + `Stop_daemon + ) + ) + done + +let serve ?tags ?restore ~sw ~net config = + let net = (net :> [`Generic] Eio.Net.ty r) in + let (vat, socket) = create_server ?tags ?restore ~sw ~net config in + Fiber.fork_daemon ~sw (fun () -> + listen ?tags ~sw (config, vat, socket) ); - Lwt.return vat + vat -let client_only_vat ?switch ?tags ?restore () = +let client_only_vat ?tags ?restore ~sw net = + let net = (net :> [`Generic] Eio.Net.ty r) in let secret_key = lazy (Capnp_rpc_net.Auth.Secret_key.generate ()) in - Vat.create ?switch ?tags ?restore ~secret_key () + Vat.create ?tags ?restore ~secret_key ~sw net let manpage_capnp_options = Vat_config.docs diff --git a/unix/capnp_rpc_unix.mli b/unix/capnp_rpc_unix.mli index 9d391a38c..cde4d5266 100644 --- a/unix/capnp_rpc_unix.mli +++ b/unix/capnp_rpc_unix.mli @@ -1,12 +1,9 @@ -(** Helpers for using {!Capnp_rpc_lwt} on traditional operating systems. *) +(** Helpers for using {!Capnp_rpc} on traditional operating systems. *) -open Capnp_rpc_lwt +open Capnp_rpc.Std open Capnp_rpc_net -module Unix_flow = Unix_flow - include Capnp_rpc_net.VAT_NETWORK with - type flow = Unix_flow.flow and module Network = Network (** Configuration for a {!Vat}. *) @@ -66,14 +63,14 @@ module File_store : sig type 'a t (** A store of values of type ['a]. *) - val create : string -> 'a t + val create : _ Eio.Path.t -> 'a t (** [create dir] is a store for Cap'n Proto structs. Items are stored inside [dir]. *) - val save : 'a t -> digest:string -> 'a StructStorage.reader_t -> unit + val save : 'a t -> digest:string -> 'a Capnp_rpc.StructStorage.reader_t -> unit (** [save t ~digest data] saves [data] to disk in a file named [base64_encode digest]. *) - val load : 'a t -> digest:string -> 'a StructStorage.reader_t option + val load : 'a t -> digest:string -> 'a Capnp_rpc.StructStorage.reader_t option (** [load t ~digest] is the data passed to [save t ~digest], or [None] if the digest is not known. *) @@ -102,7 +99,7 @@ val sturdy_uri : Uri.t Cmdliner.Arg.conv val connect_with_progress : ?mode:[`Auto | `Log | `Batch | `Console | `Silent] -> - 'a Sturdy_ref.t -> ('a Capability.t, Capnp_rpc.Exception.t) Lwt_result.t + 'a Sturdy_ref.t -> ('a Capability.t, Capnp_rpc.Exception.t) result (** [connect_with_progress sr] is like [Sturdy_ref.connect], but shows that a connection is in progress. Note: On failure, it does {e not} display the error, which should instead be handled by the caller. @param mode Controls how progress is displayed: @@ -116,26 +113,27 @@ val connect_with_progress : val with_cap_exn : ?progress:[`Auto | `Log | `Batch | `Console | `Silent] -> 'a Sturdy_ref.t -> - ('a Capability.t -> 'b Lwt.t) -> - 'b Lwt.t + ('a Capability.t -> 'b) -> + 'b (** Like [Sturdy_ref.with_cap_exn], but using [connect_with_progress] to show progress. *) val serve : - ?switch:Lwt_switch.t -> ?tags:Logs.Tag.set -> ?restore:Restorer.t -> + sw:Eio.Switch.t -> + net:_ Eio.Net.t -> Vat_config.t -> - Vat.t Lwt.t -(** [serve ~restore vat_config] is a new vat that is listening for new connections + Vat.t +(** [serve ~restore ~sw ~net vat_config] is a new vat that is listening for new connections as specified by [vat_config]. After connecting to it, clients can get access to services using [restore]. *) val client_only_vat : - ?switch:Lwt_switch.t -> ?tags:Logs.Tag.set -> ?restore:Restorer.t -> - unit -> Vat.t -(** [client_only_vat ()] is a new vat that does not listen for incoming connections. *) + sw:Eio.Switch.t -> + _ Eio.Net.t -> Vat.t +(** [client_only_vat net] is a new vat that does not listen for incoming connections. *) val manpage_capnp_options : string (** [manpage_capnp_options] is the title of the section of the man-page containing the Cap'n Proto options. diff --git a/unix/dune b/unix/dune index 5e9a7638b..57ef2fbc7 100644 --- a/unix/dune +++ b/unix/dune @@ -1,5 +1,4 @@ (library (name capnp_rpc_unix) (public_name capnp-rpc-unix) - (libraries lwt.unix astring capnp-rpc-lwt capnp-rpc-net capnp-rpc fmt logs - mirage-crypto-rng-lwt cmdliner cstruct-lwt extunix)) + (libraries eio.unix astring capnp-rpc capnp-rpc-net fmt logs cmdliner cstruct extunix)) diff --git a/unix/file_store.ml b/unix/file_store.ml index da1059ea2..975a7ca5a 100644 --- a/unix/file_store.ml +++ b/unix/file_store.ml @@ -1,54 +1,47 @@ -open Capnp_rpc_lwt +open Capnp_rpc -module ReaderOps = Capnp.Runtime.ReaderInc.Make(Capnp_rpc_lwt) +module ReaderOps = Capnp.Runtime.ReaderInc.Make(Capnp_rpc) + +let on_windows = Sys.os_type = "Win32" + +let ( / ) = Eio.Path.( / ) type 'a t = { - dir : string; + dir : Eio.Fs.dir_ty Eio.Path.t; } -let create dir = { dir } +let create dir = { dir = (dir :> Eio.Fs.dir_ty Eio.Path.t) } -let path_of_digest t digest = - match Base64.encode ~alphabet:Base64.uri_safe_alphabet ~pad:false digest with - | Ok filename -> Filename.concat t.dir filename - | Error (`Msg m) -> failwith m (* Encoding can't really fail *) +let leaf_of_digest digest = + Base64.encode_exn ~alphabet:Base64.uri_safe_alphabet ~pad:false digest let segments_of_reader = function | None -> [] | Some ss -> Message.to_storage ss.StructStorage.data.Slice.msg let save t ~digest data = - let path = path_of_digest t digest in - let tmp_path = path ^ ".new" in - let ch = open_out_bin tmp_path in - Fun.protect ~finally:(fun () -> close_out ch) (fun () -> + let leaf = leaf_of_digest digest in + let tmp_leaf = if on_windows then leaf else leaf ^ ".new" in + Eio.Path.with_open_out ~create:(`Or_truncate 0o644) (t.dir / tmp_leaf) (fun flow -> let segments = segments_of_reader data in segments |> List.iter (fun {Message.segment; bytes_consumed} -> - output ch segment 0 bytes_consumed + let buf = Cstruct.of_bytes segment ~len:bytes_consumed in + Eio.Flow.write flow [buf] ); ); - Unix.rename tmp_path path + if not on_windows then + Eio.Path.rename (t.dir / tmp_leaf) (t.dir / leaf) let remove t ~digest = - let path = path_of_digest t digest in - Unix.unlink path + Eio.Path.unlink (t.dir / leaf_of_digest digest) let load t ~digest = - let path = path_of_digest t digest in - if Sys.file_exists path then ( - let ch = open_in_bin path in - let segment = - Fun.protect ~finally:(fun () -> close_in ch) (fun () -> - let len = in_channel_length ch in - let segment = Bytes.create len in - really_input ch segment 0 len; - segment - ) - in - let msg = Message.of_storage [segment] in + let leaf = leaf_of_digest digest in + match Eio.Path.load (t.dir / leaf) with + | segment -> + let msg = Message.of_storage [Bytes.unsafe_of_string segment] in let reader = ReaderOps.get_root_struct (Message.readonly msg) in Some reader - ) else ( - Logs.info (fun f -> f "File %S not found" path); + | exception Eio.Io (Eio.Fs.E Not_found _, _) -> + Logs.info (fun f -> f "File %S not found" leaf); None - ) diff --git a/unix/network.ml b/unix/network.ml index 6e397f339..b148998fc 100644 --- a/unix/network.ml +++ b/unix/network.ml @@ -1,11 +1,9 @@ -open Lwt.Infix +open Eio.Std module Log = Capnp_rpc.Debug.Log -module Tls_wrapper = Capnp_rpc_net.Tls_wrapper.Make(Unix_flow) +module Tls_wrapper = Capnp_rpc_net.Tls_wrapper module Location = struct - open Astring - include Capnp_rpc_net.Capnp_address.Location let abs_path p = @@ -21,16 +19,25 @@ module Location = struct let tcp ~host ~port = `TCP (host, port) let parse_tcp s = - match String.cut ~sep:":" s with - | None -> Error (`Msg "Missing :PORT in listen address") - | Some (host, port) -> - match String.to_int port with - | None -> Error (`Msg "PORT must be an integer") - | Some port -> + if String.starts_with ~prefix:"[" s then ( + match Ipaddr.with_port_of_string ~default:(-1) s with + | Ok (_, -1) -> Fmt.error_msg "Missing port in IPv6 address %S" s + | Ok (host, port) -> + let host = Ipaddr.to_string host in Ok (tcp ~host ~port) + | Error (`Msg m) -> Fmt.error_msg "Invalid IPv6 address %S: %s" s m + ) else ( + match Astring.String.cut ~sep:":" s with + | None -> Fmt.error_msg "Missing :PORT in listen address %S" s + | Some (host, port) -> + match int_of_string_opt port with + | None -> Fmt.error_msg "Invalid port %S in listen address %S" port s + | Some port -> + Ok (tcp ~host ~port) + ) let of_string s = - match String.cut ~sep:":" s with + match Astring.String.cut ~sep:":" s with | Some ("unix", path) -> Ok (unix path) | Some ("tcp", tcp) -> parse_tcp tcp | None -> Error (`Msg "Missing ':'") @@ -50,7 +57,7 @@ module Types = struct type join_key_part end -type t = unit +type t = [`Generic] Eio.Net.ty r let error fmt = fmt |> Fmt.kstr @@ fun msg -> @@ -58,45 +65,32 @@ let error fmt = let parse_third_party_cap_id _ = `Two_party_only -let addr_of_host host = - match Unix.gethostbyname host with - | exception Not_found -> - Capnp_rpc.Debug.failf "Unknown host %S" host - | addr -> - if Array.length addr.Unix.h_addr_list = 0 then - Capnp_rpc.Debug.failf "No addresses found for host name %S" host - else - addr.Unix.h_addr_list.(0) - -let connect_socket = function - | `Unix path -> - Log.info (fun f -> f "Connecting to %S..." path); - let socket = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt.catch - (fun () -> Lwt_unix.connect socket (Unix.ADDR_UNIX path) >|= fun () -> socket) - (fun ex -> Lwt_unix.close socket >>= fun () -> Lwt.fail ex) - | `TCP (host, port) -> - Log.info (fun f -> f "Connecting to %s:%d..." host port); - let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in - Lwt.catch - (fun () -> - Lwt_unix.setsockopt socket Unix.SO_KEEPALIVE true; - Keepalive.try_set_idle (Lwt_unix.unix_file_descr socket) 60; - Lwt_unix.connect socket (Unix.ADDR_INET (addr_of_host host, port)) >|= fun () -> - socket - ) - (fun ex -> Lwt_unix.close socket >>= fun () -> Lwt.fail ex) - -let connect () ~switch ~secret_key (addr, auth) = - Lwt.try_bind - (fun () -> connect_socket addr) - (fun socket -> - let flow = Unix_flow.connect ~switch socket in - Tls_wrapper.connect_as_client ~switch flow secret_key auth - ) - (fun ex -> - Lwt.return @@ error "@[Network connection for %a failed:@,%a@]" Location.pp addr Fmt.exn ex - ) - -let accept_connection ~switch ~secret_key flow = - Tls_wrapper.connect_as_server ~switch flow secret_key +let connect net ~sw ~secret_key (addr, auth) = + let eio_addr = + match addr with + | `Unix _ as x -> x + | `TCP (host, port) -> + match Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) with + | [] -> Fmt.failwith "No addresses found for host name %S" host + | addr :: _ -> addr + in + Log.info (fun f -> f "Connecting to %a..." Eio.Net.Sockaddr.pp eio_addr); + match Eio.Net.connect ~sw net eio_addr with + | socket -> + begin match addr with + | `Unix _ -> () + | `TCP _ -> + let socket = Eio_unix.Resource.fd_opt socket |> Option.get in + Eio_unix.Fd.use_exn "keep-alive" socket @@ fun socket -> + Unix.setsockopt socket Unix.SO_KEEPALIVE true; + Keepalive.try_set_idle socket 60 + end; + Tls_wrapper.connect_as_client socket secret_key auth + | exception ex -> + Fiber.check (); + error "@[Network connection for %a failed:@,%a@]" Location.pp addr Fmt.exn ex + +let accept_connection ~secret_key flow = + Tls_wrapper.connect_as_server flow secret_key + +let v t = (t :> [`Generic] Eio.Net.ty r) diff --git a/unix/network.mli b/unix/network.mli index 7ba6d427c..b38ff192a 100644 --- a/unix/network.mli +++ b/unix/network.mli @@ -1,5 +1,7 @@ (** A network using TCP and Unix-domain sockets. *) +open Eio.Std + module Location : sig type t = [ | `Unix of string @@ -25,14 +27,15 @@ module Location : sig end include Capnp_rpc_net.S.NETWORK with - type t = unit and + type t = [`Generic] Eio.Net.ty Eio.Resource.t and type Address.t = Location.t * Capnp_rpc_net.Auth.Digest.t +val v : _ Eio.Net.t -> t + val accept_connection : - switch:Lwt_switch.t -> secret_key:Capnp_rpc_net.Auth.Secret_key.t option -> - Unix_flow.flow -> - (Capnp_rpc_net.Endpoint.t, [> `Msg of string]) result Lwt.t -(** [accept_connection ~switch ~secret_key flow] is a new endpoint for [flow]. + [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> + (Capnp_rpc_net.Endpoint.t, [> `Msg of string]) result +(** [accept_connection ~secret_key flow] is a new endpoint for [flow]. If [secret_key] is not [None], it is used to perform a TLS server-side handshake. Otherwise, the connection is not encrypted. *) diff --git a/unix/unix_flow.ml b/unix/unix_flow.ml deleted file mode 100644 index 6d5d9c35c..000000000 --- a/unix/unix_flow.ml +++ /dev/null @@ -1,109 +0,0 @@ -open Lwt.Infix - -(* Slightly rude to set signal handlers in a library, but SIGPIPE makes no sense - in a modern application. *) -let () = if not Sys.win32 then Sys.(set_signal sigpipe Signal_ignore) - -type flow = { - fd : Lwt_unix.file_descr; - mutable current_write : int Lwt.t option; - mutable current_read : int Lwt.t option; - mutable closed : bool; -} -type error = [`Exception of exn] -type write_error = [`Closed | `Exception of exn] - -let opt_cancel = function - | None -> () - | Some x -> Lwt.cancel x - -let close t = - if t.closed then Lwt.return_unit - else ( - t.closed <- true; - opt_cancel t.current_read; - opt_cancel t.current_write; - Lwt.catch - (fun () -> Lwt_unix.close t.fd) - (function - | Unix.Unix_error (Unix.ECONNRESET, _, _) -> Lwt.return_unit (* FreeBSD *) - | ex -> raise ex - ) - ) - -let pp_error f = function - | `Exception ex -> Fmt.exn f ex - | `Closed -> Fmt.string f "Closed" - -let pp_write_error = pp_error - -let write t buf = - let rec aux buf = - if t.closed then Lwt.return (Error `Closed) - else ( - assert (t.current_write = None); - let write_thread = Lwt_cstruct.write t.fd buf in - t.current_write <- Some write_thread; - write_thread >>= fun wrote -> - t.current_write <- None; - if wrote = Cstruct.length buf then Lwt.return (Ok ()) - else aux (Cstruct.shift buf wrote) - ) - in - Lwt.catch - (fun () -> aux buf) - (function - | Unix.Unix_error (Unix.ECONNRESET, _, _) - | Unix.Unix_error (Unix.ENOTCONN, _, _) (* macos *) - | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return @@ Error `Closed - | ex -> Lwt.return @@ Error (`Exception ex)) - -let rec writev t = function - | [] -> Lwt.return (Ok ()) - | x :: xs -> - write t x >>= function - | Ok () -> writev t xs - | Error _ as e -> Lwt.return e - -let read t = - let len = 4096 in - let buf = Cstruct.create_unsafe len in - Lwt.try_bind - (fun () -> - assert (t.current_read = None); - if t.closed then raise Lwt.Canceled; - let read_thread = Lwt_cstruct.read t.fd buf in - t.current_read <- Some read_thread; - read_thread - ) - (function - | 0 -> - Lwt.return @@ Ok `Eof - | got -> - t.current_read <- None; - Lwt.return @@ Ok (`Data (Cstruct.sub buf 0 got)) - ) - (function - | Lwt.Canceled - | Unix.Unix_error (Unix.EPIPE, _, _) - | Unix.Unix_error (Unix.ECONNRESET, _, _) -> Lwt_result.return `Eof - | ex -> Lwt.return @@ Error (`Exception ex) - ) - -let connect ?switch fd = - let t = { fd; closed = false; current_read = None; current_write = None } in - Lwt_switch.add_hook switch (fun () -> close t); - t - -let socketpair ?switch () = - let a, b = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) in - connect ?switch a, connect ?switch b - -let shutdown t cmd = - Lwt_unix.shutdown t.fd - (match cmd with - | `read -> SHUTDOWN_RECEIVE - | `read_write -> SHUTDOWN_ALL - | `write -> SHUTDOWN_SEND - ); - Lwt.return_unit diff --git a/unix/unix_flow.mli b/unix/unix_flow.mli deleted file mode 100644 index 78d85bfee..000000000 --- a/unix/unix_flow.mli +++ /dev/null @@ -1,7 +0,0 @@ -(** Wraps a Unix [file_descr] to provide the Mirage flow API. *) - -include Mirage_flow.S - -val connect : ?switch:Lwt_switch.t -> Lwt_unix.file_descr -> flow - -val socketpair : ?switch:Lwt_switch.t -> unit -> flow * flow diff --git a/unix/vat_network.ml b/unix/vat_network.ml index d5d810f8e..922b2eda7 100644 --- a/unix/vat_network.ml +++ b/unix/vat_network.ml @@ -1 +1 @@ -include Capnp_rpc_net.Networking (Network) (Unix_flow) +include Capnp_rpc_net.Networking (Network)