pax_global_header00006660000000000000000000000064142027330520014510gustar00rootroot0000000000000052 comment=0a11cfde4b67628ca8833a50c32cd47dc08ef27c async_rpc_kernel-0.15.0/000077500000000000000000000000001420273305200151145ustar00rootroot00000000000000async_rpc_kernel-0.15.0/.gitignore000066400000000000000000000000411420273305200170770ustar00rootroot00000000000000_build *.install *.merlin _opam async_rpc_kernel-0.15.0/CHANGES.md000066400000000000000000000355661420273305200165250ustar00rootroot00000000000000## v0.10 - Exposed function `Rpc.dispatch'`, which is like `dispatch` but returns an `Rpc_result.t`, which has more information than the `Or_error.t` returned by `dispatch`. ## 113.43.00 - Add some benchmarks for Pipe_rpc - Optimize the server side of Pipe RPC and add an expert interface. This feature will benefit all Pipe RPC implementors. At base: ┌─────────────────────────┬──────────┬─────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├─────────────────────────┼──────────┼─────────┼────────────┤ │ `bench.ml` direct write │ 148.87ns │ 126.00w │ 100.00% │ └─────────────────────────┴──────────┴─────────┴────────────┘ At tip: ┌────────────────────────────────┬──────────┬─────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├────────────────────────────────┼──────────┼─────────┼────────────┤ │ `bench.ml` direct write │ 69.71ns │ 3.00w │ 94.99% │ │ `bench.ml` direct write expert │ 73.39ns │ │ 100.00% │ └────────────────────────────────┴──────────┴─────────┴────────────┘ Note: the reason the expert version is slightly slower is identified: if we replace the `blit`s by `unsafe_blit`s in `rpc_transport_low_latency.ml`, then the expert version becomes faster. The RPC tests for Pipe RPC showed a nice improvement on the server side: lower CPU consumption and roughly 20% faster - Remove the ~update argument from State_rpc.dispatch. Before this feature, the dispatch method for State_rpcs looked like this: val dispatch : ('query, 'state, 'update, 'error) t -> Connection.t -> 'query -> update : ('state -> 'update -> 'state) -> ( 'state * ('state * 'update) Pipe.Reader.t * Metadata.t , 'error ) Result.t Or_error.t Deferred.t There are a couple of cases where having the `update` method there can be cumbersome: - sometimes the type of the state that it sent over the wire is different from the type that is naturally maintained on the client side. - sometimes the update method needs to perform some Async computation to return a new state. It feels like the method is trying to be helpful, but has more of a tendency of getting in the way. This feature removes this method. The old API may be reinstated by using a `Pipe.fold_map` as below: State_rpc.dispatch rpc connection query >>|? fun (state, update_pipe, pipe_metadata) -> state, Pipe.fold_map pipe ~init:state ~f:(fun state update -> let new_state = update_state state update in new_state, (new_state, update)), pipe_metadata - Add support for `State_rpcs` in `Versioned_rpc.Callee_converts`. Implementation and interface very closely resemble that of a Pipe_rpc. ## 113.33.00 - Cleans up the implementation-side interface for aborting `Pipe_rpc`s. Summary The `aborted` `Deferred.t` that got passed to `Pipe_rpc` implementations is gone. The situations where it would have been determined now close the reading end of the user-supplied pipe instead. Details Previously, when an RPC dispatcher decided to abort a query, the RPC implementation would get its `aborted` `Deferred.t` filled in, but would remain free to write some final elements to the pipe. This is a little bit more flexible than the new interface, but it's also problematic in that the implementer could easily just not pay attention to `aborted`. (They're not obligated to pay attention to when the pipe is closed, either, but at least they can't keep writing to it.) We don't think the extra flexibility was used at all. In the future, we may also simplify the client side to remove the `abort` function on the dispatch side (at least when not using `dispatch_iter`). For the time being it remains, but closing the received pipe is the preferred way of aborting the query. There are a couple of known ways this might have changed behavior from before. Both of these appear not to cause problems in the jane repo. - In the past, an implementation could write to a pipe as long as the client didn't disconnect, even if it closed its pipe. Now writes will raise after a client closes its pipe (or calls `abort`), since the implementor's pipe will also be closed in this case. Doing this was already unsafe, though, since the pipe *was* closed if the RPC connection was closed. - `aborted` was only determined if a client aborted the query or the connection was closed. The new alternative, `Pipe.closed` called on the returned pipe, will also be determined if the implementation closes the pipe itself. This is unlikely to cause serious issues but could potentially cause some confusing logging. - Blocking RPC implementations (i.e., ones made with `Rpc.implement'`) now capture the backtrace when they raise. This is consistent with what happens in the deferred implementation case, since in that case the implementation is run inside a `Monitor.try_with`, which captures backtraces as well. Here's an example of what a new error looks like: ((rpc_error (Uncaught_exn ((location "server-side blocking rpc computation") (exn (Invalid_argument "Float.iround_up_exn: argument (100000000000000000000.000000) is too large")) (backtrace "Raised at file \"pervasives.ml\", line 31, characters 25-45\ \nCalled from file \"result.ml\", line 43, characters 17-22\ \nCalled from file \"monad.ml\", line 17, characters 20-28\ \n")))) (connection_description ("Client connected via TCP" (localhost 3333))) (rpc_tag foo) (rpc_version 1)) - Actually deprecated `deprecated_dispatch_multi` functions in `Versioned_rpc`. ## 113.24.00 - When `Transfer.Writer.send*` raises, send an error to the client. - Added `Pipe_rpc` in `Versioned_rpc.Both_convert`. - Switched to ppx. - Expose the lower-level registration hook in `Versioned_rpc`. - Allow custom handling of missed async\_rpc heartbeats. - Client-side State\_rpc `dispatch` function does not behave well when the reader side of the pipe is closed. It should gracefully abort the rpc instead of raising exceptions, or whatever it currently does. - Add `Rpc.Expert.implement` and `Rpc.Expert.implement'` with a similar interface as `One_way.Expert.implement` but for 2-way rpcs. Exceptions raised by an expert implementations are handled as follow: - if the query has already been answered, stop the server (as for one-way expert) - if not, send a `Rpc_error.Uncaught_exn` (as for 2-way rpc) - Adds `Rpc.Pipe_rpc.dispatch_iter`, plus a bunch of additional types to support it. The main reason for this is to reduce space usage: `Pipe_rpc.dispatch` followed by `Pipe.iter_without_pushback` consumes ~105 words in the steady state (i.e., when no messages are coming in) while `dispatch_iter` consumes ~15. I'm sure `dispatch` can be improved a lot, but a pipe by itself is 46 words, so it can't possibly become as small as `dispatch_iter`. Both cases can be made smaller by making `Connection.response_handler` a GADT instead of a closure. I plan to do this later. One annoying property of the interface is that the only way to cancel a subscription is to use `Pipe_rpc.abort`, which has a terrible interface. The logical way to improve the interface is to return a record of a `Pipe_rpc.t`, a `Connection.t`, and a `Query_id.t`, which allocates an additional few words. I'd kind of like to do this but it seems counter to the goal of reducing space usage. - Adds `Rpc.Pipe_rpc.implement_direct`, which uses a "direct stream writer" to write results to the other side, rather than using a `Pipe.Writer.t`. This consumes much less memory, ~15 words per open query as opposed to ~225 for a regular `Pipe_rpc` implementation. A large part of the diff in this feature is the addition of a module `Implementation_types`, which just contains copies of type definitions from `Implementation` and `Implementations`. This is necessary to handle some cyclic type definitions (both of these modules now depend on types defined in the other module). This is the implementation-side dual of `Pipe_rpc.dispatch_iter`. - Change `Command_rpc.Command` to use `Versioned_rpc.Callee_converts` instead of `Versioned_rpc.Both_convert` so that commands can be constructed without client-side conversions. Clients remain free to use conversions or not, as appropriate. Removed `val rpcs` from `Callee_converts` interfaces because nothing appears to use it, and `Both_convert` does not provide it. Now `Both_convert.S` can be supplied to satisfy `Callee_converts.S`. - Annotate errors returned by the async-rpc library with the name of the RPC for which the error was returned (if it's an rpc-level error) and a description of the remote side of the connection (the ip:host if connected via a network socket). - Bring back `val rpcs` in versioned\_rpc modules. ## 113.00.00 - Fixed race in `Rpc` that caused double connection cleanup. Two errors, `Connection_closed` and a Writer error, `(Uncaught_exn(monitor.ml.Error_((exn(\"writer error\"....))))))`, occurring at the same time will cleanup the connection twice and call response_handler of open_queries twice with two different errors. (((pid 31291) (thread_id 0)) ((human_readable 2015-05-25T10:47:18+0100) (int63_ns_since_epoch 1432547238929886105)) "unhandled exception in Async scheduler" ("unhandled exception" ((monitor.ml.Error_ ((exn ("Ivar.fill of full ivar" (Full _) lib/async_kernel/src/ivar0.ml:329:14)) (backtrace ("Raised at file \"error.ml\", line 7, characters 21-29" "Called from file \"rpc.ml\", line 101, characters 8-31" "Called from file \"connection.ml\", line 251, characters 8-172" "Called from file \"core_hashtbl.ml\", line 244, characters 36-48" "Called from file \"connection.ml\", line 248, characters 2-278" "Called from file \"async_stream.ml\", line 49, characters 53-56" "Called from file \"async_stream.ml\", line 21, characters 34-39" "Called from file \"job_queue.ml\", line 124, characters 4-7" "")) (monitor (((name main) (here ()) (id 1) (has_seen_error true) (is_detached false) (kill_index 0)))))) ((pid 31291) (thread_id 0))))) - Fixed bugs in `Rpc` in which a TCP connection's reader was closed before its writer. - In `Versioned_rpc`, eliminated an unnecessary Async cycle when placing RPC messages. - Added `Rpc.Pipe_rpc.close_reason` and `Rpc.State_rpc.close_reason`, which give the reason why a pipe returned by an RPC was closed. These functions take the IDs that are returned along with the pipes by the dispatch functions, so the interface of `dispatch` did not need to change. - Made `Rpc.Expert.dispatch` expose that the connection was closed, just like `One_way.Expert.dispatch`. - Expose the name of the `Versioned_rpc.Menu` RPC. ## 112.35.00 - Moved `Async_extra.Rpc` to its own library, `Async_kernel_rpc`, and abstracted its transport layer. `Async_kernel_rpc` depends only on `Async_kernel`. This allows `Async_rpc` to be used in javascript or to try transports tuned for different use cases. `Versioned_rpc` was moved to `Async_rpc_kernel` as well. - Added `Rpc.One_way` module, for RPCs that do not expect any response or acknowledgment. - Sped up `Rpc.Connection`. We have been able to send 6_000_000 (contentless) one-way messages per second under some idealized circumstances. - In `Rpc`, added an optional `heartbeat_config` argument to configure the heartbeat interval and timeout. - In `Rpc`, added some information to `Connection_closed` exceptions. - In `Rpc.Implementations.create`'s `on_unknown_rpc` argument, added a `connection_state` argument to the `` `Call`` variant. When using `Rpc.Connection.serve`, one can put client addresses in the `connection_state`, so this makes it possible to identify who sent the unknown RPC instead of just saying what the RPC's name and version are. - Added `Rpc.One_way.Expert`, which has an `implement` function that gives direct access to the internal buffer instead of using a bin-prot reader. - Made `Rpc` not raise an exception if a connection is closed due to heartbeating. - Reworked `Async_rpc_kernel`'s `Transport` implementation to not require a `transfer` function similar to `Async_unix.Writer.transfer`. Changed the RPC connection to flush the pipe when the writer is closed, which was the only behavior of `Async_unix.Writer.transfer` that had been relied on. With this change, if someone closes the underlying writer by hand the pipes won't be flushed, which should be expected anyway. - Fixed an issue where "normal" `Pipe_rpc` errors caused the connection to shutdown. Such errors include querying an unknown RPC or getting an exception raised by the RPC implementation shutdown. Now such errors behave like `Rpc` errors, i.e. they are completely ignored besides being put in the return value of `Pipe_rpc.dispatch`. Errors that occur later in `Pipe_rpc` still cause the connection to close, since these should only occur if there is a bug somewhere. - In `Rpc`, connection-closing errors no longer raise top-level exceptions. One can now call `close_reason : t -> Info.t Deferred.t` to get the reason the connection was closed. - Added `One_way` rpcs to `Versioned_rpc`. - Fixed `Rpc` to not write if the transport is closed. The fix doesn't check that the writer is closed, but instead ensure that we don't try to write when we shouldn't. This means that it will still fail if the user close the transport by hand, which they shouldn't do. This change requires transport implementations to fail after they have been closed. This is different from the semantics of `Async_unix.Writer`, but the latter is non-intuitive and makes it hard to check the correctness of the code. Moreover it is only required for `Async_unix.Writer.with_flushed_at_close` which we don't use. async_rpc_kernel-0.15.0/CONTRIBUTING.md000066400000000000000000000044101420273305200173440ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ async_rpc_kernel-0.15.0/LICENSE.md000066400000000000000000000021351420273305200165210ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2022 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. async_rpc_kernel-0.15.0/Makefile000066400000000000000000000004031420273305200165510ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean async_rpc_kernel-0.15.0/README.md000066400000000000000000000003011420273305200163650ustar00rootroot00000000000000Async_rpc_kernel ================ A library for building RPC-style protocols. This library is the portable part of the Unix-oriented `Async_rpc` library, and is actively used in JavaScript. async_rpc_kernel-0.15.0/async_rpc_kernel.opam000066400000000000000000000020241420273305200213110ustar00rootroot00000000000000opam-version: "2.0" version: "v0.15.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/async_rpc_kernel" bug-reports: "https://github.com/janestreet/async_rpc_kernel/issues" dev-repo: "git+https://github.com/janestreet/async_rpc_kernel.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/async_rpc_kernel/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.08.0"} "async_kernel" {>= "v0.15" & < "v0.16"} "core" {>= "v0.15" & < "v0.16"} "ppx_jane" {>= "v0.15" & < "v0.16"} "protocol_version_header" {>= "v0.15" & < "v0.16"} "dune" {>= "2.0.0"} ] synopsis: "Platform-independent core of Async RPC library" description: " Part of Jane Street's Core library The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml. " async_rpc_kernel-0.15.0/bench/000077500000000000000000000000001420273305200161735ustar00rootroot00000000000000async_rpc_kernel-0.15.0/bench/bench.ml000066400000000000000000000114271420273305200176110ustar00rootroot00000000000000open Core open Poly open Async let max_message_size = 16 lsl 20 let config = Rpc.Low_latency_transport.Config.create (* Always batch, we don't care about measuring the syscall time here *) ~start_batching_after_num_messages:0 () ;; let rpc = Rpc.Pipe_rpc.create ~name:"test" ~version:42 ~bin_query:[%bin_type_class: unit] ~bin_response:[%bin_type_class: int * int] ~bin_error:[%bin_type_class: unit] () ;; let rpc_big = Rpc.Pipe_rpc.create ~name:"test-big" ~version:42 ~bin_query:[%bin_type_class: unit] ~bin_response:[%bin_type_class: int list] ~bin_error:[%bin_type_class: unit] () ;; let make rpc = let pipe_reader, pipe_writer = Pipe.create () in let impl = Rpc.Pipe_rpc.implement_direct rpc (fun () () writer -> Pipe.write_without_pushback pipe_writer writer; return (Ok ())) in ( impl , fun () -> match%map Pipe.read pipe_reader with | `Eof -> assert false | `Ok x -> x ) ;; let implementation, next_direct_writer = make rpc let implementation_big, next_direct_writer_big = make rpc_big let implementations = Rpc.Implementations.create_exn ~implementations:[ implementation; implementation_big ] ~on_unknown_rpc:`Raise ;; let create fdr fdw = let reader = Rpc.Low_latency_transport.Reader.create fdr ~max_message_size ~config in let writer = Rpc.Low_latency_transport.Writer.create fdw ~max_message_size ~config in Async_rpc_kernel.Rpc.Connection.create ~implementations ~connection_state:ignore { reader; writer } >>| Result.ok_exn ;; let client, _server, server_to_client_fdw = Thread_safe.block_on_async_exn (fun () -> let%bind `Reader c2s_fdr, `Writer c2s_fdw = Unix.pipe (Info.of_string "client->server") in let%bind `Reader s2c_fdr, `Writer s2c_fdw = Unix.pipe (Info.of_string "server->client") in let%map client = create s2c_fdr c2s_fdw and server = create c2s_fdr s2c_fdw in client, server, s2c_fdw) ;; let new_direct_writer rpc next_direct_writer = Thread_safe.block_on_async_exn (fun () -> let%map () = match%map Rpc.Pipe_rpc.dispatch_iter rpc client () ~f:(fun _ -> Continue) with | Ok _ -> () | Error _ -> assert false and direct_writer = next_direct_writer () in direct_writer) ;; let direct_writer = new_direct_writer rpc next_direct_writer let direct_writers_big = Array.init 100 ~f:(fun _ -> new_direct_writer rpc_big next_direct_writer_big) ;; let group1 = Rpc.Pipe_rpc.Direct_stream_writer.Group.create () let group10 = Rpc.Pipe_rpc.Direct_stream_writer.Group.create () let group100 = Rpc.Pipe_rpc.Direct_stream_writer.Group.create () let groups = [ 1, group1; 10, group10; 100, group100 ] let () = List.iter groups ~f:(fun (n, group) -> for i = 0 to n - 1 do Rpc.Pipe_rpc.Direct_stream_writer.Group.add_exn group direct_writers_big.(i) done) ;; let () = (* Now replace the server fd by /dev/null, so that writes always succeed *) let fd = Fd.file_descr_exn server_to_client_fdw in let open! Core in let module Unix = Core_unix in let devnull = Unix.openfile ~mode:[ O_WRONLY ] "/dev/null" in Unix.dup2 ~src:devnull ~dst:fd (); Unix.close devnull ;; (* [stop_inlining] makes sure the compiler knows nothing about [data] *) external stop_inlining : 'a -> 'a = "async_rpc_kernel_bench_identity" let data = stop_inlining (42, 0x1234_5678) let bin_writer_int_int = [%bin_writer: int * int] let buf = Bigstring.create 8192 let%bench "direct write" = assert ( Rpc.Pipe_rpc.Direct_stream_writer.write_without_pushback direct_writer data = `Ok) ;; let%bench "direct write expert" = let len = bin_writer_int_int.write buf ~pos:0 data in assert ( Rpc.Pipe_rpc.Direct_stream_writer.Expert.write_without_pushback direct_writer ~buf ~pos:0 ~len = `Ok) ;; let big_data = stop_inlining (List.init 1000 ~f:(fun x -> x * 1000)) let bin_writer_int_list = [%bin_writer: int list] let%bench "direct write (big)" = assert ( Rpc.Pipe_rpc.Direct_stream_writer.write_without_pushback direct_writers_big.(0) big_data = `Ok) ;; let%bench "direct write expert (big)" = let len = bin_writer_int_list.write buf ~pos:0 big_data in assert ( Rpc.Pipe_rpc.Direct_stream_writer.Expert.write_without_pushback direct_writers_big.(0) ~buf ~pos:0 ~len = `Ok) ;; let%bench ("iter direct write (big)" [@indexed n = [ 1; 10; 100 ]]) = for i = 0 to n - 1 do assert ( Rpc.Pipe_rpc.Direct_stream_writer.write_without_pushback direct_writers_big.(i) big_data = `Ok) done ;; let%bench_fun ("direct write to group (big)" [@indexed n = [ 1; 10; 100 ]]) = let group = List.Assoc.find_exn groups ~equal:Int.equal n in fun () -> Rpc.Pipe_rpc.Direct_stream_writer.Group.write_without_pushback group big_data ;; async_rpc_kernel-0.15.0/bench/bench.mli000066400000000000000000000000551420273305200177550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) async_rpc_kernel-0.15.0/bench/dune000066400000000000000000000001461420273305200170520ustar00rootroot00000000000000(library (name async_rpc_kernel_bench) (c_names stubs) (libraries async) (preprocess (pps ppx_jane)))async_rpc_kernel-0.15.0/bench/stubs.c000066400000000000000000000001331420273305200174740ustar00rootroot00000000000000#include value async_rpc_kernel_bench_identity(value x) { return x; } async_rpc_kernel-0.15.0/dune-project000066400000000000000000000000201420273305200174260ustar00rootroot00000000000000(lang dune 1.10)async_rpc_kernel-0.15.0/src/000077500000000000000000000000001420273305200157035ustar00rootroot00000000000000async_rpc_kernel-0.15.0/src/async_rpc_kernel.ml000066400000000000000000000007501420273305200215600ustar00rootroot00000000000000module Rpc = Rpc module Versioned_rpc = Versioned_rpc module Persistent_connection = Persistent_connection module Pipe_transport = Pipe_transport module Rpc_error = Rpc_error module Rpc_result = Rpc_result module Async_rpc_kernel_stable = struct module Rpc = Rpc.Stable end module Async_rpc_kernel_private = struct module Connection = Connection module Protocol = Protocol module Transport = Transport let default_handshake_timeout = Connection.default_handshake_timeout end async_rpc_kernel-0.15.0/src/connection.ml000066400000000000000000000434561420273305200204100ustar00rootroot00000000000000open Core open Async_kernel module Time_ns = Core_private.Time_ns_alternate_sexp module P = Protocol module Reader = Transport.Reader module Writer = Transport.Writer module Header : sig type t [@@deriving bin_type_class] val v1 : t val negotiate : us:t -> peer:t -> int Or_error.t end = struct include P.Header let negotiate = negotiate ~allow_legacy_peer:true let v1 = Protocol_version_header.create_exn ~protocol:Rpc ~supported_versions:[ 1 ] end module Handshake_error = struct module T = struct type t = | Eof | Transport_closed | Timeout | Reading_header_failed of Error.t | Negotiation_failed of Error.t | Negotiated_unexpected_version of int [@@deriving sexp] end include T include Sexpable.To_stringable (T) exception Handshake_error of (t * Info.t) [@@deriving sexp] let to_exn ~connection_description t = Handshake_error (t, connection_description) end module Heartbeat_config = struct type t = { timeout : Time_ns.Span.t ; send_every : Time_ns.Span.t } [@@deriving sexp, bin_io, fields] let create ?(timeout = Time_ns.Span.of_sec 30.) ?(send_every = Time_ns.Span.of_sec 10.) () = { timeout; send_every } ;; module Runtime = struct type t = { mutable timeout : Time_ns.Span.t ; send_every : Time_ns.Span.t } [@@deriving sexp_of] end let to_runtime { timeout; send_every } = { Runtime.timeout; send_every } end type response_handler = Nat0.t P.Response.t -> read_buffer:Bigstring.t -> read_buffer_pos_ref:int ref -> [ `keep | `wait of unit Deferred.t | `remove of unit Rpc_result.t | `remove_and_wait of unit Deferred.t ] type t = { description : Info.t ; heartbeat_config : Heartbeat_config.Runtime.t ; mutable heartbeat_callbacks : (unit -> unit) array ; mutable last_seen_alive : Time_ns.t ; reader : Reader.t ; writer : Writer.t ; open_queries : (P.Query_id.t, (response_handler[@sexp.opaque])) Hashtbl.t ; close_started : Info.t Ivar.t ; close_finished : unit Ivar.t (* There's a circular dependency between connections and their implementation instances (the latter depends on the connection state, which is given access to the connection when it is created). *) ; implementations_instance : Implementations.Instance.t Set_once.t ; time_source : Synchronous_time_source.t ; heartbeat_event : Synchronous_time_source.Event.t Set_once.t } [@@deriving sexp_of] let sexp_of_t_hum_writer t = [%sexp { description : Info.t = t.description; writer : Writer.t = t.writer }] ;; let description t = t.description let is_closed t = Ivar.is_full t.close_started let writer t = if is_closed t || not (Writer.can_send t.writer) then Error `Closed else Ok t.writer ;; let bytes_to_write t = Writer.bytes_to_write t.writer let flushed t = Writer.flushed t.writer let handle_send_result : t -> 'a Transport.Send_result.t -> 'a = fun t r -> match r with | Sent x -> x | Closed -> (* All of the places we call [handle_send_result] check whether [t] is closed (usually via the [writer] function above). This checks whether [t.writer] is closed, which should not happen unless [t] is closed. *) failwiths ~here:[%here] "RPC connection got closed writer" t sexp_of_t_hum_writer | Message_too_big _ -> raise_s [%sexp "Message cannot be sent" , { reason = (r : _ Transport.Send_result.t); connection = (t : t_hum_writer) }] ;; let dispatch t ~response_handler ~bin_writer_query ~query = match writer t with | Error `Closed as r -> r | Ok writer -> Option.iter response_handler ~f:(fun response_handler -> Hashtbl.set t.open_queries ~key:query.P.Query.id ~data:response_handler); Writer.send_bin_prot writer (P.Message.bin_writer_needs_length (Writer_with_length.of_writer bin_writer_query)) (Query query) |> handle_send_result t; Ok () ;; let make_dispatch_bigstring do_send t ~tag ~version buf ~pos ~len ~response_handler = match writer t with | Error `Closed -> Error `Closed | Ok writer -> let id = P.Query_id.create () in let header : Nat0.t P.Message.t = Query { tag; version; id; data = Nat0.of_int_exn len } in Option.iter response_handler ~f:(fun response_handler -> Hashtbl.set t.open_queries ~key:id ~data:response_handler); let result = do_send writer P.Message.bin_writer_nat0_t header ~buf ~pos ~len |> handle_send_result t in Ok result ;; let dispatch_bigstring = make_dispatch_bigstring Writer.send_bin_prot_and_bigstring let schedule_dispatch_bigstring = make_dispatch_bigstring Writer.send_bin_prot_and_bigstring_non_copying ;; let handle_response t (response : _ P.Response.t) ~read_buffer ~read_buffer_pos_ref : _ Transport.Handler_result.t = match Hashtbl.find t.open_queries response.id with | None -> Stop (Error (Rpc_error.Unknown_query_id response.id)) | Some response_handler -> (match response_handler response ~read_buffer ~read_buffer_pos_ref with | `keep -> Continue | `wait wait -> Wait wait | `remove_and_wait wait -> Hashtbl.remove t.open_queries response.id; Wait wait | `remove removal_circumstances -> Hashtbl.remove t.open_queries response.id; (match removal_circumstances with | Ok () -> Continue | Error e -> (match e with | Unimplemented_rpc _ -> Continue | Bin_io_exn _ | Connection_closed | Write_error _ | Uncaught_exn _ | Unknown_query_id _ -> Stop (Error e)))) ;; let handle_msg t (msg : _ P.Message.t) ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor : _ Transport.Handler_result.t = match msg with | Heartbeat -> Array.iter t.heartbeat_callbacks ~f:(fun f -> f ()); Continue | Response response -> handle_response t response ~read_buffer ~read_buffer_pos_ref | Query query -> let instance = Set_once.get_exn t.implementations_instance [%here] in Implementations.Instance.handle_query instance ~close_connection_monitor ~query ~read_buffer ~read_buffer_pos_ref ;; let close_reason t ~on_close = let reason = Ivar.read t.close_started in match on_close with | `started -> reason | `finished -> let%bind () = Ivar.read t.close_finished in reason ;; let close_finished t = Ivar.read t.close_finished let add_heartbeat_callback t f = (* Adding heartbeat callbacks is relatively rare, but the callbacks are triggered a lot. The array representation makes the addition quadratic for the sake of keeping the triggering cheap. *) t.heartbeat_callbacks <- Array.append [| f |] t.heartbeat_callbacks ;; let reset_heartbeat_timeout t timeout = t.heartbeat_config.timeout <- timeout; t.last_seen_alive <- Synchronous_time_source.now t.time_source ;; let last_seen_alive t = t.last_seen_alive let abort_heartbeating t = Option.iter (Set_once.get t.heartbeat_event) ~f:(fun event -> match Synchronous_time_source.Event.abort t.time_source event with | Ok | Previously_unscheduled -> () | Currently_happening -> Synchronous_time_source.run_after t.time_source Time_ns.Span.zero (fun () -> Synchronous_time_source.Event.abort_exn t.time_source event)) ;; let close ?(streaming_responses_flush_timeout = Time_ns.Span.of_int_sec 5) ~reason t = if not (is_closed t) then ( abort_heartbeating t; Ivar.fill t.close_started reason; (match Set_once.get t.implementations_instance with | None -> Deferred.unit | Some instance -> let flushed = Implementations.Instance.flush instance in if Deferred.is_determined flushed then ( Implementations.Instance.stop instance; flushed) else ( let%map () = Deferred.any_unit [ flushed ; Writer.stopped t.writer ; Time_source.after (Time_source.of_synchronous t.time_source) streaming_responses_flush_timeout ] in Implementations.Instance.stop instance)) >>> fun () -> Writer.close t.writer >>> fun () -> Reader.close t.reader >>> fun () -> Ivar.fill t.close_finished ()); close_finished t ;; let on_message t ~close_connection_monitor = let f buf ~pos ~len:_ : _ Transport.Handler_result.t = let pos_ref = ref pos in let nat0_msg = P.Message.bin_read_nat0_t buf ~pos_ref in match handle_msg t nat0_msg ~read_buffer:buf ~read_buffer_pos_ref:pos_ref ~close_connection_monitor with | Continue -> Continue | Wait _ as res -> res | Stop result -> let reason = let msg = "Rpc message handling loop stopped" in match result with | Ok () -> Info.of_string msg | Error e -> Info.create msg e (Rpc_error.sexp_of_t ~get_connection_close_reason:(fun () -> [%sexp "Connection.on_message resulted in Connection_closed error. This is \ weird."])) in don't_wait_for (close t ~reason); Stop reason in Staged.stage f ;; let heartbeat_now t = let since_last_heartbeat = Time_ns.diff (Synchronous_time_source.now t.time_source) t.last_seen_alive in if Time_ns.Span.( > ) since_last_heartbeat t.heartbeat_config.timeout then ( let reason () = sprintf !"No heartbeats received for %{sexp:Time_ns.Span.t}." t.heartbeat_config.timeout in don't_wait_for (close t ~reason:(Info.of_thunk reason))) else ( match writer t with | Error `Closed -> () | Ok writer -> Writer.send_bin_prot writer P.Message.bin_writer_nat0_t Heartbeat |> handle_send_result t) ;; let default_handshake_timeout = Time_ns.Span.of_sec 30. let cleanup t ~reason exn = don't_wait_for (close ~reason t); if not (Hashtbl.is_empty t.open_queries) then ( let error = match exn with | Rpc_error.Rpc (error, (_ : Info.t)) -> error | exn -> Uncaught_exn (Exn.sexp_of_t exn) in (* clean up open streaming responses *) (* an unfortunate hack; ok because the response handler will have nothing to read following a response where [data] is an error *) let dummy_buffer = Bigstring.create 1 in let dummy_ref = ref 0 in Hashtbl.iteri t.open_queries ~f:(fun ~key:query_id ~data:response_handler -> ignore (response_handler ~read_buffer:dummy_buffer ~read_buffer_pos_ref:dummy_ref { id = query_id; data = Error error })); Hashtbl.clear t.open_queries; Bigstring.unsafe_destroy dummy_buffer) ;; let schedule_heartbeats t = t.last_seen_alive <- Synchronous_time_source.now t.time_source; let heartbeat_from_now_on = (* [at_intervals] will schedule the first heartbeat the first time the time_source is advanced *) Synchronous_time_source.Event.at_intervals t.time_source t.heartbeat_config.send_every (fun () -> heartbeat_now t) in Set_once.set_exn t.heartbeat_event [%here] heartbeat_from_now_on ;; let run_after_handshake t ~implementations ~connection_state ~writer_monitor_exns = let instance = Implementations.instantiate implementations ~writer:t.writer ~connection_description:t.description ~connection_close_started:(Ivar.read t.close_started) ~connection_state:(connection_state t) in Set_once.set_exn t.implementations_instance [%here] instance; let close_connection_monitor = Monitor.create ~name:"RPC close connection monitor" () in Monitor.detach_and_iter_errors close_connection_monitor ~f:(fun exn -> let reason = Info.create_s [%message "Uncaught exception in implementation" (exn : Exn.t)] in don't_wait_for (close ~reason t)); let monitor = Monitor.create ~name:"RPC connection loop" () in let reason name exn = exn, Info.tag (Info.of_exn exn) ~tag:("exn raised in RPC connection " ^ name) in Stream.iter (Stream.interleave (Stream.of_list [ Stream.map ~f:(reason "loop") (Monitor.detach_and_get_error_stream monitor) ; Stream.map ~f:(reason "Writer.t") writer_monitor_exns ])) ~f:(fun (exn, reason) -> cleanup t exn ~reason); within ~monitor (fun () -> schedule_heartbeats t; Reader.read_forever t.reader ~on_message:(Staged.unstage (on_message t ~close_connection_monitor)) ~on_end_of_batch:(fun () -> t.last_seen_alive <- Synchronous_time_source.now t.time_source) >>> function | Ok reason -> cleanup t ~reason (Rpc_error.Rpc (Connection_closed, t.description)) (* The protocol is such that right now, the only outcome of the other side closing the connection normally is that we get an eof. *) | Error (`Eof | `Closed) -> cleanup t ~reason:(Info.of_string "EOF or connection closed") (Rpc_error.Rpc (Connection_closed, t.description))) ;; let do_handshake t ~handshake_timeout = match writer t with | Error `Closed -> return (Error Handshake_error.Transport_closed) | Ok writer -> Writer.send_bin_prot writer Header.bin_t.writer Header.v1 |> handle_send_result t; (* If we use [max_connections] in the server, then this read may just hang until the server starts accepting new connections (which could be never). That is why a timeout is used *) let result = Monitor.try_with ~rest:`Log ~run:`Now (fun () -> Reader.read_one_message_bin_prot t.reader Header.bin_t.reader) in (match%map Time_source.with_timeout (Time_source.of_synchronous t.time_source) handshake_timeout result with | `Timeout -> (* There's a pending read, the reader is basically useless now, so we clean it up. *) don't_wait_for (close t ~reason:(Info.of_string "Handshake timeout")); Error Handshake_error.Timeout | `Result (Error exn) -> let reason = Info.of_string "[Reader.read_one_message_bin_prot] raised" in don't_wait_for (close t ~reason); Error (Reading_header_failed (Error.of_exn exn)) | `Result (Ok (Error `Eof)) -> Error Eof | `Result (Ok (Error `Closed)) -> Error Transport_closed | `Result (Ok (Ok peer)) -> (match Header.negotiate ~us:Header.v1 ~peer with | Error e -> Error (Negotiation_failed e) | Ok 1 -> Ok () | Ok i -> Error (Negotiated_unexpected_version i))) ;; let contains_magic_prefix = Protocol_version_header.contains_magic_prefix ~protocol:Rpc let create ?implementations ~connection_state ?(handshake_timeout = default_handshake_timeout) ?(heartbeat_config = Heartbeat_config.create ()) ?(description = Info.of_string "") ?(time_source = Synchronous_time_source.wall_clock ()) ({ reader; writer } : Transport.t) = let implementations = match implementations with | None -> Implementations.null () | Some s -> s in let t = { description ; heartbeat_config = Heartbeat_config.to_runtime heartbeat_config ; heartbeat_callbacks = [||] ; last_seen_alive = Synchronous_time_source.now time_source ; reader ; writer ; open_queries = Hashtbl.Poly.create ~size:10 () ; close_started = Ivar.create () ; close_finished = Ivar.create () ; implementations_instance = Set_once.create () ; time_source ; heartbeat_event = Set_once.create () } in let writer_monitor_exns = Monitor.detach_and_get_error_stream (Writer.monitor writer) in upon (Writer.stopped writer) (fun () -> don't_wait_for (close t ~reason:(Info.of_string "RPC transport stopped"))); match%map do_handshake t ~handshake_timeout with | Ok () -> run_after_handshake t ~implementations ~connection_state ~writer_monitor_exns; Ok t | Error error -> Error (Handshake_error.to_exn ~connection_description:description error) ;; let with_close ?implementations ?handshake_timeout ?heartbeat_config ?description ?time_source ~connection_state transport ~dispatch_queries ~on_handshake_error = let handle_handshake_error = match on_handshake_error with | `Call f -> f | `Raise -> raise in let%bind t = create ?implementations ?handshake_timeout ?heartbeat_config ?description ?time_source ~connection_state transport in match t with | Error e -> let%bind () = Transport.close transport in handle_handshake_error e | Ok t -> Monitor.protect ~run: `Schedule ~rest:`Log ~finally:(fun () -> close t ~reason:(Info.of_string "Rpc.Connection.with_close finished")) (fun () -> let%bind result = dispatch_queries t in let%map () = match implementations with | None -> Deferred.unit | Some _ -> close_finished t in result) ;; let server_with_close ?handshake_timeout ?heartbeat_config ?description ?time_source transport ~implementations ~connection_state ~on_handshake_error = let on_handshake_error = match on_handshake_error with | `Call f -> `Call f | `Raise -> `Raise | `Ignore -> `Call (fun _ -> Deferred.unit) in with_close ?handshake_timeout ?heartbeat_config ?description ?time_source transport ~implementations ~connection_state ~on_handshake_error ~dispatch_queries:(fun _ -> Deferred.unit) ;; let close ?streaming_responses_flush_timeout ?(reason = Info.of_string "Rpc.Connection.close") t = close ?streaming_responses_flush_timeout ~reason t ;; module Client_implementations = struct type nonrec 's t = { connection_state : t -> 's ; implementations : 's Implementations.t } let null () = { connection_state = (fun _ -> ()); implementations = Implementations.null () } ;; end async_rpc_kernel-0.15.0/src/connection.mli000066400000000000000000000021131420273305200205420ustar00rootroot00000000000000(** Internal to [Async_rpc_kernel]. See [Connection_intf.S]. *) open! Core open! Async_kernel open Protocol include Connection_intf.S (* Internally, we use a couple of extra functions on connections that aren't exposed to users. *) type response_handler = Nat0.t Response.t -> read_buffer:Bigstring.t -> read_buffer_pos_ref:int ref -> [ `keep | `wait of unit Deferred.t | `remove of unit Rpc_result.t | `remove_and_wait of unit Deferred.t ] val dispatch : t -> response_handler:response_handler option -> bin_writer_query:'a Bin_prot.Type_class.writer -> query:'a Query.t -> (unit, [ `Closed ]) Result.t val dispatch_bigstring : t -> tag:Rpc_tag.t -> version:int -> Bigstring.t -> pos:int -> len:int -> response_handler:response_handler option -> (unit, [ `Closed ]) Result.t val schedule_dispatch_bigstring : t -> tag:Rpc_tag.t -> version:int -> Bigstring.t -> pos:int -> len:int -> response_handler:response_handler option -> (unit Deferred.t, [ `Closed ]) Result.t val default_handshake_timeout : Time_ns.Span.t async_rpc_kernel-0.15.0/src/connection_intf.ml000066400000000000000000000160211420273305200214140ustar00rootroot00000000000000open Core open Async_kernel (* The reason for defining this module type explicitly is so that we can internally keep track of what is and isn't exposed. *) module type S = sig type t [@@deriving sexp_of] module Heartbeat_config : sig type t [@@deriving sexp, bin_io] (** Each side of the connection has its own heartbeat config. It sends a heartbeat every [send_every]. If it doesn't receive any messages for [timeout], whether it's a heartbeat or not, it drops the connection. It only checks whether [timeout] has elapsed when it sends heartbeats, so effectively [timeout] is rounded up to the nearest multiple of [send_every]. *) val create : ?timeout:Time_ns.Span.t -> ?send_every:Time_ns.Span.t -> unit -> t val timeout : t -> Time_ns.Span.t val send_every : t -> Time_ns.Span.t end module Client_implementations : sig type nonrec 's t = { connection_state : t -> 's ; implementations : 's Implementations.t } val null : unit -> unit t end (** Initiate an Rpc connection on the given transport. [implementations] should be the bag of implementations that the calling side implements; it defaults to [Implementations.null] (i.e., "I implement no RPCs"). [connection_state] will be called once, before [create]'s result is determined, on the same connection that [create] returns. Its output will be provided to the [implementations] when queries arrive. WARNING: If specifying a custom [heartbeat_config], make sure that both ends of the Rpc connection use compatible settings for timeout and send frequency. Otherwise, your Rpc connections might close unexpectedly. [description] can be used to give some extra information about the connection, which will then show up in error messages and the connection's sexp. If you have lots of connections in your program, this can be useful for distinguishing them. [time_source] can be given to define the time_source for which the heartbeating events will be scheduled. Defaults to wall-clock. *) val create : ?implementations:'s Implementations.t -> connection_state:(t -> 's) -> ?handshake_timeout:Time_ns.Span.t -> ?heartbeat_config:Heartbeat_config.t -> ?description:Info.t -> ?time_source:Synchronous_time_source.t -> Transport.t -> (t, Exn.t) Result.t Deferred.t (** As of Feb 2017, the RPC protocol started to contain a magic number so that one can identify RPC communication. The bool returned by [contains_magic_prefix] says whether this magic number was observed. *) val contains_magic_prefix : bool Bin_prot.Type_class.reader val description : t -> Info.t (** After [add_heartbeat_callback t f], [f ()] will be called after every subsequent heartbeat received by [t]. *) val add_heartbeat_callback : t -> (unit -> unit) -> unit (** Changes the heartbeat timeout and restarts the timer by setting [last_seen_alive] to the current time. *) val reset_heartbeat_timeout : t -> Time_ns.Span.t -> unit (** The last time either any message has been received or [reset_heartbeat_timeout] was called. *) val last_seen_alive : t -> Time_ns.t (** [close] starts closing the connection's transport, and returns a deferred that becomes determined when its close completes. It is ok to call [close] multiple times on the same [t]; calls subsequent to the initial call will have no effect, but will return the same deferred as the original call. Before closing the underlying transport's writer, [close] waits for all streaming reponses to be [Pipe.upstream_flushed] with a timeout of [streaming_responses_flush_timeout]. The [reason] for closing the connection will be passed to callers of [close_reason]. *) val close : ?streaming_responses_flush_timeout:Time_ns.Span.t (* default: 5 seconds *) -> ?reason:Info.t -> t -> unit Deferred.t (** [close_finished] becomes determined after the close of the connection's transport completes, i.e. the same deferred that [close] returns. [close_finished] differs from [close] in that it does not have the side effect of initiating a close. *) val close_finished : t -> unit Deferred.t (** [close_reason ~on_close t] becomes determined when close starts or finishes based on [on_close], but additionally returns the reason that the connection was closed. *) val close_reason : t -> on_close:[ `started | `finished ] -> Info.t Deferred.t (** [is_closed t] returns [true] iff [close t] has been called. [close] may be called internally upon errors or timeouts. *) val is_closed : t -> bool (** [bytes_to_write] and [flushed] just call the similarly named functions on the [Transport.Writer.t] within a connection. *) val bytes_to_write : t -> int val flushed : t -> unit Deferred.t (** [with_close] tries to create a [t] using the given transport. If a handshake error is the result, it calls [on_handshake_error], for which the default behavior is to raise an exception. If no error results, [dispatch_queries] is called on [t]. After [dispatch_queries] returns, if [server] is None, the [t] will be closed and the deferred returned by [dispatch_queries] will be determined immediately. Otherwise, we'll wait until the other side closes the connection and then close [t] and determine the deferred returned by [dispatch_queries]. When the deferred returned by [with_close] becomes determined, [Transport.close] has finished. NOTE: Because this connection is closed when the [Deferred.t] returned by [dispatch_queries] is determined, you should be careful when using this with [Pipe_rpc]. For example, simply returning the pipe when you get it will close the pipe immediately. You should instead either use the pipe inside [dispatch_queries] and not determine its result until you are done with the pipe, or use a different function like [create]. *) val with_close : ?implementations:'s Implementations.t -> ?handshake_timeout:Time_ns.Span.t -> ?heartbeat_config:Heartbeat_config.t -> ?description:Info.t -> ?time_source:Synchronous_time_source.t -> connection_state:(t -> 's) -> Transport.t -> dispatch_queries:(t -> 'a Deferred.t) -> on_handshake_error:[ `Raise | `Call of Exn.t -> 'a Deferred.t ] -> 'a Deferred.t (** Runs [with_close] but dispatches no queries. The implementations are required because this function doesn't let you dispatch any queries (i.e., act as a client), it would be pointless to call it if you didn't want to act as a server.*) val server_with_close : ?handshake_timeout:Time_ns.Span.t -> ?heartbeat_config:Heartbeat_config.t -> ?description:Info.t -> ?time_source:Synchronous_time_source.t -> Transport.t -> implementations:'s Implementations.t -> connection_state:(t -> 's) -> on_handshake_error:[ `Raise | `Ignore | `Call of Exn.t -> unit Deferred.t ] -> unit Deferred.t end async_rpc_kernel-0.15.0/src/description.ml000066400000000000000000000013101420273305200205530ustar00rootroot00000000000000open Core module Stable = struct module V1 = struct type t = { name : string ; version : int } [@@deriving bin_io, compare, hash, sexp] end end include Stable.V1 include Comparable.Make (Stable.V1) include Hashable.Make (Stable.V1) let summarize ts = List.map ts ~f:(fun { name; version } -> name, version) |> String.Map.of_alist_fold ~init:Int.Set.empty ~f:Int.Set.add ;; let%expect_test _ = let descriptions = [ { name = "foo"; version = 1 } ; { name = "foo"; version = 2 } ; { name = "bar"; version = 5 } ] in let summary = summarize descriptions in print_s [%sexp (summary : Int.Set.t String.Map.t)]; [%expect {| ((bar (5)) (foo (1 2))) |}] ;; async_rpc_kernel-0.15.0/src/description.mli000066400000000000000000000006271420273305200207360ustar00rootroot00000000000000(** Internal to [Async_rpc_kernel]. See [Rpc.Decscription]. *) open! Core type t = { name : string ; version : int } [@@deriving bin_io, compare, hash, sexp_of] include Comparable.S with type t := t include Hashable.S with type t := t val summarize : t list -> Int.Set.t String.Map.t module Stable : sig module V1 : sig type nonrec t = t [@@deriving compare, sexp, bin_io, hash] end end async_rpc_kernel-0.15.0/src/dune000066400000000000000000000003001420273305200165520ustar00rootroot00000000000000(library (name async_rpc_kernel) (public_name async_rpc_kernel) (preprocess (pps ppx_jane)) (libraries async_kernel core async_kernel.persistent_connection_kernel protocol_version_header))async_rpc_kernel-0.15.0/src/implementation.ml000066400000000000000000000070461420273305200212710ustar00rootroot00000000000000open Core open Async_kernel open Protocol open Implementation_types.Implementation module Expert = struct module Responder = struct type t = Expert.Responder.t = { query_id : Query_id.t ; writer : Transport.Writer.t ; mutable responded : bool } [@@deriving sexp_of] let create query_id writer = { query_id; writer; responded = false } end type implementation_result = Expert.implementation_result = | Replied | Delayed_response of unit Deferred.t end module F = struct type ('a, 'b) result_mode = ('a, 'b) F.result_mode = | Blocking : ('a, 'a) result_mode | Deferred : ('a, 'a Deferred.t) result_mode type ('connection_state, 'query, 'init, 'update) streaming_impl = ('connection_state, 'query, 'init, 'update) F.streaming_impl = | Pipe of ('connection_state -> 'query -> ('init * 'update Pipe.Reader.t, 'init) Result.t Deferred.t) | Direct of ('connection_state -> 'query -> 'update Implementation_types.Direct_stream_writer.t -> ('init, 'init) Result.t Deferred.t) type 'connection_state t = 'connection_state F.t = | One_way : 'msg Bin_prot.Type_class.reader * ('connection_state -> 'msg -> unit) -> 'connection_state t | One_way_expert : ('connection_state -> Bigstring.t -> pos:int -> len:int -> unit) -> 'connection_state t | Rpc : 'query Bin_prot.Type_class.reader * 'response Bin_prot.Type_class.writer * ('connection_state -> 'query -> 'result) * ('response, 'result) result_mode -> 'connection_state t | Rpc_expert : ('connection_state -> Expert.Responder.t -> Bigstring.t -> pos:int -> len:int -> 'result) * (Expert.implementation_result, 'result) result_mode -> 'connection_state t | Streaming_rpc : 'query Bin_prot.Type_class.reader (* 'init can be an error or an initial state *) * 'init Bin_prot.Type_class.writer * 'update Bin_prot.Type_class.writer * ('connection_state, 'query, 'init, 'update) streaming_impl -> 'connection_state t let sexp_of_t _ = function | One_way_expert _ | One_way _ -> [%message "one-way"] | Rpc_expert _ | Rpc _ -> [%message "rpc"] | Streaming_rpc _ -> [%message "streaming-rpc"] ;; let lift t ~f = match t with | One_way (bin_msg, impl) -> One_way (bin_msg, fun state str -> impl (f state) str) | One_way_expert impl -> One_way_expert (fun state buf ~pos ~len -> impl (f state) buf ~pos ~len) | Rpc (bin_query, bin_response, impl, result_mode) -> Rpc (bin_query, bin_response, (fun state q -> impl (f state) q), result_mode) | Rpc_expert (impl, result_mode) -> Rpc_expert ((fun state resp buf ~pos ~len -> impl (f state) resp buf ~pos ~len), result_mode) | Streaming_rpc (bin_q, bin_i, bin_u, impl) -> let impl = match impl with | Pipe impl -> Pipe (fun state q -> impl (f state) q) | Direct impl -> Direct (fun state q w -> impl (f state) q w) in Streaming_rpc (bin_q, bin_i, bin_u, impl) ;; end type nonrec 'connection_state t = 'connection_state t = { tag : Rpc_tag.t ; version : int ; f : 'connection_state F.t ; shapes : Sexp.t Lazy.t ; on_exception : On_exception.t } [@@deriving sexp_of] let description t = { Description.name = Rpc_tag.to_string t.tag; version = t.version } let lift t ~f = { t with f = F.lift ~f t.f } let update_on_exception t ~f = { t with on_exception = f t.on_exception } async_rpc_kernel-0.15.0/src/implementation.mli000066400000000000000000000051761420273305200214440ustar00rootroot00000000000000(** Internal to [Async_rpc_kernel]. See [Rpc.Implementation]. *) open! Core open! Async_kernel open Protocol open Implementation_types.Implementation module Expert : sig module Responder : sig type t = Expert.Responder.t = { query_id : Query_id.t ; writer : Transport.Writer.t ; mutable responded : bool } [@@deriving sexp_of] val create : Query_id.t -> Transport.Writer.t -> t end type implementation_result = Expert.implementation_result = | Replied | Delayed_response of unit Deferred.t end module F : sig type ('a, 'b) result_mode = ('a, 'b) F.result_mode = | Blocking : ('a, 'a) result_mode | Deferred : ('a, 'a Deferred.t) result_mode type ('connection_state, 'query, 'init, 'update) streaming_impl = ('connection_state, 'query, 'init, 'update) F.streaming_impl = | Pipe of ('connection_state -> 'query -> ('init * 'update Pipe.Reader.t, 'init) Result.t Deferred.t) | Direct of ('connection_state -> 'query -> 'update Implementation_types.Direct_stream_writer.t -> ('init, 'init) Result.t Deferred.t) type 'connection_state t = 'connection_state F.t = | One_way : 'msg Bin_prot.Type_class.reader * ('connection_state -> 'msg -> unit) -> 'connection_state t | One_way_expert : ('connection_state -> Bigstring.t -> pos:int -> len:int -> unit) -> 'connection_state t | Rpc : 'query Bin_prot.Type_class.reader * 'response Bin_prot.Type_class.writer * ('connection_state -> 'query -> 'result) * ('response, 'result) result_mode -> 'connection_state t | Rpc_expert : ('connection_state -> Expert.Responder.t -> Bigstring.t -> pos:int -> len:int -> 'result) * (Expert.implementation_result, 'result) result_mode -> 'connection_state t | Streaming_rpc : 'query Bin_prot.Type_class.reader (* 'init can be an error or an initial state *) * 'init Bin_prot.Type_class.writer * 'update Bin_prot.Type_class.writer * ('connection_state, 'query, 'init, 'update) streaming_impl -> 'connection_state t val lift : 'a t -> f:('b -> 'a) -> 'b t end type 'connection_state t = 'connection_state Implementation_types.Implementation.t = { tag : Rpc_tag.t ; version : int ; f : 'connection_state F.t ; shapes : Sexp.t Lazy.t ; on_exception : On_exception.t } [@@deriving sexp_of] val description : _ t -> Description.t val lift : 'a t -> f:('b -> 'a) -> 'b t val update_on_exception : 'a t -> f:(On_exception.t -> On_exception.t) -> 'a t async_rpc_kernel-0.15.0/src/implementation_types.ml000066400000000000000000000127171420273305200225160ustar00rootroot00000000000000open Core open Async_kernel open Protocol (** The types of the [Implementation] and [Implementations] modules, which have a dependency cyle: [Implementation] -> [Direct_stream_writer] -> [Implementations] -> [Implementation]. *) module Direct_stream_writer_id = Unique_id.Int63 () module On_exception = struct type t = { callback : (exn -> unit) option [@sexp.omit_nil] ; close_connection_if_no_return_value : bool } [@@deriving sexp_of] end module rec Implementation : sig module Expert : sig module Responder : sig type t = { query_id : Query_id.t ; writer : Transport.Writer.t ; mutable responded : bool } end type implementation_result = | Replied | Delayed_response of unit Deferred.t end module F : sig type (_, _) result_mode = | Blocking : ('a, 'a) result_mode | Deferred : ('a, 'a Deferred.t) result_mode type ('connection_state, 'query, 'init, 'update) streaming_impl = | Pipe of ('connection_state -> 'query -> ('init * 'update Pipe.Reader.t, 'init) Result.t Deferred.t) | Direct of ('connection_state -> 'query -> 'update Direct_stream_writer.t -> ('init, 'init) Result.t Deferred.t) type 'connection_state t = | One_way : 'msg Bin_prot.Type_class.reader * ('connection_state -> 'msg -> unit) -> 'connection_state t | One_way_expert : ('connection_state -> Bigstring.t -> pos:int -> len:int -> unit) -> 'connection_state t | Rpc : 'query Bin_prot.Type_class.reader * 'response Bin_prot.Type_class.writer * ('connection_state -> 'query -> 'result) * ('response, 'result) result_mode -> 'connection_state t | Rpc_expert : ('connection_state -> Expert.Responder.t -> Bigstring.t -> pos:int -> len:int -> 'result) * (Expert.implementation_result, 'result) result_mode -> 'connection_state t | Streaming_rpc : 'query Bin_prot.Type_class.reader * 'init Bin_prot.Type_class.writer * 'update Bin_prot.Type_class.writer * ('connection_state, 'query, 'init, 'update) streaming_impl -> 'connection_state t end type 'connection_state t = { tag : Rpc_tag.t ; version : int ; f : 'connection_state F.t ; shapes : Sexp.t Lazy.t ; on_exception : On_exception.t } end = Implementation and Implementations : sig type 'connection_state on_unknown_rpc = [ `Raise | `Continue | `Close_connection | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] | `Expert of 'connection_state -> rpc_tag:string -> version:int -> Implementation.Expert.Responder.t -> Bigstring.t -> pos:int -> len:int -> unit Deferred.t ] type 'connection_state t = { implementations : 'connection_state Implementation.t Description.Table.t ; on_unknown_rpc : 'connection_state on_unknown_rpc } type 'connection_state implementations = 'connection_state t module rec Instance : sig type streaming_response = | Pipe : _ Pipe.Reader.t -> streaming_response | Direct : _ Direct_stream_writer.t -> streaming_response type 'a unpacked = { implementations : 'a implementations ; writer : Transport.Writer.t ; open_streaming_responses : (Query_id.t, streaming_response) Hashtbl.t ; mutable stopped : bool ; connection_state : 'a ; connection_description : Info.t ; connection_close_started : Info.t Deferred.t ; mutable last_dispatched_implementation : (Description.t * 'a Implementation.t) option ; packed_self : t } and t = T : _ unpacked -> t end end = Implementations and Direct_stream_writer : sig module Pending_response : sig type 'a t = | Normal of 'a | Expert of string end module State : sig type 'a t = | Not_started of 'a Pending_response.t Queue.t | Started end module Id = Direct_stream_writer_id type 'a t = { id : Id.t ; mutable state : 'a State.t ; closed : unit Ivar.t ; instance : Implementations.Instance.t ; query_id : Query_id.t ; stream_writer : 'a Cached_stream_writer.t ; groups : 'a group_entry Bag.t } and 'a group_entry = { group : 'a Direct_stream_writer.Group.t ; element_in_group : 'a t Bag.Elt.t } module Group : sig type 'a direct_stream_writer = 'a t type 'a t = { (* [components] is only tracked separately from [components_by_id] so we can iterate over its elements more quickly than we could iterate over the values of [components_by_id]. *) mutable components : 'a direct_stream_writer Bag.t ; components_by_id : 'a component Id.Table.t ; buffer : Bigstring.t ref } and 'a component = { writer_element_in_group : 'a direct_stream_writer Bag.Elt.t ; group_element_in_writer : 'a group_entry Bag.Elt.t } end with type 'a direct_stream_writer := 'a t end = Direct_stream_writer and Cached_stream_writer : sig type 'a t = { header_prefix : string (* Bin_protted constant prefix of the message *) ; mutable data_len : Nat0.t ; bin_writer : 'a Bin_prot.Type_class.writer } end = Cached_stream_writer async_rpc_kernel-0.15.0/src/implementations.ml000066400000000000000000001033251420273305200214510ustar00rootroot00000000000000open Core open Poly open Async_kernel open Util open Implementation_types.Implementations module P = Protocol module Writer = Transport.Writer (* The Result monad is also used. *) let ( >>|~ ) = Result.( >>| ) (* Commute Result and Deferred. *) let defer_result : 'a 'b. ('a Deferred.t, 'b) Result.t -> ('a, 'b) Result.t Deferred.t = function | Error _ as err -> return err | Ok d -> (match Deferred.peek d with | None -> let%map x = d in Ok x | Some d -> return (Ok d)) ;; module Deferred_immediate = Monad.Make (struct type 'a t = 'a Deferred.t let return = return let bind d ~f = match Deferred.peek d with | None -> d >>= f | Some x -> f x ;; let map d ~f = match Deferred.peek d with | None -> d >>| f | Some x -> return (f x) ;; let map = `Custom map end) module Responder = Implementation.Expert.Responder type 'connection_state on_unknown_rpc = [ `Raise | `Continue | `Close_connection | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] ] type 'connection_state on_unknown_rpc_with_expert = [ 'connection_state on_unknown_rpc | `Expert of 'connection_state -> rpc_tag:string -> version:int -> Responder.t -> Bigstring.t -> pos:int -> len:int -> unit Deferred.t ] type 'connection_state t = 'connection_state Implementation_types.Implementations.t = { implementations : 'connection_state Implementation.t Description.Table.t ; on_unknown_rpc : 'connection_state on_unknown_rpc_with_expert } type 'connection_state implementations = 'connection_state t let descriptions t = Hashtbl.keys t.implementations module Instance = struct type streaming_response = Instance.streaming_response = | Pipe : _ Pipe.Reader.t -> streaming_response | Direct : (_ Implementation_types.Direct_stream_writer.t[@sexp.opaque]) -> streaming_response [@@deriving sexp_of] type streaming_responses = (P.Query_id.t, streaming_response) Hashtbl.t [@@deriving sexp_of] type 'a unpacked = 'a Instance.unpacked = { implementations : ('a implementations[@sexp.opaque]) ; writer : Writer.t ; open_streaming_responses : streaming_responses ; mutable stopped : bool ; connection_state : 'a ; connection_description : Info.t ; connection_close_started : Info.t Deferred.t ; mutable last_dispatched_implementation : (Description.t * ('a Implementation.t[@sexp.opaque])) option (* [packed_self] is here so we can essentially pack an unpacked instance without doing any additional allocation. *) ; packed_self : (t[@sexp.opaque]) } [@@deriving sexp_of] and t = Instance.t = T : _ unpacked -> t let sexp_of_t (T t) = [%sexp_of: _ unpacked] t let send_write_error t id sexp = let data : _ P.Message.t = Response { id; data = Error (Write_error sexp) } in match Writer.send_bin_prot t.writer P.Message.bin_writer_nat0_t data with | Sent () | Closed -> () | Message_too_big _ as r -> raise_s [%sexp "Failed to send write error to client" , { error = (sexp : Sexp.t); reason = (r : unit Transport.Send_result.t) }] ;; let handle_send_result t id (result : _ Transport.Send_result.t) = match result with | Sent () -> () | Closed -> () | Message_too_big _ as r -> send_write_error t id ([%sexp_of: unit Transport.Send_result.t] r) ;; let write_message t ~id bin_writer x = if not t.stopped then Writer.send_bin_prot t.writer bin_writer x |> handle_send_result t id ;; let write_message_expert t ~id bin_writer x ~buf ~pos ~len = if not t.stopped then Writer.send_bin_prot_and_bigstring t.writer bin_writer x ~buf ~pos ~len |> handle_send_result t id ;; let write_response t id bin_writer_data data = let bin_writer = P.Message.bin_writer_needs_length (Writer_with_length.of_writer bin_writer_data) in write_message t ~id bin_writer (Response { id; data }) ;; module Cached_stream_writer : sig type instance type 'a t = 'a Implementation_types.Cached_stream_writer.t val create : id:P.Query_id.t -> bin_writer:'a Bin_prot.Type_class.writer -> 'a t val write : 'a t -> instance -> P.Query_id.t -> 'a -> unit val write_expert : 'a t -> instance -> P.Query_id.t -> buf:Bigstring.t -> pos:int -> len:int -> unit val write_string : 'a t -> instance -> P.Query_id.t -> string -> unit end with type instance := t = struct type 'a t = 'a Implementation_types.Cached_stream_writer.t = { header_prefix : string (* Bin_protted constant prefix of the message *) ; (* Length of the user data part. We set this field when sending a message. This relies on the fact that the message is serialized immediately (which is the only acceptable semantics for the transport layer anyway, as it doesn't know if the value is mutable or not). [data_len] is passed to bin-prot writers by mutating [data_len] instead of by passing an additional argument to avoid some allocation. *) mutable data_len : Nat0.t ; bin_writer : 'a Bin_prot.Type_class.writer } type void = Void let bin_size_void Void = 0 let bin_write_void _buf ~pos Void = pos type void_message = void P.Message.needs_length [@@deriving bin_write] type void_stream_response_data = void P.Stream_response_data.needs_length [@@deriving bin_write] (* This is not re-entrant but Async code always runs on one thread at a time *) let buffer = Bigstring.create 32 let cache_bin_protted (bin_writer : _ Bin_prot.Type_class.writer) x = let len = bin_writer.write buffer ~pos:0 x in Bigstring.To_string.sub buffer ~pos:0 ~len ;; let create (type a) ~id ~bin_writer : a t = let header_prefix = cache_bin_protted bin_writer_void_message (Response { id; data = Ok Void }) in { header_prefix; bin_writer; data_len = Nat0.of_int_exn 0 } ;; (* This part of the message header is a constant, make it a literal to make the writing code slightly faster. *) let stream_response_data_header_len = 4 let stream_response_data_header_as_int32 = 0x8a79l let%test_unit "stream_response_* constants are correct" = let len = bin_writer_void_stream_response_data.write buffer ~pos:0 (`Ok Void : void_stream_response_data) in assert (len = stream_response_data_header_len); assert ( Bigstring.unsafe_get_int32_t_le buffer ~pos:0 = stream_response_data_header_as_int32) ;; let bin_write_string_no_length buf ~pos str = let str_len = String.length str in (* Very low-level bin_prot stuff... *) Bin_prot.Common.assert_pos pos; let next = pos + str_len in Bin_prot.Common.check_next buf next; Bin_prot.Common.unsafe_blit_string_buf ~src_pos:0 str ~dst_pos:pos buf ~len:str_len; next ;; (* The two following functions are used by the 3 variants exposed by this module. They serialize a [Response { id; data = Ok (`Ok data_len) }] value, taking care of writing the [Nat0.t] length prefix where approriate. Bear in mind that there are two levels of length prefixes for stream response data message: one for the user data (under the `Ok, before the actual data), and one for the response data (under the .data field, before the Ok). *) let bin_size_nat0_header { header_prefix; data_len; _ } = let stream_response_data_nat0_len = stream_response_data_header_len + Nat0.bin_size_t data_len in let stream_response_data_len = stream_response_data_nat0_len + (data_len : Nat0.t :> int) in String.length header_prefix + Nat0.bin_size_t (Nat0.of_int_exn stream_response_data_len) + stream_response_data_nat0_len ;; let bin_write_nat0_header buf ~pos { header_prefix; data_len; _ } = let pos = bin_write_string_no_length buf ~pos header_prefix in let stream_response_data_len = stream_response_data_header_len + Nat0.bin_size_t data_len + (data_len : Nat0.t :> int) in let pos = Nat0.bin_write_t buf ~pos (Nat0.of_int_exn stream_response_data_len) in let next = pos + 4 in Bin_prot.Common.check_next buf next; Bigstring.unsafe_set_int32_t_le buf ~pos stream_response_data_header_as_int32; Nat0.bin_write_t buf ~pos:next data_len ;; let bin_writer_nat0_header : _ Bin_prot.Type_class.writer = { size = bin_size_nat0_header; write = bin_write_nat0_header } ;; let bin_size_message (t, _) = bin_size_nat0_header t + (t.data_len : Nat0.t :> int) let bin_write_message buf ~pos (t, data) = let pos = bin_write_nat0_header buf ~pos t in t.bin_writer.write buf ~pos data ;; let bin_writer_message : _ Bin_prot.Type_class.writer = { size = bin_size_message; write = bin_write_message } ;; let bin_size_message_as_string (t, _) = bin_size_nat0_header t + (t.data_len : Nat0.t :> int) ;; let bin_write_message_as_string buf ~pos (t, str) = let pos = bin_write_nat0_header buf ~pos t in bin_write_string_no_length buf ~pos str ;; let bin_writer_message_as_string : _ Bin_prot.Type_class.writer = { size = bin_size_message_as_string; write = bin_write_message_as_string } ;; (* [write] and [write_string] both allocate 3 words for the tuples. [write_expert] does not allocate. *) let write t (T instance) id data = t.data_len <- Nat0.of_int_exn (t.bin_writer.size data); write_message instance ~id bin_writer_message (t, data) ;; let write_string t (T instance) id str = t.data_len <- Nat0.of_int_exn (String.length str); write_message instance ~id bin_writer_message_as_string (t, str) ;; let write_expert t (T instance) id ~buf ~pos ~len = t.data_len <- Nat0.of_int_exn len; write_message_expert instance ~id bin_writer_nat0_header t ~buf ~pos ~len ;; end module Direct_stream_writer = struct module T = Implementation_types.Direct_stream_writer module State = T.State module Id = T.Id type 'a t = 'a T.t = { id : Id.t ; mutable state : 'a State.t ; closed : unit Ivar.t ; instance : Instance.t ; query_id : P.Query_id.t ; stream_writer : 'a Cached_stream_writer.t ; groups : 'a group_entry Bag.t } and 'a group_entry = 'a T.group_entry = { group : 'a T.Group.t ; element_in_group : 'a t Bag.Elt.t } let is_closed t = Ivar.is_full t.closed let closed t = Ivar.read t.closed let flushed t = let (T instance) = t.instance in Transport.Writer.flushed instance.writer ;; let bin_writer t = t.stream_writer.bin_writer let write_eof { instance = T instance; query_id; _ } = write_response instance query_id P.Stream_response_data.bin_writer_nat0_t (Ok `Eof) ;; let write_message { instance; stream_writer; query_id; _ } x = Cached_stream_writer.write stream_writer instance query_id x ;; let write_message_string { instance; stream_writer; query_id; _ } x = Cached_stream_writer.write_string stream_writer instance query_id x ;; let write_message_expert { instance; stream_writer; query_id; _ } ~buf ~pos ~len = Cached_stream_writer.write_expert stream_writer instance query_id ~buf ~pos ~len ;; let close_without_removing_from_instance t = if not (Ivar.is_full t.closed) then ( Ivar.fill t.closed (); let groups = t.groups in if not (Bag.is_empty groups) then Async_kernel_scheduler.Private.Very_low_priority_work.enqueue ~f:(fun () -> match Bag.remove_one groups with | None -> Finished | Some { group; element_in_group } -> Bag.remove group.components element_in_group; Hashtbl.remove group.components_by_id t.id; Not_finished); match t.state with | Not_started _ -> () | Started -> write_eof t) ;; let close ({ instance = T instance; query_id; _ } as t) = close_without_removing_from_instance t; Hashtbl.remove instance.open_streaming_responses query_id ;; let write_without_pushback t x = if Ivar.is_full t.closed then `Closed else ( (match t.state with | Not_started q -> Queue.enqueue q (Normal x) | Started -> write_message t x); `Ok) ;; let write ({ instance = T instance; _ } as t) x = match write_without_pushback t x with | `Closed -> `Closed | `Ok -> `Flushed (Writer.flushed instance.writer) ;; module Expert = struct let write_without_pushback t ~buf ~pos ~len = if Ivar.is_full t.closed then `Closed else ( (match t.state with | Not_started q -> Queue.enqueue q (Expert (Bigstring.To_string.sub buf ~pos ~len)) | Started -> write_message_expert t ~buf ~pos ~len); `Ok) ;; let write ({ instance = T instance; _ } as t) ~buf ~pos ~len = match write_without_pushback t ~buf ~pos ~len with | `Closed -> `Closed | `Ok -> `Flushed (Writer.flushed instance.writer) ;; end let start t = match t.state with | Started -> failwith "attempted to start writer which was already started" | Not_started q -> t.state <- Started; Queue.iter q ~f:(function | Normal x -> write_message t x | Expert x -> write_message_string t x); if Ivar.is_full t.closed then write_eof t ;; end let maybe_dispatch_on_exception (result : (_, Rpc_error.t) Result.t) on_exception ~close_connection_monitor = match result with | Error (Uncaught_exn sexp) -> On_exception.handle_exn on_exception ~close_connection_monitor (Exn.create_s sexp) | Error _ | Ok _ -> () ;; let apply_implementation t implementation ~(query : Nat0.t P.Query.t) ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor ~on_exception : _ Transport.Handler_result.t = let id = query.id in match implementation with | Implementation.F.One_way (bin_query_reader, f) -> let query_contents = bin_read_from_bigstring bin_query_reader read_buffer ~pos_ref:read_buffer_pos_ref ~len:query.data ~location:"server-side one-way rpc message un-bin-io'ing" in (match query_contents with | Error _ as err -> Stop err | Ok q -> (try f t.connection_state q; Continue with | exn -> On_exception.handle_exn on_exception ~close_connection_monitor exn; if on_exception.close_connection_if_no_return_value then Stop (Rpc_result.uncaught_exn exn ~location:"server-side one-way rpc computation") else Continue)) | Implementation.F.One_way_expert f -> (try let len = (query.data :> int) in f t.connection_state read_buffer ~pos:!read_buffer_pos_ref ~len; read_buffer_pos_ref := !read_buffer_pos_ref + len; Continue with | exn -> On_exception.handle_exn on_exception ~close_connection_monitor exn; if on_exception.close_connection_if_no_return_value then Stop (Rpc_result.uncaught_exn exn ~location:"server-side one-way rpc expert computation") else Continue) | Implementation.F.Rpc (bin_query_reader, bin_response_writer, f, result_mode) -> let query_contents = bin_read_from_bigstring bin_query_reader read_buffer ~pos_ref:read_buffer_pos_ref ~len:query.data ~location:"server-side rpc query un-bin-io'ing" in (match result_mode with | Implementation.F.Blocking -> (try query_contents >>|~ f t.connection_state |> write_response t id bin_response_writer with | exn -> (* In the [Deferred] branch we use [Monitor.try_with], which includes backtraces when it catches an exception. For consistency, we also get backtraces here. *) let backtrace = Backtrace.Exn.most_recent () in let sexp = [%sexp { location = "server-side blocking rpc computation" ; exn : exn ; backtrace : Backtrace.t }] in write_response t id bin_response_writer (Error (Rpc_error.Uncaught_exn sexp)); On_exception.handle_exn on_exception ~close_connection_monitor exn) | Implementation.F.Deferred -> let data = (* We generally try to write a response before handling [on_exception] so if we are closing the connection we still actually send the response back. When we pass [on_exception.callback] here, we are making it possible for raised exceptions not to be written back to the client (e.g. if the implementation raises both asynchronously and synchronously). This would be hard to handle in a more principled way. *) Rpc_result.try_with ?on_background_exception:on_exception.callback ~run:`Now ~location:"server-side rpc computation" (fun () -> defer_result (query_contents >>|~ f t.connection_state)) in (* In the common case that the implementation returns a value immediately, we will write the response immediately as well (this is also why the above [try_with] has [~run:`Now]). This can be a big performance win for servers that get many queries in a single Async cycle. *) (match Deferred.peek data with | None -> data >>> fun data -> write_response t id bin_response_writer data; maybe_dispatch_on_exception data on_exception ~close_connection_monitor | Some data -> write_response t id bin_response_writer data; maybe_dispatch_on_exception data on_exception ~close_connection_monitor)); Continue | Implementation.F.Rpc_expert (f, result_mode) -> let responder = Implementation.Expert.Responder.create query.id t.writer in let d = (* We need the [Monitor.try_with] even for the blocking mode as the implementation might return [Delayed_reponse], so we don't bother optimizing the blocking mode. *) let rest = match on_exception.callback with | None -> `Log | Some callback -> `Call callback in Monitor.try_with ~rest ~run:`Now (fun () -> let len = (query.data :> int) in let result = f t.connection_state responder read_buffer ~pos:!read_buffer_pos_ref ~len in match result_mode with | Implementation.F.Deferred -> result | Implementation.F.Blocking -> Deferred.return result) in let handle_exn ~is_uncaught_exn exn = let result = Rpc_result.uncaught_exn exn ~location:"server-side rpc expert computation" in let result = if responder.responded then result else ( write_response t id bin_writer_unit result; Ok ()) in if is_uncaught_exn then On_exception.handle_exn on_exception ~close_connection_monitor exn; result in let check_responded () = if responder.responded then Ok () else handle_exn ~is_uncaught_exn:false (Failure "Expert implementation did not reply") in let d = let open Deferred_immediate.Let_syntax in match%map d with | Ok result -> let d = match result with | Replied -> Deferred.unit | Delayed_response d -> d in if Deferred.is_determined d then check_responded () else ( upon d (fun () -> check_responded () |> Rpc_result.or_error ~rpc_description: { name = P.Rpc_tag.to_string query.tag; version = query.version } ~connection_description:t.connection_description ~connection_close_started:t.connection_close_started |> ok_exn); Ok ()) | Error exn -> handle_exn ~is_uncaught_exn:true exn in (match Deferred.peek d with | None -> Wait (let%map r = d in ok_exn (Rpc_result.or_error ~rpc_description: { name = P.Rpc_tag.to_string query.tag; version = query.version } ~connection_description:t.connection_description ~connection_close_started:t.connection_close_started r)) | Some result -> (match result with | Ok () -> Continue | Error _ -> Stop result)) | Implementation.F.Streaming_rpc (bin_query_reader, bin_init_writer, bin_update_writer, impl) -> let stream_query = bin_read_from_bigstring P.Stream_query.bin_reader_nat0_t read_buffer ~pos_ref:read_buffer_pos_ref ~len:query.data ~location:"server-side pipe_rpc stream_query un-bin-io'ing" ~add_len:(function | `Abort -> 0 | `Query (len : Nat0.t) -> (len :> int)) in (match stream_query with | Error _err -> () | Ok `Abort -> (* Note that there's some delay between when we receive a pipe RPC query and when we put something in [open_streaming_responses] (we wait for a user-supplied function to return). During this time, an abort message would just be ignored. The dispatcher can't abort the query while this is happening, though, since the interface doesn't expose the ID required to abort the query until after a response has been returned. *) Option.iter (Hashtbl.find t.open_streaming_responses query.id) ~f:(function | Pipe pipe -> Pipe.close_read pipe | Direct w -> Direct_stream_writer.close w) | Ok (`Query len) -> let data = bin_read_from_bigstring bin_query_reader read_buffer ~pos_ref:read_buffer_pos_ref ~len ~location:"streaming_rpc server-side query un-bin-io'ing" in let stream_writer = Cached_stream_writer.create ~id ~bin_writer:bin_update_writer in let impl_with_state = match impl with | Pipe f -> `Pipe f | Direct f -> let writer : _ Direct_stream_writer.t = { id = Direct_stream_writer.Id.create () ; state = Not_started (Queue.create ()) ; closed = Ivar.create () ; instance = t.packed_self ; query_id = id ; groups = Bag.create () ; stream_writer } in Hashtbl.set t.open_streaming_responses ~key:query.id ~data:(Direct writer); `Direct (f, writer) in let run_impl impl split_ok handle_ok = Rpc_result.try_with ?on_background_exception:on_exception.callback (fun () -> defer_result (data >>|~ impl)) ~location:"server-side pipe_rpc computation" >>> function | Error (Uncaught_exn sexp as err) -> Hashtbl.remove t.open_streaming_responses id; write_response t id bin_init_writer (Error err); On_exception.handle_exn on_exception ~close_connection_monitor (Exn.create_s sexp) | Error err -> Hashtbl.remove t.open_streaming_responses id; write_response t id bin_init_writer (Error err) | Ok (Error err) -> Hashtbl.remove t.open_streaming_responses id; write_response t id bin_init_writer (Ok err) | Ok (Ok ok) -> let initial, rest = split_ok ok in write_response t id bin_init_writer (Ok initial); handle_ok rest in (match impl_with_state with | `Pipe f -> run_impl (fun data -> f t.connection_state data) Fn.id (fun pipe_r -> Hashtbl.set t.open_streaming_responses ~key:id ~data:(Pipe pipe_r); don't_wait_for (Writer.transfer t.writer pipe_r (Cached_stream_writer.write stream_writer t.packed_self id)); Pipe.closed pipe_r >>> fun () -> Pipe.upstream_flushed pipe_r >>> function | `Ok | `Reader_closed -> write_response t id P.Stream_response_data.bin_writer_nat0_t (Ok `Eof); Hashtbl.remove t.open_streaming_responses id) | `Direct (f, writer) -> run_impl (fun data -> f t.connection_state data writer) (fun x -> x, ()) (fun () -> Direct_stream_writer.start writer))); Continue ;; let flush (T t) = assert (not t.stopped); let producers_flushed = Hashtbl.fold t.open_streaming_responses ~init:[] ~f:(fun ~key:_ ~data acc -> match data with | Direct _ -> acc | Pipe pipe -> Deferred.ignore_m (Pipe.upstream_flushed pipe) :: acc) in Deferred.all_unit producers_flushed ;; let stop (T t) = t.stopped <- true; Hashtbl.iter t.open_streaming_responses ~f:(function | Direct writer -> (* Don't remove the writer from the instance, as that would modify the hashtable that we are currently iterating over. *) Direct_stream_writer.close_without_removing_from_instance writer | Pipe _ -> ()); Hashtbl.clear t.open_streaming_responses ;; let handle_unknown_rpc on_unknown_rpc error t query : _ Transport.Handler_result.t = match on_unknown_rpc with | `Continue -> Continue | `Raise -> Rpc_error.raise error t.connection_description | `Close_connection -> Stop (Ok ()) | `Call f -> (match f t.connection_state ~rpc_tag:(P.Rpc_tag.to_string query.P.Query.tag) ~version:query.version with | `Close_connection -> Stop (Ok ()) | `Continue -> Continue) ;; let handle_query_internal t ~(query : Nat0.t P.Query.t) ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor = let { implementations; on_unknown_rpc } = t.implementations in let description : Description.t = { name = P.Rpc_tag.to_string query.tag; version = query.version } in match t.last_dispatched_implementation with | Some (last_desc, implementation) when Description.equal last_desc description -> apply_implementation t implementation.f ~query ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor ~on_exception:implementation.on_exception | None | Some _ -> (match Hashtbl.find implementations description with | Some implementation -> t.last_dispatched_implementation <- Some (description, implementation); apply_implementation t implementation.f ~on_exception:implementation.on_exception ~query ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor | None -> (match on_unknown_rpc with | `Expert impl -> let { P.Query.tag; version; id; data = len } = query in let d = let responder = Responder.create id t.writer in impl t.connection_state ~rpc_tag:(P.Rpc_tag.to_string tag) ~version responder read_buffer ~pos:!read_buffer_pos_ref ~len:(len :> int) in if Deferred.is_determined d then Continue else Wait d | (`Continue | `Raise | `Close_connection | `Call _) as on_unknown_rpc -> let error = Rpc_error.Unimplemented_rpc (query.tag, `Version query.version) in write_response t query.id P.Message.bin_writer_nat0_t (Error error); handle_unknown_rpc on_unknown_rpc error t query)) ;; let handle_query (T t) ~query ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor = if t.stopped || Writer.is_closed t.writer then Transport.Handler_result.Stop (Ok ()) else handle_query_internal t ~query ~read_buffer ~read_buffer_pos_ref ~close_connection_monitor ;; end module Direct_stream_writer = Instance.Direct_stream_writer let create ~implementations:i's ~on_unknown_rpc = (* Make sure the tags are unique. *) let implementations = Description.Table.create ~size:10 () in let dups = Description.Hash_set.create ~size:10 () in List.iter i's ~f:(fun (i : _ Implementation.t) -> let description = { Description.name = P.Rpc_tag.to_string i.tag; version = i.version } in match Hashtbl.add implementations ~key:description ~data:i with | `Ok -> () | `Duplicate -> Hash_set.add dups description); if not (Hash_set.is_empty dups) then Error (`Duplicate_implementations (Hash_set.to_list dups)) else Ok { implementations ; on_unknown_rpc = (on_unknown_rpc :> _ on_unknown_rpc_with_expert) } ;; let instantiate t ~connection_description ~connection_close_started ~connection_state ~writer = let rec unpacked : _ Instance.unpacked = { implementations = t ; writer ; open_streaming_responses = Hashtbl.Poly.create ~size:10 () ; connection_state ; connection_description ; connection_close_started ; stopped = false ; last_dispatched_implementation = None ; packed_self = Instance.T unpacked } in unpacked.packed_self ;; exception Duplicate_implementations of Description.t list [@@deriving sexp] let create_exn ~implementations ~on_unknown_rpc = match create ~implementations ~on_unknown_rpc with | Ok x -> x | Error (`Duplicate_implementations dups) -> raise (Duplicate_implementations dups) ;; let null () = create_exn ~implementations:[] ~on_unknown_rpc:`Raise let add_exn t (implementation : _ Implementation.t) = let desc : Description.t = { name = P.Rpc_tag.to_string implementation.tag; version = implementation.version } in let implementations = Hashtbl.copy t.implementations in match Hashtbl.add implementations ~key:desc ~data:implementation with | `Duplicate -> raise (Duplicate_implementations [ desc ]) | `Ok -> { t with implementations } ;; let add t implementation = Or_error.try_with (fun () -> add_exn t implementation) let lift { implementations; on_unknown_rpc } ~f = let implementations = Hashtbl.map implementations ~f:(Implementation.lift ~f) in let on_unknown_rpc = match on_unknown_rpc with | (`Raise | `Continue | `Close_connection) as x -> x | `Call call -> `Call (fun state -> call (f state)) | `Expert expert -> `Expert (fun state -> expert (f state)) in { implementations; on_unknown_rpc } ;; module Expert = struct module Responder = Responder module Rpc_responder = struct type t = Responder.t let cannot_send r = failwiths ~here:[%here] "Message cannot be sent" r [%sexp_of: _ Transport.Send_result.t] ;; let mark_responded (t : t) = if t.responded then failwiths ~here:[%here] "Already responded" t [%sexp_of: Responder.t]; t.responded <- true ;; let schedule (t : t) buf ~pos ~len = mark_responded t; let header : Nat0.t P.Message.t = Response { id = t.query_id; data = Ok (Nat0.of_int_exn len) } in match Writer.send_bin_prot_and_bigstring_non_copying t.writer P.Message.bin_writer_nat0_t header ~buf ~pos ~len with | Sent d -> `Flushed d | Closed -> `Connection_closed | Message_too_big _ as r -> cannot_send r ;; let handle_send_result : unit Transport.Send_result.t -> unit = function | Sent () | Closed -> () | Message_too_big _ as r -> cannot_send r ;; let write_bigstring (t : t) buf ~pos ~len = mark_responded t; let header : Nat0.t P.Message.t = Response { id = t.query_id; data = Ok (Nat0.of_int_exn len) } in Writer.send_bin_prot_and_bigstring t.writer P.Message.bin_writer_nat0_t header ~buf ~pos ~len |> handle_send_result ;; let write_error (t : t) error = mark_responded t; let data = Rpc_result.uncaught_exn ~location:"server-side raw rpc computation" (Error.to_exn error) in Writer.send_bin_prot t.writer P.Message.bin_writer_nat0_t (Response { id = t.query_id; data }) |> handle_send_result ;; let write_bin_prot (t : t) bin_writer_a a = mark_responded t; Writer.send_bin_prot t.writer (P.Message.bin_writer_needs_length (Writer_with_length.of_writer bin_writer_a)) (Response { id = t.query_id; data = Ok a }) |> handle_send_result ;; end let create_exn = create_exn end async_rpc_kernel-0.15.0/src/implementations.mli000066400000000000000000000073251420273305200216250ustar00rootroot00000000000000(** Internal to [Async_rpc_kernel]. See [Rpc.Implementations]. *) open! Core open! Async_kernel open Protocol type 'a t type 'connection_state on_unknown_rpc = [ `Raise | `Continue | `Close_connection | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] ] val create : implementations:'connection_state Implementation.t list -> on_unknown_rpc:'connection_state on_unknown_rpc -> ('connection_state t, [ `Duplicate_implementations of Description.t list ]) Result.t val null : unit -> 'a t val lift : 'a t -> f:('b -> 'a) -> 'b t module Direct_stream_writer : sig type 'a t = 'a Implementation_types.Direct_stream_writer.t module Id = Implementation_types.Direct_stream_writer.Id val close : _ t -> unit val closed : _ t -> unit Deferred.t val is_closed : _ t -> bool val write : 'a t -> 'a -> [ `Flushed of unit Deferred.t | `Closed ] val write_without_pushback : 'a t -> 'a -> [ `Ok | `Closed ] val flushed : _ t -> unit Deferred.t val bin_writer : 'a t -> 'a Bin_prot.Type_class.writer module Expert : sig val write : 'a t -> buf:Bigstring.t -> pos:int -> len:int -> [ `Flushed of unit Deferred.t | `Closed ] val write_without_pushback : 'a t -> buf:Bigstring.t -> pos:int -> len:int -> [ `Ok | `Closed ] end end module Instance : sig type t [@@deriving sexp_of] val handle_query : t -> query:Nat0.t Query.t -> read_buffer:Bigstring.t -> read_buffer_pos_ref:int ref -> close_connection_monitor:Monitor.t -> unit Rpc_result.t Transport.Handler_result.t (* Flushes all open streaming responses *) val flush : t -> unit Deferred.t (* Stop the instance: drop all responses to pending requests and make all further call to [handle_query] or [flush] to fail. *) val stop : t -> unit end val instantiate : 'a t -> connection_description:Info.t -> connection_close_started:Info.t Deferred.t -> connection_state:'a -> writer:Transport.Writer.t -> Instance.t val create_exn : implementations:'connection_state Implementation.t list -> on_unknown_rpc: [ `Raise | `Continue | `Close_connection | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] ] -> 'connection_state t val add : 'connection_state t -> 'connection_state Implementation.t -> 'connection_state t Or_error.t val add_exn : 'connection_state t -> 'connection_state Implementation.t -> 'connection_state t val descriptions : _ t -> Description.t list module Expert : sig module Responder = Implementation.Expert.Responder module Rpc_responder : sig type t = Responder.t val schedule : t -> Bigstring.t -> pos:int -> len:int -> [ `Connection_closed | `Flushed of unit Deferred.t ] val write_bigstring : t -> Bigstring.t -> pos:int -> len:int -> unit val write_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> unit val write_error : t -> Error.t -> unit end val create_exn : implementations:'connection_state Implementation.t list -> on_unknown_rpc: [ `Raise | `Continue | `Close_connection | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] | `Expert of 'connection_state -> rpc_tag:string -> version:int -> Responder.t -> Bigstring.t -> pos:int -> len:int -> unit Deferred.t ] -> 'connection_state t end async_rpc_kernel-0.15.0/src/nat0.ml000066400000000000000000000010201420273305200170700ustar00rootroot00000000000000type t = Bin_prot.Nat0.t [@@deriving bin_shape ~basetype:"899e2f4a-490a-11e6-b68f-bbd62472516c"] let bin_t = Bin_prot.Type_class.bin_nat0 let bin_size_t = Bin_prot.Size.bin_size_nat0 let bin_writer_t = Bin_prot.Type_class.bin_writer_nat0 let bin_write_t = Bin_prot.Write.bin_write_nat0 let bin_reader_t = Bin_prot.Type_class.bin_reader_nat0 let bin_read_t = Bin_prot.Read.bin_read_nat0 let __bin_read_t__ _buf ~pos_ref _vnat0 = Bin_prot.Common.raise_variant_wrong_type "t" !pos_ref ;; let of_int_exn = Bin_prot.Nat0.of_int async_rpc_kernel-0.15.0/src/nat0.mli000066400000000000000000000002601420273305200172460ustar00rootroot00000000000000(** The bin-prot representation of lengths of strings, arrays, etc. *) type t = Bin_prot.Nat0.t [@@deriving bin_io] (** fails on negative values *) val of_int_exn : int -> t async_rpc_kernel-0.15.0/src/on_exception.ml000066400000000000000000000012021420273305200207220ustar00rootroot00000000000000open Core open Async_kernel type t = Implementation_types.On_exception.t = { callback : (exn -> unit) option [@sexp.omit_nil] ; close_connection_if_no_return_value : bool } [@@deriving sexp_of] let close_connection = { callback = None; close_connection_if_no_return_value = true } let continue = { callback = None; close_connection_if_no_return_value = false } let handle_exn { callback; close_connection_if_no_return_value } ~close_connection_monitor exn = Option.iter callback ~f:(fun callback -> callback exn); if close_connection_if_no_return_value then Monitor.send_exn close_connection_monitor exn ;; async_rpc_kernel-0.15.0/src/on_exception.mli000066400000000000000000000004551420273305200211040ustar00rootroot00000000000000open Core open Async_kernel type t = Implementation_types.On_exception.t = { callback : (exn -> unit) option ; close_connection_if_no_return_value : bool } [@@deriving sexp_of] val close_connection : t val continue : t val handle_exn : t -> close_connection_monitor:Monitor.t -> Exn.t -> unit async_rpc_kernel-0.15.0/src/persistent_connection.ml000066400000000000000000000012071420273305200226540ustar00rootroot00000000000000open! Core open! Async_kernel include Persistent_connection_kernel module Versioned_rpc = Make (struct type t = Versioned_rpc.Connection_with_menu.t let rpc_connection = Versioned_rpc.Connection_with_menu.connection let close t = Rpc.Connection.close (rpc_connection t) let is_closed t = Rpc.Connection.is_closed (rpc_connection t) let close_finished t = Rpc.Connection.close_finished (rpc_connection t) end) module Rpc = Make (struct type t = Rpc.Connection.t let close t = Rpc.Connection.close t let is_closed t = Rpc.Connection.is_closed t let close_finished t = Rpc.Connection.close_finished t end) async_rpc_kernel-0.15.0/src/persistent_connection.mli000066400000000000000000000003511420273305200230240ustar00rootroot00000000000000open! Core open! Async_kernel include module type of struct include Persistent_connection_kernel end module Rpc : S with type conn = Rpc.Connection.t module Versioned_rpc : S with type conn = Versioned_rpc.Connection_with_menu.t async_rpc_kernel-0.15.0/src/pipe_transport.ml000066400000000000000000000423611420273305200213140ustar00rootroot00000000000000open Core open Async_kernel open Int.Replace_polymorphic_compare include struct open Transport module Header = Header module Handler_result = Handler_result module Send_result = Send_result module Reader = Reader module Writer = Writer end let rec pipe_read t f = match%bind Pipe.values_available t with | `Eof -> f `Eof | `Ok -> (match Pipe.read_now' t with | `Nothing_available -> pipe_read t f | (`Eof | `Ok _) as res -> f res) ;; module type DATA = sig type t [@@deriving sexp_of] val length : t -> int val add_to_bigbuffer : Bigbuffer.t -> t -> unit val to_bigstring : t -> Bigstring.t val of_bigstring : Bigstring.t -> t end module Pipe_and_buffer = struct type 'a t = { pipe : 'a Pipe.Reader.t ; buffer : Bigbuffer.t } [@@deriving sexp_of] let create pipe = { pipe; buffer = Bigbuffer.create Header.length } end module Pipe_reader (Data : DATA) = struct type t = Data.t Pipe_and_buffer.t [@@deriving sexp_of] let close (t : t) = Pipe.close_read t.pipe; Deferred.unit ;; let is_closed (t : t) = Pipe.is_closed t.pipe let read_forever (t : t) ~on_message ~on_end_of_batch : (_, _) Deferred.Result.t = let buffer = t.buffer in (* Dequeue until enough data ([need]) is available and try read messages *) let rec process_queue ~need queue = match Queue.dequeue queue with | None -> (* Queue is empty - we need to wait for more data *) return (Second need) | Some data -> let buff_len = Bigbuffer.length buffer in let data_len = Data.length data in if buff_len = 0 && data_len >= need then (* We have enough data and buffer is empty. This is the common case where every bin_prot message is sent in its own websocket frame *) process_data ~pos:0 ~data:(Data.to_bigstring data) ~length:data_len queue else ( (* Slow path. We have to accumulate [Bigstring.t]s *) Data.add_to_bigbuffer buffer data; if Bigbuffer.length buffer >= need then ( (* There is enough data in the buffer *) let data = Bigbuffer.volatile_contents buffer in let length = Bigbuffer.length buffer in process_data ~pos:0 ~data ~length queue) else (* We need more data - keep processing the queue *) process_queue ~need queue) (* Read as many messages as possible from the current data *) and process_data ~pos ~data ~length queue = if length >= Header.length then ( let payload_len = Header.unsafe_get_payload_length data ~pos in let total_len = Header.length + payload_len in if length >= total_len then ( match on_message data ~pos:(pos + Header.length) ~len:payload_len with | Handler_result.Stop x -> let pos = pos + total_len in let length = length - total_len in (* Make sure that all data we've read (and not "consumed") from the pipe is kept in the buffer. That is the remaining bits in [data] and all contents in [queue]. *) set_buffer ~pos ~length ~data; Queue.iter queue ~f:(fun data -> Data.add_to_bigbuffer buffer data); return (First x) | (Continue | Wait _) as continue_or_wait -> let%bind () = match continue_or_wait with | Handler_result.Stop _ -> (* Impossible: this branch does not contain [Stop _] *) assert false | Continue -> Deferred.unit | Wait d -> d in let pos = pos + total_len in let length = length - total_len in assert (length >= 0); if length > 0 then (* Process the rest of the data. More than one bin_prot message was sent inside the websocket frame *) process_data ~pos ~data ~length queue else (* length = 0 *) (* All data was read - keep processing the queue *) set_buffer_and_process_queue ~need:Header.length ~pos ~length:0 ~queue ~data) else set_buffer_and_process_queue ~need:total_len ~pos ~length ~queue ~data) else set_buffer_and_process_queue ~need:Header.length ~pos ~length ~queue ~data and set_buffer ~pos ~length ~data = if length = 0 then Bigbuffer.clear buffer else ( let data = Bigstring.sub data ~pos ~len:length in Bigbuffer.clear buffer; Bigbuffer.add_bigstring buffer data) and set_buffer_and_process_queue ~need ~pos ~length ~queue ~data = set_buffer ~pos ~length ~data; process_queue ~need queue in let rec wait_for_read ~need = pipe_read t.pipe (function | `Eof -> return (Error `Eof) | `Ok queue -> process_queue ~need queue >>= end_of_batch_and_continue) and end_of_batch_and_continue next = on_end_of_batch (); match next with | First result -> return (Ok result) | Second need -> wait_for_read ~need in let start_processing_existing_data ~data ~length = process_data ~pos:0 ~data ~length (Queue.create ()) >>= end_of_batch_and_continue in (* We either start by - processing remaining bits in the buffer - or waiting for more data in the pipe *) let need = Header.length in let length = Bigbuffer.length buffer in if Int.( < ) length need then wait_for_read ~need else start_processing_existing_data ~length ~data:(Bigbuffer.volatile_contents buffer) ;; module For_testing = struct type t = Data.t let of_bigstring = Data.of_bigstring end end module Pipe_and_monitor = struct type 'a t = { pipe : 'a Pipe.Writer.t ; monitor : Monitor.t } [@@deriving sexp_of] let create pipe = { pipe; monitor = Monitor.create () } end (* We don't perform any buffering here. A message is consider to be flushed as soon as it enters the pipe. *) module Pipe_writer (Data : DATA) = struct type t = Data.t Pipe_and_monitor.t [@@deriving sexp_of] let close (t : t) = Pipe.close t.pipe; Deferred.unit ;; let is_closed (t : t) = Pipe.is_closed t.pipe let monitor (t : t) = t.monitor (* Because we don't maintain any buffer, there are no pending writes *) let bytes_to_write (_ : t) = 0 let stopped (t : t) = Pipe.closed t.pipe (* We consider that a message is flushed as soon as it reaches the underlining transport. *) let flushed (_ : t) = Deferred.unit let ready_to_write = flushed let sent_result x : _ Send_result.t = Sent x let check_closed (t : t) f = if not (Pipe.is_closed t.pipe) then f () else Send_result.Closed ;; let send_bin_prot t writer x = check_closed t (fun () -> let buf = Bin_prot.Utils.bin_dump ~header:true writer x in Pipe.write_without_pushback t.pipe (Data.of_bigstring buf); sent_result ()) ;; let send_bin_prot_and_bigstring t (writer : _ Bin_prot.Type_class.writer) x ~buf ~pos ~len:payload_size = check_closed t (fun () -> (* Write the size header manually and concatenate the two *) let data_size = writer.size x in let data = Bigstring.create (data_size + Header.length + payload_size) in Header.unsafe_set_payload_length data ~pos:0 (data_size + payload_size); let dst_pos = writer.write data ~pos:Header.length x in Bigstring.blit ~src:buf ~src_pos:pos ~dst:data ~dst_pos ~len:payload_size; Pipe.write_without_pushback t.pipe (Data.of_bigstring data); sent_result ()) ;; let send_bin_prot_and_bigstring_non_copying t writer x ~buf ~pos ~len = match send_bin_prot_and_bigstring t writer x ~buf ~pos ~len with | Sent () -> sent_result Deferred.unit | (Closed | Message_too_big _) as r -> r ;; end module Bigstring_data = struct type t = Bigstring.t [@@deriving sexp_of] let length = Bigstring.length let add_to_bigbuffer = Bigbuffer.add_bigstring let to_bigstring x = x let of_bigstring x = x end module String_data = struct type t = String.t [@@deriving sexp_of] let length = String.length let add_to_bigbuffer = Bigbuffer.add_string let to_bigstring x = Bigstring.of_string x let of_bigstring x = Bigstring.to_string x end module Bigstring_pipe_reader = Pipe_reader (Bigstring_data) module Bigstring_pipe_writer = Pipe_writer (Bigstring_data) module String_pipe_reader = Pipe_reader (String_data) module String_pipe_writer = Pipe_writer (String_data) module Kind = struct type 'a t = | String : string t | Bigstring : bigstring t let string = String let bigstring = Bigstring end let make_reader (type a) (x : a Kind.t) (reader : a Pipe.Reader.t) = let reader = Pipe_and_buffer.create reader in match x with | Kind.String -> Reader.pack (module String_pipe_reader) reader | Kind.Bigstring -> Reader.pack (module Bigstring_pipe_reader) reader ;; let make_writer (type a) (x : a Kind.t) (writer : a Pipe.Writer.t) = let writer = Pipe_and_monitor.create writer in match x with | Kind.String -> Writer.pack (module String_pipe_writer) writer | Kind.Bigstring -> Writer.pack (module Bigstring_pipe_writer) writer ;; let create kind reader writer = { Transport.reader = make_reader kind reader; writer = make_writer kind writer } ;; (* Testing *) module type Transport_reader = sig module For_testing : sig type t val of_bigstring : Bigstring.t -> t end include Transport.Reader.S with type t = For_testing.t Pipe_and_buffer.t end module Test_reader (Transport_reader : Transport_reader) = struct open Transport_reader.For_testing let default_message = Bigstring.of_string "FOOBAR123" let create_message_buf (message : Bigstring.t) : Bigstring.t = let message_len = Bigstring.length message in let buf = Bigstring.create (Header.length + message_len) in Header.unsafe_set_payload_length buf ~pos:0 message_len; Bigstring.blit ~src:message ~dst:buf ~src_pos:0 ~dst_pos:Header.length ~len:message_len; buf ;; let create_message () = create_message_buf default_message let on_message ?(message = default_message) on_message_count buffer ~pos ~len = on_message_count := !on_message_count + 1; [%test_result: Bigstring.t] (Bigstring.sub buffer ~pos ~len) ~expect:message; Handler_result.Continue ;; let on_end_of_batch on_end_of_batch_count () = incr on_end_of_batch_count let wait () = Async_kernel_scheduler.Expert.run_cycles_until_no_jobs_remain () let run_test run verify = let reader, writer = Pipe.create () in let reader = Pipe_and_buffer.create reader in let on_message_count = ref 0 in let on_end_of_batch_count = ref 0 in let on_message = on_message on_message_count in let on_end_of_batch = on_end_of_batch on_end_of_batch_count in ignore (Transport_reader.read_forever reader ~on_message ~on_end_of_batch); wait (); run (fun x -> Pipe.write_without_pushback writer (of_bigstring x)); wait (); verify ~on_message_count ~on_end_of_batch_count ;; let verify ~on_message_count ~on_end_of_batch_count message_count batch_count = [%test_result: int] !on_message_count ~expect:message_count; [%test_result: int] !on_end_of_batch_count ~expect:batch_count ;; let write_1_msg_1_chunk write = write (create_message ()) (* Not enough data, we need to accumulate *) let write_1_msg_3_chunk write = let buf = create_message_buf (Bigstring.of_string "") in let message_raw = default_message in Header.unsafe_set_payload_length buf ~pos:0 (Bigstring.length message_raw); write buf; wait (); let msg_len = Bigstring.length message_raw in let split_at = msg_len / 2 in let part1 = Bigstring.sub message_raw ~pos:0 ~len:split_at in let part2 = Bigstring.sub message_raw ~pos:split_at ~len:(msg_len - split_at) in write part1; wait (); write part2 ;; (* Too much data, we need to loop withing the same batch *) let write_2_msg_1_chunk write = let one_msg = create_message_buf default_message in let two_msg = Bigstring.concat [ one_msg; one_msg ] in write two_msg ;; let write_2_msg_one_byte_at_a_time_34_chunk write = let one_msg = create_message_buf default_message in let two_msg = Bigstring.concat [ one_msg; one_msg ] in for i = 0 to Bigstring.length two_msg - 1 do write (Bigstring.sub two_msg ~pos:i ~len:1); wait () done ;; let%test_unit _ = run_test write_1_msg_1_chunk (verify 1 1) let%test_unit _ = let f write = write_1_msg_1_chunk write; write_1_msg_1_chunk write in run_test f (verify 2 1) ;; let%test_unit _ = run_test write_1_msg_3_chunk (verify 1 3) let%test_unit _ = run_test write_2_msg_1_chunk (verify 2 1) let%test_unit _ = run_test write_2_msg_one_byte_at_a_time_34_chunk (verify 2 34) let%test_unit _ = let f write = write (create_message ()); wait (); write_1_msg_3_chunk write; wait (); write_2_msg_1_chunk write; wait (); write_2_msg_one_byte_at_a_time_34_chunk write; wait (); write (create_message ()) in run_test f (verify 7 40) ;; let%test_unit "can call read_forever multiple times" = let reader, writer = Pipe.create () in let reader = Pipe_and_buffer.create reader in let on_end_of_batch () = () in let write x = Pipe.write_without_pushback writer (of_bigstring x) in let num = ref 0 in let stop_after_on_message buffer ~pos ~len = incr num; [%test_result: Bigstring.t] (Bigstring.sub buffer ~pos ~len) ~expect:default_message; Handler_result.Stop () in write_2_msg_1_chunk write; Pipe.close writer; don't_wait_for (let%bind x = Transport_reader.read_forever reader ~on_message:stop_after_on_message ~on_end_of_batch in assert (Result.is_ok x); let%bind x = Transport_reader.read_forever reader ~on_message:stop_after_on_message ~on_end_of_batch in assert (Result.is_ok x); Deferred.unit); wait (); [%test_result: Int.t] ~expect:2 !num ;; end let%test_module "Test_reader_string" = (module Test_reader (String_pipe_reader)) let%test_module "Test_reader_bigstring" = (module Test_reader (Bigstring_pipe_reader)) module Bench_reader (Transport_reader : Transport_reader) = struct open Transport_reader.For_testing let default_message = Bigstring.of_string "FOOBAR123" let create_message_buf (message : Bigstring.t) : Bigstring.t = let message_len = Bigstring.length message in let buf = Bigstring.create (Header.length + message_len) in Header.unsafe_set_payload_length buf ~pos:0 message_len; Bigstring.blit ~src:message ~dst:buf ~src_pos:0 ~dst_pos:Header.length ~len:message_len; buf ;; let create_message () = create_message_buf default_message let one_message = create_message () let two_messages = Bigstring.concat [ one_message; one_message ] let one_message_p1, one_message_p2 = let msg_len = Bigstring.length one_message in let split_at = msg_len / 2 in let part1 = Bigstring.sub one_message ~pos:0 ~len:split_at in let part2 = Bigstring.sub one_message ~pos:split_at ~len:(msg_len - split_at) in part1, part2 ;; let on_message _buffer ~pos:_ ~len:_ = Handler_result.Continue let on_end_of_batch () = () let wait () = Async_kernel_scheduler.Expert.run_cycles_until_no_jobs_remain () let run_test run = let reader, writer = Pipe.create () in let reader = Pipe_and_buffer.create reader in let on_message = on_message in let on_end_of_batch = on_end_of_batch in ignore (Transport_reader.read_forever reader ~on_message ~on_end_of_batch); wait (); for _ = 0 to 100 do run (fun x -> Pipe.write_without_pushback writer (of_bigstring x)) done; wait () ;; let write_1_msg_1_chunk write = write one_message (* Not enough data, we need to accumulate *) let buf = create_message_buf (Bigstring.of_string "") let write_1_msg_3_chunk write = Header.unsafe_set_payload_length buf ~pos:0 (Bigstring.length one_message); write buf; write one_message_p1; write one_message_p2 ;; (* Too much data, we need to loop withing the same batch *) let write_2_msg_1_chunk write = write two_messages let write_2_msg_one_byte_at_a_time_34_chunk write = for i = 0 to Bigstring.length two_messages - 1 do write (Bigstring.sub two_messages ~pos:i ~len:1) done ;; let%bench "write_1_msg_1_chunk" = run_test write_1_msg_1_chunk let%bench "write_2_msg_1_chunk" = let f write = write_1_msg_1_chunk write; write_1_msg_1_chunk write in run_test f ;; let%bench "write_1_msg_3_chunk" = run_test write_1_msg_3_chunk let%bench "write_2_msg_1_chunk" = run_test write_2_msg_1_chunk let%bench "write_2_msg_one_byte" = run_test write_2_msg_one_byte_at_a_time_34_chunk let%bench "multi" = let f write = write (create_message ()); write_1_msg_3_chunk write; write_2_msg_1_chunk write; write_2_msg_one_byte_at_a_time_34_chunk write; write (create_message ()) in run_test f ;; end let%bench_module "Test_reader_string" = (module Bench_reader (String_pipe_reader)) let%bench_module "Test_reader_bigstring" = (module Bench_reader (Bigstring_pipe_reader)) async_rpc_kernel-0.15.0/src/pipe_transport.mli000066400000000000000000000006341420273305200214620ustar00rootroot00000000000000open! Core open Async_kernel module Kind : sig type 'a t val string : String.t t val bigstring : Bigstring.t t end (** Create an rpc [Transport.t] using async pipes. The resulting transport will not perform any buffering. It will always write to the pipe writer without push-back and always be considered flushed. *) val create : 'a Kind.t -> 'a Pipe.Reader.t -> 'a Pipe.Writer.t -> Transport.t async_rpc_kernel-0.15.0/src/protocol.ml000066400000000000000000000054421420273305200201030ustar00rootroot00000000000000(** Async_rpc protocol types, for internal use only *) (* WARNING: do not change any of these types without good reason *) open Bin_prot.Std open Sexplib.Std module Rpc_tag : Core.Identifiable = Core.String module Query_id = Core.Unique_id.Int63 () module Unused_query_id : sig type t [@@deriving bin_io, sexp_of] val t : t end = struct type t = Query_id.t [@@deriving bin_io, sexp_of] let t = Query_id.create () end module Rpc_error : sig open Core type t = | Bin_io_exn of Sexp.t | Connection_closed | Write_error of Sexp.t | Uncaught_exn of Sexp.t | Unimplemented_rpc of Rpc_tag.t * [ `Version of int ] | Unknown_query_id of Query_id.t [@@deriving bin_io, sexp, compare] include Comparable.S with type t := t end = struct module T = struct type t = | Bin_io_exn of Core.Sexp.t | Connection_closed | Write_error of Core.Sexp.t | Uncaught_exn of Core.Sexp.t | Unimplemented_rpc of Rpc_tag.t * [ `Version of Core.Int.Stable.V1.t ] | Unknown_query_id of Query_id.t [@@deriving bin_io, sexp, compare] let%expect_test "stable" = print_endline [%bin_digest: t]; [%expect {| 8cc766befa2cf565ea147d9fcd5eaaab |}] ;; end include T include Core.Comparable.Make (T) end module Rpc_result = struct type 'a t = ('a, Rpc_error.t) Core.Result.t [@@deriving bin_io, sexp_of] end module Header = Protocol_version_header module Query = struct type 'a needs_length = { tag : Rpc_tag.t ; version : int ; id : Query_id.t ; data : 'a } [@@deriving bin_io, sexp_of] type 'a t = 'a needs_length [@@deriving bin_read] end module Response = struct type 'a needs_length = { id : Query_id.t ; data : 'a Rpc_result.t } [@@deriving bin_io, sexp_of] type 'a t = 'a needs_length [@@deriving bin_read] end module Stream_query = struct type 'a needs_length = [ `Query of 'a | `Abort ] [@@deriving bin_io] type 'a t = 'a needs_length [@@deriving bin_read] type nat0_t = Nat0.t needs_length [@@deriving bin_read, bin_write] end module Stream_initial_message = struct type ('response, 'error) t = { unused_query_id : Unused_query_id.t ; initial : ('response, 'error) Core.Result.t } [@@deriving bin_io, sexp_of] end module Stream_response_data = struct type 'a needs_length = [ `Ok of 'a | `Eof ] [@@deriving bin_io] type 'a t = 'a needs_length [@@deriving bin_read] type nat0_t = Nat0.t needs_length [@@deriving bin_read, bin_write] end module Message = struct type 'a needs_length = | Heartbeat | Query of 'a Query.needs_length | Response of 'a Response.needs_length [@@deriving bin_io, sexp_of] type 'a t = 'a needs_length [@@deriving bin_read, sexp_of] type nat0_t = Nat0.t needs_length [@@deriving bin_read, bin_write] end async_rpc_kernel-0.15.0/src/rpc.ml000066400000000000000000000765211420273305200170340ustar00rootroot00000000000000 open Core open Async_kernel open Util module P = Protocol module Description = Description module On_exception = On_exception module Implementation = Implementation module Implementations = Implementations module Transport = Transport module Connection = Connection (* The Result monad is also used. *) let ( >>=~ ) = Result.( >>= ) let ( >>|~ ) = Result.( >>| ) module Rpc_common = struct let dispatch_raw' conn ~tag ~version ~bin_writer_query ~query ~query_id ~response_handler = let query = { P.Query.tag; version; id = query_id; data = query } in match Connection.dispatch conn ~response_handler ~bin_writer_query ~query with | Ok () -> Ok () | Error `Closed -> Error Rpc_error.Connection_closed ;; let dispatch_raw conn ~tag ~version ~bin_writer_query ~query ~query_id ~f = let response_ivar = Ivar.create () in (match dispatch_raw' conn ~tag ~version ~bin_writer_query ~query ~query_id ~response_handler:(Some (f response_ivar)) with | Ok () -> () | Error _ as e -> Ivar.fill response_ivar e); Ivar.read response_ivar ;; end let shapes lst = Sexp.List (List.map lst ~f:(fun (name, shape) -> [%message "" ~_:(name : string) ~_:(Bin_prot.Shape.eval_to_digest_string shape : string)])) ;; module Rpc = struct type ('query, 'response) t = { tag : P.Rpc_tag.t ; version : int ; bin_query : 'query Bin_prot.Type_class.t ; bin_response : 'response Bin_prot.Type_class.t ; query_type_id : 'query Type_equal.Id.t ; response_type_id : 'response Type_equal.Id.t } let create ~name ~version ~bin_query ~bin_response = let query_type_id = Type_equal.Id.create ~name:[%string "%{name}:query"] sexp_of_opaque in let response_type_id = Type_equal.Id.create ~name:[%string "%{name}:response"] sexp_of_opaque in { tag = P.Rpc_tag.of_string name ; version ; bin_query ; bin_response ; query_type_id ; response_type_id } ;; let name t = P.Rpc_tag.to_string t.tag let version t = t.version let description t = { Description.name = name t; version = version t } let query_type_id t = t.query_type_id let response_type_id t = t.response_type_id let bin_query t = t.bin_query let bin_response t = t.bin_response let shapes t = shapes [ "query", t.bin_query.shape; "response", t.bin_response.shape ] let implement ?(on_exception = On_exception.continue) t f = { Implementation.tag = t.tag ; version = t.version ; f = Rpc (t.bin_query.reader, t.bin_response.writer, f, Deferred) ; shapes = lazy (shapes t) ; on_exception } ;; let implement' ?(on_exception = On_exception.continue) t f = { Implementation.tag = t.tag ; version = t.version ; f = Rpc (t.bin_query.reader, t.bin_response.writer, f, Blocking) ; shapes = lazy (shapes t) ; on_exception } ;; let dispatch' t conn query = let response_handler ivar (response : _ P.Response.t) ~read_buffer ~read_buffer_pos_ref = let response = response.data >>=~ fun len -> bin_read_from_bigstring t.bin_response.reader read_buffer ~pos_ref:read_buffer_pos_ref ~len ~location:"client-side rpc response un-bin-io'ing" in Ivar.fill ivar response; `remove (Ok ()) in let query_id = P.Query_id.create () in Rpc_common.dispatch_raw conn ~tag:t.tag ~version:t.version ~bin_writer_query:t.bin_query.writer ~query ~query_id ~f:response_handler ;; let rpc_result_to_or_error t conn result = Rpc_result.or_error result ~rpc_description:(description t) ~connection_description:(Connection.description conn) ~connection_close_started:(Connection.close_reason ~on_close:`started conn) ;; let dispatch t conn query = let%map result = dispatch' t conn query in rpc_result_to_or_error t conn result ;; let dispatch_exn t conn query = dispatch t conn query >>| Or_error.ok_exn module Expert = struct module Responder = Implementations.Expert.Rpc_responder let make_dispatch do_dispatch conn ~rpc_tag ~version buf ~pos ~len ~handle_response ~handle_error = let response_handler : Connection.response_handler = fun response ~read_buffer ~read_buffer_pos_ref -> match response.data with | Error e -> handle_error (Error.t_of_sexp (Rpc_error.sexp_of_t ~get_connection_close_reason:(fun () -> [%sexp (Deferred.peek (Connection.close_reason ~on_close:`started conn) : Info.t option)]) e)); `remove (Ok ()) | Ok len -> let len = (len : Nat0.t :> int) in let d = handle_response read_buffer ~pos:!read_buffer_pos_ref ~len in read_buffer_pos_ref := !read_buffer_pos_ref + len; if Deferred.is_determined d then `remove (Ok ()) else `remove_and_wait d in do_dispatch conn ~tag:(P.Rpc_tag.of_string rpc_tag) ~version buf ~pos ~len ~response_handler:(Some response_handler) ;; let dispatch conn ~rpc_tag ~version buf ~pos ~len ~handle_response ~handle_error = match make_dispatch Connection.dispatch_bigstring conn ~rpc_tag ~version buf ~pos ~len ~handle_response ~handle_error with | Ok () -> `Ok | Error `Closed -> `Connection_closed ;; let schedule_dispatch conn ~rpc_tag ~version buf ~pos ~len ~handle_response ~handle_error = match make_dispatch Connection.schedule_dispatch_bigstring conn ~rpc_tag ~version buf ~pos ~len ~handle_response ~handle_error with | Ok d -> `Flushed d | Error `Closed -> `Connection_closed ;; type implementation_result = Implementation.Expert.implementation_result = | Replied | Delayed_response of unit Deferred.t let implement ?(on_exception = On_exception.continue) t f = { Implementation.tag = t.tag ; version = t.version ; f = Rpc_expert (f, Deferred) ; shapes = lazy (shapes t) ; on_exception } ;; let implement' ?(on_exception = On_exception.continue) t f = { Implementation.tag = t.tag ; version = t.version ; f = Rpc_expert (f, Blocking) ; shapes = lazy (shapes t) ; on_exception } ;; let implement_for_tag_and_version ?(on_exception = On_exception.continue) ~rpc_tag ~version f = { Implementation.tag = P.Rpc_tag.of_string rpc_tag ; version ; f = Rpc_expert (f, Deferred) ; shapes = lazy (Sexp.Atom "Unknown") ; on_exception } ;; let implement_for_tag_and_version' ?(on_exception = On_exception.continue) ~rpc_tag ~version f = { Implementation.tag = P.Rpc_tag.of_string rpc_tag ; version ; f = Rpc_expert (f, Blocking) ; shapes = lazy (Sexp.Atom "Unknown") ; on_exception } ;; end end module One_way = struct type 'msg t = { tag : P.Rpc_tag.t ; version : int ; bin_msg : 'msg Bin_prot.Type_class.t ; msg_type_id : 'msg Type_equal.Id.t } [@@deriving fields] let name t = P.Rpc_tag.to_string t.tag let create ~name ~version ~bin_msg = let msg_type_id = Type_equal.Id.create ~name:[%string "%{name}:msg"] sexp_of_opaque in { tag = P.Rpc_tag.of_string name; version; bin_msg; msg_type_id } ;; let shapes t = shapes [ "msg", t.bin_msg.shape ] let description t = { Description.name = name t; version = version t } let msg_type_id t = t.msg_type_id let implement ?(on_exception = On_exception.close_connection) t f = { Implementation.tag = t.tag ; version = t.version ; f = One_way (t.bin_msg.reader, f) ; shapes = lazy (shapes t) ; on_exception } ;; let dispatch' t conn query = let query_id = P.Query_id.create () in Rpc_common.dispatch_raw' conn ~tag:t.tag ~version:t.version ~bin_writer_query:t.bin_msg.writer ~query ~query_id ~response_handler:None ;; let rpc_result_to_or_error t conn result = Rpc_result.or_error result ~rpc_description:(description t) ~connection_description:(Connection.description conn) ~connection_close_started:(Connection.close_reason ~on_close:`started conn) ;; let dispatch t conn query = dispatch' t conn query |> fun result -> rpc_result_to_or_error t conn result ;; let dispatch_exn t conn query = Or_error.ok_exn (dispatch t conn query) module Expert = struct let implement ?(on_exception = On_exception.close_connection) t f = { Implementation.tag = t.tag ; version = t.version ; f = One_way_expert f ; shapes = lazy (shapes t) ; on_exception } ;; let dispatch { tag; version; bin_msg = _; msg_type_id = _ } conn buf ~pos ~len = match Connection.dispatch_bigstring conn ~tag ~version buf ~pos ~len ~response_handler:None with | Ok () -> `Ok | Error `Closed -> `Connection_closed ;; let schedule_dispatch { tag; version; bin_msg = _; msg_type_id = _ } conn buf ~pos ~len = match Connection.schedule_dispatch_bigstring conn ~tag ~version buf ~pos ~len ~response_handler:None with | Ok flushed -> `Flushed flushed | Error `Closed -> `Connection_closed ;; end end module Pipe_close_reason = struct type t = | Closed_locally | Closed_remotely | Error of Error.t [@@deriving bin_io, compare, sexp] module Stable = struct module V1 = struct type nonrec t = t = | Closed_locally | Closed_remotely | Error of Error.Stable.V2.t [@@deriving bin_io, compare, sexp] end end end (* the basis of the implementations of Pipe_rpc and State_rpc *) module Streaming_rpc = struct module Initial_message = P.Stream_initial_message type ('query, 'initial_response, 'update_response, 'error_response) t = { tag : P.Rpc_tag.t ; version : int ; bin_query : 'query Bin_prot.Type_class.t ; bin_initial_response : 'initial_response Bin_prot.Type_class.t ; bin_update_response : 'update_response Bin_prot.Type_class.t ; bin_error_response : 'error_response Bin_prot.Type_class.t ; client_pushes_back : bool ; query_type_id : 'query Type_equal.Id.t ; initial_response_type_id : 'initial_response Type_equal.Id.t ; update_response_type_id : 'update_response Type_equal.Id.t ; error_response_type_id : 'error_response Type_equal.Id.t } let create ?client_pushes_back ~name ~version ~bin_query ~bin_initial_response ~bin_update_response ~bin_error ~alias_for_initial_response ~alias_for_update_response () = let client_pushes_back = match client_pushes_back with | None -> false | Some () -> true in let query_type_id = Type_equal.Id.create ~name:[%string "%{name}:query"] sexp_of_opaque in let initial_response_type_id = Type_equal.Id.create ~name:[%string "%{name}:%{alias_for_initial_response}"] sexp_of_opaque in let update_response_type_id = Type_equal.Id.create ~name:[%string "%{name}:%{alias_for_update_response}"] sexp_of_opaque in let error_response_type_id = Type_equal.Id.create ~name:[%string "%{name}:error"] sexp_of_opaque in { tag = P.Rpc_tag.of_string name ; version ; bin_query ; bin_initial_response ; bin_update_response ; bin_error_response = bin_error ; client_pushes_back ; query_type_id ; initial_response_type_id ; update_response_type_id ; error_response_type_id } ;; let make_initial_message x = { Initial_message.unused_query_id = P.Unused_query_id.t; initial = x } ;; let shapes t = shapes [ "query", t.bin_query.shape ; "initial-response", t.bin_initial_response.shape ; "update-response", t.bin_update_response.shape ; "error", t.bin_error_response.shape ] ;; let implement_gen t ?(on_exception = On_exception.continue) impl = let bin_init_writer = Initial_message.bin_writer_t t.bin_initial_response.writer t.bin_error_response.writer in { Implementation.tag = t.tag ; version = t.version ; f = Streaming_rpc (t.bin_query.reader, bin_init_writer, t.bin_update_response.writer, impl) ; shapes = lazy (shapes t) ; on_exception } ;; let implement ?on_exception t f = let f c query = match%map f c query with | Error err -> Error (make_initial_message (Error err)) | Ok (initial, pipe) -> Ok (make_initial_message (Ok initial), pipe) in implement_gen t ?on_exception (Pipe f) ;; let implement_direct ?on_exception t f = let f c query writer = match%map f c query writer with | Error _ as x -> Error (make_initial_message x) | Ok _ as x -> Ok (make_initial_message x) in implement_gen ?on_exception t (Direct f) ;; let abort t conn id = let query = { P.Query.tag = t.tag; version = t.version; id; data = `Abort } in ignore (Connection.dispatch conn ~bin_writer_query:P.Stream_query.bin_writer_nat0_t ~query ~response_handler:None : (unit, [ `Closed ]) Result.t) ;; module Pipe_message = struct type 'a t = | Update of 'a | Closed of [ `By_remote_side | `Error of Error.t ] end module Pipe_response = struct type t = | Continue | Wait of unit Deferred.t end module Pipe_metadata = struct type t = { query_id : P.Query_id.t ; close_reason : Pipe_close_reason.t Deferred.t } let id t = t.query_id let close_reason t = t.close_reason end module Response_state = struct module Update_handler = struct type 'a t = 'a Pipe_message.t -> Pipe_response.t end module Initial = struct type nonrec ('q, 'i, 'u, 'e, 'extra) t = { rpc : ('q, 'i, 'u, 'e) t ; query_id : P.Query_id.t ; make_update_handler : unit -> 'extra * 'u Update_handler.t ; ivar : (P.Query_id.t * 'i * 'extra, 'e) Result.t Rpc_result.t Ivar.t ; connection : Connection.t } end module State = struct type 'a t = | Waiting_for_initial_response : ('q, 'i, 'u, 'e, 'extra) Initial.t -> 'u t | Writing_updates of 'a Bin_prot.Type_class.reader * 'a Update_handler.t end type 'a t = { mutable state : 'a State.t } end let read_error ~get_connection_close_reason (handler : _ Response_state.Update_handler.t) err = let core_err = Error.t_of_sexp (Rpc_error.sexp_of_t ~get_connection_close_reason err) in ignore (handler (Closed (`Error core_err)) : Pipe_response.t); `remove (Error err) ;; let eof (handler : _ Response_state.Update_handler.t) = ignore (handler (Closed `By_remote_side) : Pipe_response.t); `remove (Ok ()) ;; let response_handler ~get_connection_close_reason initial_state : Connection.response_handler = let open Response_state in let state = { state = Waiting_for_initial_response initial_state } in fun response ~read_buffer ~read_buffer_pos_ref -> match state.state with | Writing_updates (bin_reader_update, handler) -> (match response.data with | Error err -> read_error ~get_connection_close_reason handler err | Ok len -> let data = bin_read_from_bigstring P.Stream_response_data.bin_reader_nat0_t read_buffer ~pos_ref:read_buffer_pos_ref ~len ~location:"client-side streaming_rpc response un-bin-io'ing" ~add_len:(function | `Eof -> 0 | `Ok (len : Nat0.t) -> (len :> int)) in (match data with | Error err -> read_error ~get_connection_close_reason handler err | Ok `Eof -> eof handler | Ok (`Ok len) -> let data = bin_read_from_bigstring bin_reader_update read_buffer ~pos_ref:read_buffer_pos_ref ~len ~location:"client-side streaming_rpc response un-bin-io'ing" in (match data with | Error err -> read_error ~get_connection_close_reason handler err | Ok data -> (match handler (Update data) with | Continue -> `keep | Wait d -> `wait d)))) | State.Waiting_for_initial_response initial_handler -> (* We never use [`remove (Error _)] here, since that indicates that the connection should be closed, and these are "normal" errors. (In contrast, the errors we get in the [Writing_updates_to_pipe] case indicate more serious problems.) Instead, we just put errors in [ivar]. *) let error err = Ivar.fill initial_handler.ivar (Error err); `remove (Ok ()) in (match response.data with | Error err -> error err | Ok len -> let initial = bin_read_from_bigstring (Initial_message.bin_reader_t initial_handler.rpc.bin_initial_response.reader initial_handler.rpc.bin_error_response.reader) read_buffer ~pos_ref:read_buffer_pos_ref ~len ~location:"client-side streaming_rpc initial_response un-bin-io'ing" in (match initial with | Error err -> error err | Ok initial_msg -> (match initial_msg.initial with | Error err -> Ivar.fill initial_handler.ivar (Ok (Error err)); `remove (Ok ()) | Ok initial -> let extra, handler = initial_handler.make_update_handler () in Ivar.fill initial_handler.ivar (Ok (Ok (initial_handler.query_id, initial, extra))); state.state <- Writing_updates (initial_handler.rpc.bin_update_response.reader, handler); `keep))) ;; let dispatch_gen t conn query make_update_handler = let bin_writer_query = P.Stream_query.bin_writer_needs_length (Writer_with_length.of_type_class t.bin_query) in let query = `Query query in let query_id = P.Query_id.create () in Rpc_common.dispatch_raw conn ~query_id ~tag:t.tag ~version:t.version ~bin_writer_query ~query ~f:(fun ivar -> response_handler ~get_connection_close_reason:(fun () -> [%sexp (Deferred.peek (Connection.close_reason ~on_close:`started conn) : Info.t option)]) { rpc = t; query_id; connection = conn; ivar; make_update_handler }) >>| Rpc_result.or_error ~rpc_description:{ name = P.Rpc_tag.to_string t.tag; version = t.version } ~connection_description:(Connection.description conn) ~connection_close_started:(Connection.close_reason ~on_close:`started conn) ;; let dispatch_iter t conn query ~f = match%map dispatch_gen t conn query (fun () -> (), f) with | (Error _ | Ok (Error _)) as e -> e | Ok (Ok (id, init, ())) -> Ok (Ok (id, init)) ;; let dispatch t conn query = match%map dispatch_gen t conn query (fun () -> let pipe_r, pipe_w = Pipe.create () in (* Set a small buffer to reduce the number of pushback events *) Pipe.set_size_budget pipe_w 100; let close_reason : Pipe_close_reason.t Ivar.t = Ivar.create () in let f : _ Response_state.Update_handler.t = function | Update data -> if not (Pipe.is_closed pipe_w) then ( Pipe.write_without_pushback pipe_w data; if t.client_pushes_back && Pipe.length pipe_w >= Pipe.size_budget pipe_w then Wait (match%map Pipe.downstream_flushed pipe_w with | `Ok | `Reader_closed -> ()) else Continue) else Continue | Closed reason -> Ivar.fill_if_empty close_reason (match reason with | `By_remote_side -> Closed_remotely | `Error err -> Error err); Pipe.close pipe_w; Continue in (pipe_r, close_reason), f) with | (Error _ | Ok (Error _)) as e -> e | Ok (Ok (id, init, (pipe_r, close_reason))) -> upon (Pipe.closed pipe_r) (fun () -> if not (Ivar.is_full close_reason) then ( abort t conn id; Ivar.fill_if_empty close_reason Closed_locally)); let pipe_metadata : Pipe_metadata.t = { query_id = id; close_reason = Ivar.read close_reason } in Ok (Ok (pipe_metadata, init, pipe_r)) ;; end (* A Pipe_rpc is like a Streaming_rpc, except we don't care about initial state - thus it is restricted to unit and ultimately ignored *) module Pipe_rpc = struct type ('query, 'response, 'error) t = ('query, unit, 'response, 'error) Streaming_rpc.t module Id = P.Query_id module Metadata = Streaming_rpc.Pipe_metadata let create ?client_pushes_back ~name ~version ~bin_query ~bin_response ~bin_error () = Streaming_rpc.create ?client_pushes_back ~name ~version ~bin_query ~bin_initial_response:Unit.bin_t ~bin_update_response:bin_response ~bin_error (* [initial_response] doesn't show up in [Pipe_rpc]'s signature, so the type-id created using [alias_for_initial_response] is unreachable. *) ~alias_for_initial_response:"" ~alias_for_update_response:"response" () ;; let bin_query t = t.Streaming_rpc.bin_query let bin_response t = t.Streaming_rpc.bin_update_response let bin_error t = t.Streaming_rpc.bin_error_response let client_pushes_back t = t.Streaming_rpc.client_pushes_back let implement ?on_exception t f = Streaming_rpc.implement ?on_exception t (fun a query -> let%map x = f a query in x >>|~ fun x -> (), x) ;; module Direct_stream_writer = struct include Implementations.Direct_stream_writer module Group = struct module Buffer = struct type t = Bigstring.t ref let create ?(initial_size = 4096) () = if initial_size < 0 then failwiths ~here:[%here] "Rpc.Pipe_rpc.Direct_stream_writer.Group.Buffer.create got negative buffer \ size" initial_size Int.sexp_of_t; ref (Bigstring.create initial_size) ;; end type 'a direct_stream_writer = 'a t module T = Implementation_types.Direct_stream_writer type 'a t = 'a T.Group.t = { mutable components : 'a direct_stream_writer Bag.t ; components_by_id : 'a component Id.Table.t ; buffer : Bigstring.t ref } and 'a component = 'a T.Group.component = { writer_element_in_group : 'a direct_stream_writer Bag.Elt.t ; group_element_in_writer : 'a T.group_entry Bag.Elt.t } let create ?buffer () = let buffer = match buffer with | None -> Buffer.create () | Some b -> b in { components = Bag.create (); components_by_id = Id.Table.create (); buffer } ;; let length t = Bag.length t.components let add_exn t (writer : _ Implementations.Direct_stream_writer.t) = if is_closed writer then failwith "Rpc.Pipe_rpc.Direct_stream_writer.Group.add_exn: cannot add a closed direct \ stream writer"; if Hashtbl.mem t.components_by_id writer.id then failwith "Rpc.Pipe_rpc.Direct_stream_writer.Group.add_exn: trying to add a direct \ stream writer that is already present in the group"; (match Bag.choose t.components with | None -> () | Some one -> let one = Bag.Elt.value one in if not (phys_equal (bin_writer one) (bin_writer writer)) then failwith "Rpc.Pipe_rpc.Direct_stream_writer.Group.add: cannot add a direct stream \ writer with a different bin_writer"); let writer_element_in_group = Bag.add t.components writer in let group_element_in_writer = Bag.add writer.groups { group = t; element_in_group = writer_element_in_group } in Hashtbl.add_exn t.components_by_id ~key:writer.id ~data:{ writer_element_in_group; group_element_in_writer } ;; let remove t (writer : _ Implementations.Direct_stream_writer.t) = match Hashtbl.find_and_remove t.components_by_id writer.id with | None -> () | Some { writer_element_in_group; group_element_in_writer } -> Bag.remove t.components writer_element_in_group; Bag.remove writer.groups group_element_in_writer ;; let to_list t = Bag.to_list t.components let flushed_or_closed t = to_list t |> List.map ~f:(fun t -> Deferred.any_unit [ flushed t; closed t ]) |> Deferred.all_unit ;; let flushed t = flushed_or_closed t module Expert = struct let write_without_pushback t ~buf ~pos ~len = Bag.iter t.components ~f:(fun direct_stream_writer -> (* Writers are automatically scheduled to be removed from their groups when closed, so [`Closed] here just means that the removal didn't happen yet. *) ignore (Expert.write_without_pushback direct_stream_writer ~buf ~pos ~len : [ `Ok | `Closed ])) ;; let write t ~buf ~pos ~len = write_without_pushback t ~buf ~pos ~len; flushed_or_closed t ;; end let write_without_pushback t x = match Bag.choose t.components with | None -> () | Some one -> let one = Bag.Elt.value one in let { Bin_prot.Type_class.write; size } = bin_writer one in let buffer = !(t.buffer) in (* Optimistic first try *) (match write buffer ~pos:0 x with | len -> Expert.write_without_pushback t ~buf:buffer ~pos:0 ~len | exception _ -> (* It's likely that the exception is due to a buffer overflow, so resize the internal buffer and try again. Technically we could match on [Bin_prot.Common.Buffer_short] only, however we can't easily enforce that custom bin_write_xxx functions raise this particular exception and not [Invalid_argument] or [Failure] for instance. *) let len = size x in Bigstring.unsafe_destroy buffer; let buffer = Bigstring.create (Int.ceil_pow2 len) in t.buffer := buffer; let len = write buffer ~pos:0 x in Expert.write_without_pushback t ~buf:buffer ~pos:0 ~len) ;; let write t x = write_without_pushback t x; flushed_or_closed t ;; end end let implement_direct t f = Streaming_rpc.implement_direct t f let dispatch t conn query = let%map response = Streaming_rpc.dispatch t conn query in response >>|~ fun x -> x >>|~ fun (metadata, (), pipe_r) -> pipe_r, metadata ;; exception Pipe_rpc_failed let dispatch_exn t conn query = let%map result = dispatch t conn query in match result with | Error rpc_error -> raise (Error.to_exn rpc_error) | Ok (Error _) -> raise Pipe_rpc_failed | Ok (Ok pipe_and_id) -> pipe_and_id ;; module Pipe_message = Streaming_rpc.Pipe_message module Pipe_response = Streaming_rpc.Pipe_response let dispatch_iter t conn query ~f = let%map response = Streaming_rpc.dispatch_iter t conn query ~f in response >>|~ fun x -> x >>|~ fun (id, ()) -> id ;; let abort = Streaming_rpc.abort let close_reason = Streaming_rpc.Pipe_metadata.close_reason let name t = P.Rpc_tag.to_string t.Streaming_rpc.tag let version t = t.Streaming_rpc.version let description t = { Description.name = name t; version = version t } let query_type_id t = t.Streaming_rpc.query_type_id let error_type_id t = t.Streaming_rpc.error_response_type_id let response_type_id t = t.Streaming_rpc.update_response_type_id end module State_rpc = struct type ('query, 'state, 'update, 'error) t = ('query, 'state, 'update, 'error) Streaming_rpc.t module Id = P.Query_id module Metadata = Streaming_rpc.Pipe_metadata let create ?client_pushes_back ~name ~version ~bin_query ~bin_state ~bin_update ~bin_error () = Streaming_rpc.create ?client_pushes_back ~name ~version ~bin_query ~bin_initial_response:bin_state ~bin_update_response:bin_update ~bin_error ~alias_for_initial_response:"state" ~alias_for_update_response:"update" () ;; let bin_query t = t.Streaming_rpc.bin_query let bin_state t = t.Streaming_rpc.bin_initial_response let bin_update t = t.Streaming_rpc.bin_update_response let bin_error t = t.Streaming_rpc.bin_error_response let implement = Streaming_rpc.implement let dispatch t conn query = let%map response = Streaming_rpc.dispatch t conn query in response >>|~ fun x -> x >>|~ fun (metadata, state, update_r) -> state, update_r, metadata ;; let abort = Streaming_rpc.abort let close_reason = Streaming_rpc.Pipe_metadata.close_reason let client_pushes_back t = t.Streaming_rpc.client_pushes_back let name t = P.Rpc_tag.to_string t.Streaming_rpc.tag let version t = t.Streaming_rpc.version let description t = { Description.name = name t; version = version t } let query_type_id t = t.Streaming_rpc.query_type_id let state_type_id t = t.Streaming_rpc.initial_response_type_id let update_type_id t = t.Streaming_rpc.update_response_type_id let error_type_id t = t.Streaming_rpc.error_response_type_id end module Any = struct type t = | Rpc : ('q, 'r) Rpc.t -> t | Pipe : ('q, 'r, 'e) Pipe_rpc.t -> t | State : ('q, 's, 'u, 'e) State_rpc.t -> t | One_way : 'm One_way.t -> t let description = function | Rpc rpc -> Rpc.description rpc | Pipe rpc -> Pipe_rpc.description rpc | State rpc -> State_rpc.description rpc | One_way rpc -> One_way.description rpc ;; end module Stable = struct module Description = Description.Stable module Pipe_close_reason = Pipe_close_reason.Stable module Rpc = Rpc module Pipe_rpc = Pipe_rpc module State_rpc = State_rpc module One_way = One_way end async_rpc_kernel-0.15.0/src/rpc.mli000066400000000000000000000737521420273305200172100ustar00rootroot00000000000000(** A library for building asynchronous RPC-style protocols. The approach here is to have a separate representation of the server-side implementation of an RPC (An [Implementation.t]) and the interface that it exports (either an [Rpc.t], a [State_rpc.t] or a [Pipe_rpc.t], but we'll refer to them generically as RPC interfaces). A server builds the [Implementation.t] out of an RPC interface and a function for implementing the RPC, while the client dispatches a request using the same RPC interface. The [Implementation.t] hides the type of the query and the response, whereas the [Rpc.t] is polymorphic in the query and response type. This allows you to build a [Implementations.t] out of a list of [Implementation.t]s. Each RPC also comes with a version number. This is meant to allow support of multiple different versions of what is essentially the same RPC. You can think of it as an extension to the name of the RPC, and in fact, each RPC is uniquely identified by its (name, version) pair. RPCs with the same name but different versions should implement similar functionality. *) open! Core open! Async_kernel module Description : sig type t = Description.t = { name : string ; version : int } [@@deriving compare, hash, sexp_of] include Comparable.S_plain with type t := t include Hashable.S_plain with type t := t val summarize : t list -> Int.Set.t String.Map.t module Stable : sig module V1 : sig type nonrec t = t [@@deriving compare, sexp, bin_io, hash] end end end module On_exception : sig (** When your implementation raises an exception, that exception might happen before a value is returned or after a value is returned. The latter kind of exception is what the [~rest] flag to [Monitor.try_with] is dealing with. In both these cases, [callback] will be called with the exception. In the case where the exception raises before a value is returned, [close_connection_if_no_return_value] determines whether the connection is closed. Exceptions raised after a value is returned will never close a connection. *) type t = { callback : (exn -> unit) option ; close_connection_if_no_return_value : bool } val close_connection : t val continue : t end (** A ['connection_state Implementation.t] is something that knows how to respond to one query, given a ['connection_state]. That is, you can create a ['connection_state Implementation.t] by providing a function which takes a query *and* a ['connection_state] and provides a response. The reason for this is that RPCs often do something like look something up in a master structure. This way, [Implementation.t]s can be created without having the master structure in your hands. *) module Implementation : sig type 'connection_state t [@@deriving sexp_of] val description : _ t -> Description.t (** We may want to use an ['a t] implementation (perhaps provided by someone else) in a ['b t] context. We can do this as long as we can map our state into the state expected by the original implementer. *) val lift : 'a t -> f:('b -> 'a) -> 'b t val update_on_exception : 'a t -> f:(On_exception.t -> On_exception.t) -> 'a t end (** A ['connection_state Implementations.t] is something that knows how to respond to many different queries. It is conceptually a package of ['connection_state Implementation.t]s. *) module Implementations : sig type 'connection_state t = 'connection_state Implementations.t (** a server that can handle no queries *) val null : unit -> 'connection_state t val lift : 'a t -> f:('b -> 'a) -> 'b t type 'connection_state on_unknown_rpc = [ `Raise | `Continue | `Close_connection (** used to be the behavior of [`Ignore] *) | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] (** [rpc_tag] and [version] are the name and version of the unknown rpc *) ] (** [create ~implementations ~on_unknown_rpc] creates a server capable of responding to the rpcs implemented in the implementation list. Be careful about setting [on_unknown_rpc] to [`Raise] because other programs may mistakenly connect to this one causing it to crash. *) val create : implementations:'connection_state Implementation.t list -> on_unknown_rpc:'connection_state on_unknown_rpc -> ( 'connection_state t , [ `Duplicate_implementations of Description.t list ] ) Result.t val create_exn : implementations:'connection_state Implementation.t list -> on_unknown_rpc: [ `Raise | `Continue | `Close_connection (** used to be the behavior of [`Ignore] *) | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] ] -> 'connection_state t val add : 'connection_state t -> 'connection_state Implementation.t -> 'connection_state t Or_error.t val add_exn : 'connection_state t -> 'connection_state Implementation.t -> 'connection_state t val descriptions : _ t -> Description.t list (** Low-level, untyped access to queries. Regular users should ignore this. *) module Expert : sig (** See [Rpc.Expert.Responder] for how to use this. *) module Responder : sig type t end (** Same as [create_exn], except for the additional [`Expert] variant. *) val create_exn : implementations:'connection_state Implementation.t list -> on_unknown_rpc: [ `Raise | `Continue | `Close_connection (** used to be the behavior of [`Ignore] *) | `Call of 'connection_state -> rpc_tag:string -> version:int -> [ `Close_connection | `Continue ] | `Expert of 'connection_state -> rpc_tag:string -> version:int -> Responder.t -> Bigstring.t -> pos:int -> len:int -> unit Deferred.t (** The [Deferred.t] the function returns is only used to determine when it is safe to overwrite the supplied [Bigstring.t], so it is *not* necessary to completely finish handling the query before it is filled in. In particular, if you don't intend to read from the [Bigstring.t] after the function returns, you can return [Deferred.unit]. *) ] -> 'connection_state t end end module Transport = Transport module Connection : Connection_intf.S module Rpc : sig type ('query, 'response) t val create : name:string -> version:int -> bin_query:'query Bin_prot.Type_class.t -> bin_response:'response Bin_prot.Type_class.t -> ('query, 'response) t (** the same values as were passed to create. *) val name : (_, _) t -> string val version : (_, _) t -> int val description : (_, _) t -> Description.t val query_type_id : ('query, _) t -> 'query Type_equal.Id.t val response_type_id : (_, 'response) t -> 'response Type_equal.Id.t val bin_query : ('query, _) t -> 'query Bin_prot.Type_class.t val bin_response : (_, 'response) t -> 'response Bin_prot.Type_class.t (** If the function that implements the RPC raises, the implementer does not see the exception. Instead, it is sent as an error to the caller of the RPC, i.e. the process that called [dispatch] or one of its alternatives.*) val implement : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> ('query, 'response) t -> ('connection_state -> 'query -> 'response Deferred.t) -> 'connection_state Implementation.t (** [implement'] is different from [implement] in that: 1. ['response] is immediately serialized and scheduled for delivery to the RPC dispatcher. 2. Less allocation happens, as none of the Async-related machinery is necessary. [implement] also tries to do 1 when possible, but it is guaranteed to happen with [implement']. *) val implement' : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> ('query, 'response) t -> ('connection_state -> 'query -> 'response) -> 'connection_state Implementation.t (** [dispatch'] exposes [Rpc_result.t] as output. Passing it through [rpc_result_to_or_error] gives you the same result as [dispatch] *) val dispatch' : ('query, 'response) t -> Connection.t -> 'query -> 'response Rpc_result.t Deferred.t val rpc_result_to_or_error : ('query, 'response) t -> Connection.t -> 'response Rpc_result.t -> 'response Or_error.t val dispatch : ('query, 'response) t -> Connection.t -> 'query -> 'response Or_error.t Deferred.t val dispatch_exn : ('query, 'response) t -> Connection.t -> 'query -> 'response Deferred.t module Expert : sig module Responder : sig type t = Implementations.Expert.Responder.t (** As in [Writer], after calling [schedule], you should not overwrite the [Bigstring.t] passed in until the responder is flushed. *) val schedule : t -> Bigstring.t -> pos:int -> len:int -> [ `Flushed of unit Deferred.t | `Connection_closed ] (** On the other hand, these are written immediately. *) val write_bigstring : t -> Bigstring.t -> pos:int -> len:int -> unit val write_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> unit val write_error : t -> Error.t -> unit end (** This just schedules a write, so the [Bigstring.t] should not be overwritten until the flushed [Deferred.t] is determined. The return value of [handle_response] has the same meaning as in the function argument of [Implementations.Expert.create]. *) val schedule_dispatch : Connection.t -> rpc_tag:string -> version:int -> Bigstring.t -> pos:int -> len:int -> handle_response:(Bigstring.t -> pos:int -> len:int -> unit Deferred.t) -> handle_error:(Error.t -> unit) -> [ `Flushed of unit Deferred.t | `Connection_closed ] val dispatch : Connection.t -> rpc_tag:string -> version:int -> Bigstring.t -> pos:int -> len:int -> handle_response:(Bigstring.t -> pos:int -> len:int -> unit Deferred.t) -> handle_error:(Error.t -> unit) -> [ `Ok | `Connection_closed ] (** Result of callbacks passed to [implement] and [implement'] and [implement_for_tag_and_version] and [implement_for_tag_and_version']: - [Replied] means that the response has already been sent using one of the functions of [Responder] - [Delayed_response d] means that the implementation is done using the input bigstring, but hasn't send the response yet. When [d] becomes determined it is expected that the response has been sent. Note: it is NOT OK for an implementation to return: {[ Delayed_response (Responder.schedule responder buf ~pos:... ~len:...) ]} where [buf] is the same bigstring as the one containing the query. This is because it would indicate that [buf] can be overwritten even though it is still being used by [Responder.schedule]. *) type implementation_result = | Replied | Delayed_response of unit Deferred.t val implement : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> (_, _) t -> ('connection_state -> Responder.t -> Bigstring.t -> pos:int -> len:int -> implementation_result Deferred.t) -> 'connection_state Implementation.t val implement' : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> (_, _) t -> ('connection_state -> Responder.t -> Bigstring.t -> pos:int -> len:int -> implementation_result) -> 'connection_state Implementation.t val implement_for_tag_and_version : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> rpc_tag:string -> version:int -> ('connection_state -> Responder.t -> Bigstring.t -> pos:int -> len:int -> implementation_result Deferred.t) -> 'connection_state Implementation.t val implement_for_tag_and_version' : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> rpc_tag:string -> version:int -> ('connection_state -> Responder.t -> Bigstring.t -> pos:int -> len:int -> implementation_result) -> 'connection_state Implementation.t end end module Pipe_close_reason : sig type t = | Closed_locally (** You closed the pipe. *) | Closed_remotely (** The RPC implementer closed the pipe. *) | Error of Error.t (** An error occurred, e.g. a message could not be deserialized. If the connection closes before either side explicitly closes the pipe, it will also go into this case. *) [@@deriving bin_io, compare, sexp] module Stable : sig module V1 : sig type nonrec t = t = | Closed_locally | Closed_remotely | Error of Error.Stable.V2.t [@@deriving bin_io, compare, sexp] end end end module Pipe_rpc : sig type ('query, 'response, 'error) t module Id : sig type t end module Metadata : sig type t val id : t -> Id.t end val create : ?client_pushes_back:unit (** If the connection is backed up, the server stops consuming elements from the pipe. Servers should pay attention to the pipe's pushback, otherwise they risk running out of memory if they fill the pipe much faster than the transport can handle, or if the client pushes back as discussed next. If [client_pushes_back] is set, the client side of the connection will stop reading elements from the underlying file descriptor when the client's pipe has a sufficient number of elements enqueued, rather than reading elements eagerly. This will eventually cause writes on the server's side to block, indicating to the server it should slow down. There are some drawbacks to using [client_pushes_back]: - RPC multiplexing doesn't work as well. The client will stop reading *all* messages on the connection if any pipe gets saturated, not just ones relating to that pipe. - A server that doesn't pay attention to pushback on its end will accumulate elements on its side of the connection, rather than on the client's side, meaning a slow client can make the server run out of memory. *) -> name:string -> version:int -> bin_query:'query Bin_prot.Type_class.t -> bin_response:'response Bin_prot.Type_class.t -> bin_error:'error Bin_prot.Type_class.t -> unit -> ('query, 'response, 'error) t val bin_query : ('query, _, _) t -> 'query Bin_prot.Type_class.t val bin_response : (_, 'response, _) t -> 'response Bin_prot.Type_class.t val bin_error : (_, _, 'error) t -> 'error Bin_prot.Type_class.t (** The pipe returned by the implementation function will be closed automatically when either the connection to the client is closed or the client closes their pipe. *) val implement : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> ('query, 'response, 'error) t -> ('connection_state -> 'query -> ('response Pipe.Reader.t, 'error) Result.t Deferred.t) -> 'connection_state Implementation.t (** A [Direct_stream_writer.t] is a simple object for responding to a [Pipe_rpc] query. *) module Direct_stream_writer : sig type 'a t (** [write t x] returns [`Closed] if [t] is closed, or [`Flushed d] if it is open. In the open case, [d] is determined when the message has been flushed from the underlying [Transport.Writer.t]. *) val write : 'a t -> 'a -> [ `Flushed of unit Deferred.t | `Closed ] val write_without_pushback : 'a t -> 'a -> [ `Ok | `Closed ] val close : _ t -> unit val closed : _ t -> unit Deferred.t val flushed : _ t -> unit Deferred.t val is_closed : _ t -> bool module Expert : sig val write : 'a t -> buf:Bigstring.t -> pos:int -> len:int -> [ `Flushed of unit Deferred.t | `Closed ] val write_without_pushback : 'a t -> buf:Bigstring.t -> pos:int -> len:int -> [ `Ok | `Closed ] end (** Group of direct writers. Groups are optimized for sending the same message to multiple clients at once. *) module Group : sig type 'a direct_stream_writer type 'a t (** A group internally holds a buffer to serialize messages only once. This buffer will grow automatically to accomodate bigger messages. It is safe to share the same buffer between multiple groups. *) module Buffer : sig type t val create : ?initial_size:int (* default 4096 *) -> unit -> t end val create : ?buffer:Buffer.t -> unit -> _ t (** [flushed_or_closed t] is determined when the underlying writer for each member of [t] is flushed or closed. *) val flushed_or_closed : _ t -> unit Deferred.t val flushed : _ t -> unit Deferred.t [@@deprecated "[since 2019-11] renamed as [flushed_or_closed]"] (** Add a direct stream writer to the group. Raises if the writer is closed or already part of the group, or if its bin-prot writer is different than an existing group member's. When the writer is closed, it is automatically removed from the group. *) val add_exn : 'a t -> 'a direct_stream_writer -> unit (** Remove a writer from a group. Note that writers are automatically removed from all groups when they are closed, so you only need to call this if you want to remove a writer without closing it. *) val remove : 'a t -> 'a direct_stream_writer -> unit (** Write a message on all direct writers in the group. Contrary to [Direct_stream_writer.write], this cannot return [`Closed] as elements of the group are removed immediately when they are closed. [write t x] is the same as [write_without_pushback t x; flushed t]. *) val write : 'a t -> 'a -> unit Deferred.t val write_without_pushback : 'a t -> 'a -> unit val to_list : 'a t -> 'a direct_stream_writer list val length : _ t -> int module Expert : sig val write : 'a t -> buf:Bigstring.t -> pos:int -> len:int -> unit Deferred.t val write_without_pushback : 'a t -> buf:Bigstring.t -> pos:int -> len:int -> unit end end with type 'a direct_stream_writer := 'a t end (** Similar to [implement], but you are given the writer instead of providing a writer and the writer is a [Direct_stream_writer.t] instead of a [Pipe.Writer.t]. The main advantage of this interface is that it consumes far less memory per open query. Though the implementation function is given a writer immediately, the result of the client's call to [dispatch] will not be determined until after the implementation function returns. Elements written before the function returns will be queued up to be written after the function returns. *) val implement_direct : ('query, 'response, 'error) t -> ('connection_state -> 'query -> 'response Direct_stream_writer.t -> (unit, 'error) Result.t Deferred.t) -> 'connection_state Implementation.t (** This has [(..., 'error) Result.t] as its return type to represent the possibility of the call itself being somehow erroneous (but understood - the outer [Or_error.t] encompasses failures of that nature). Note that this cannot be done simply by making ['response] a result type, since [('response Pipe.Reader.t, 'error) Result.t] is distinct from [('response, 'error) Result.t Pipe.Reader.t]. Closing the pipe has the effect of calling [abort]. *) val dispatch : ('query, 'response, 'error) t -> Connection.t -> 'query -> ('response Pipe.Reader.t * Metadata.t, 'error) Result.t Or_error.t Deferred.t val dispatch_exn : ('query, 'response, 'error) t -> Connection.t -> 'query -> ('response Pipe.Reader.t * Metadata.t) Deferred.t (** The input type of the [f] passed to [dispatch_iter]. *) module Pipe_message : sig type 'a t = | Update of 'a | Closed of [ `By_remote_side | `Error of Error.t ] end (** The output type of the [f] passed to [dispatch_iter]. This is analagous to a simple [unit Deferred.t], with [Continue] being like [Deferred.unit], but it is made explicit when no waiting should occur. *) module Pipe_response : sig type t = | Continue | Wait of unit Deferred.t end (** Calling [dispatch_iter t conn query ~f] is similar to calling [dispatch t conn query] and then iterating over the result pipe with [f]. The main advantage it offers is that its memory usage is much lower, making it more suitable for situations where many queries are open at once. [f] may be fed any number of [Update _] messages, followed by a single [Closed _] message. [f] can cause the connection to stop reading messages off of its underlying [Reader.t] by returning [Wait _]. This is the same as what happens when a client stops reading from the pipe returned by [dispatch] when the [Pipe_rpc.t] has [client_pushes_back] set. When successful, [dispatch_iter] returns an [Id.t] after the subscription is started. This may be fed to [abort] with the same [Pipe_rpc.t] and [Connection.t] as the call to [dispatch_iter] to cancel the subscription, which will close the pipe on the implementation side. Calling it with a different [Pipe_rpc.t] or [Connection.t] has undefined behavior. *) val dispatch_iter : ('query, 'response, 'error) t -> Connection.t -> 'query -> f:('response Pipe_message.t -> Pipe_response.t) -> (Id.t, 'error) Result.t Or_error.t Deferred.t (** [abort rpc connection id] given an RPC and the id returned as part of a call to dispatch, abort requests that the other side of the connection stop sending updates. If you are using [dispatch] rather than [dispatch_iter], you are encouraged to close the pipe you receive rather than calling [abort] -- both of these have the same effect. *) val abort : (_, _, _) t -> Connection.t -> Id.t -> unit (** [close_reason metadata] will be determined sometime after the pipe associated with [metadata] is closed. Its value will indicate what caused the pipe to be closed. *) val close_reason : Metadata.t -> Pipe_close_reason.t Deferred.t val client_pushes_back : (_, _, _) t -> bool val name : (_, _, _) t -> string val version : (_, _, _) t -> int val description : (_, _, _) t -> Description.t val query_type_id : ('query, _, _) t -> 'query Type_equal.Id.t val response_type_id : (_, 'response, _) t -> 'response Type_equal.Id.t val error_type_id : (_, _, 'error) t -> 'error Type_equal.Id.t end (** A state rpc is an easy way for two processes to synchronize a data structure by sending updates over the wire. It's basically a pipe rpc that sends/receives an initial state of the data structure, and then updates, and applies the updates under the covers. *) module State_rpc : sig type ('query, 'state, 'update, 'error) t module Id : sig type t end module Metadata : sig type t = Pipe_rpc.Metadata.t val id : t -> Id.t end val create : ?client_pushes_back:unit -> name:string -> version:int -> bin_query:'query Bin_prot.Type_class.t -> bin_state:'state Bin_prot.Type_class.t -> bin_update:'update Bin_prot.Type_class.t -> bin_error:'error Bin_prot.Type_class.t -> unit -> ('query, 'state, 'update, 'error) t val bin_query : ('query, _, _, _) t -> 'query Bin_prot.Type_class.t val bin_state : (_, 'state, _, _) t -> 'state Bin_prot.Type_class.t val bin_update : (_, _, 'update, _) t -> 'update Bin_prot.Type_class.t val bin_error : (_, _, _, 'error) t -> 'error Bin_prot.Type_class.t val implement : ?on_exception:On_exception.t (* default: [On_exception.continue] *) -> ('query, 'state, 'update, 'error) t -> ('connection_state -> 'query -> ('state * 'update Pipe.Reader.t, 'error) Result.t Deferred.t) -> 'connection_state Implementation.t val dispatch : ('query, 'state, 'update, 'error) t -> Connection.t -> 'query -> ('state * 'update Pipe.Reader.t * Metadata.t, 'error) Result.t Or_error.t Deferred.t val abort : (_, _, _, _) t -> Connection.t -> Id.t -> unit val close_reason : Metadata.t -> Pipe_close_reason.t Deferred.t val client_pushes_back : (_, _, _, _) t -> bool val name : (_, _, _, _) t -> string val version : (_, _, _, _) t -> int val description : (_, _, _, _) t -> Description.t val query_type_id : ('query, _, _, _) t -> 'query Type_equal.Id.t val state_type_id : (_, 'state, _, _) t -> 'state Type_equal.Id.t val update_type_id : (_, _, 'update, _) t -> 'update Type_equal.Id.t val error_type_id : (_, _, _, 'error) t -> 'error Type_equal.Id.t end (** An RPC that has no response. Error handling is trickier here than it is for RPCs with responses, as there is no reasonable place to put an error if something goes wrong. Because of this, in the event of an error such as dispatching to an unimplemented RPC, the connection will be shut down. Similarly, if the implementation raises an exception, the connection will be shut down. *) module One_way : sig type 'msg t val create : name:string -> version:int -> bin_msg:'msg Bin_prot.Type_class.t -> 'msg t val name : _ t -> string val version : _ t -> int val description : _ t -> Description.t val msg_type_id : 'msg t -> 'msg Type_equal.Id.t val bin_msg : 'msg t -> 'msg Bin_prot.Type_class.t val implement : ?on_exception:On_exception.t (* default On_exception.close_connection *) -> 'msg t -> ('connection_state -> 'msg -> unit) -> 'connection_state Implementation.t (** [dispatch'] exposes [Rpc_result.t] as output. Passing it through [rpc_result_to_or_error] gives you the same result as [dispatch] *) val dispatch' : 'msg t -> Connection.t -> 'msg -> unit Rpc_result.t val rpc_result_to_or_error : 'msg t -> Connection.t -> unit Rpc_result.t -> unit Or_error.t val dispatch : 'msg t -> Connection.t -> 'msg -> unit Or_error.t val dispatch_exn : 'msg t -> Connection.t -> 'msg -> unit module Expert : sig val implement : ?on_exception:On_exception.t (* default On_exception.close_connection *) -> _ t -> ('connection_state -> Bigstring.t -> pos:int -> len:int -> unit) -> 'connection_state Implementation.t val dispatch : _ t -> Connection.t -> Bigstring.t -> pos:int -> len:int -> [ `Ok | `Connection_closed ] (** Like [dispatch], but does not copy data out of the buffer, so it must not change until the returned [unit Deferred.t] is determined. *) val schedule_dispatch : _ t -> Connection.t -> Bigstring.t -> pos:int -> len:int -> [ `Flushed of unit Deferred.t | `Connection_closed ] end end module Any : sig type t = | Rpc : ('q, 'r) Rpc.t -> t | Pipe : ('q, 'r, 'e) Pipe_rpc.t -> t | State : ('q, 's, 'u, 'e) State_rpc.t -> t | One_way : 'm One_way.t -> t val description : t -> Description.t end module Stable : sig module Rpc : sig type ('query, 'response) t = ('query, 'response) Rpc.t val create : name:string -> version:int -> bin_query:'query Bin_prot.Type_class.t -> bin_response:'response Bin_prot.Type_class.t -> ('query, 'response) t val description : (_, _) t -> Description.t val bin_query : ('query, _) t -> 'query Bin_prot.Type_class.t val bin_response : (_, 'response) t -> 'response Bin_prot.Type_class.t end module Pipe_rpc : sig type ('query, 'response, 'error) t = ('query, 'response, 'error) Pipe_rpc.t val create : ?client_pushes_back:unit -> name:string -> version:int -> bin_query:'query Bin_prot.Type_class.t -> bin_response:'response Bin_prot.Type_class.t -> bin_error:'error Bin_prot.Type_class.t -> unit -> ('query, 'response, 'error) t val description : (_, _, _) t -> Description.t val bin_query : ('query, _, _) t -> 'query Bin_prot.Type_class.t val bin_response : (_, 'response, _) t -> 'response Bin_prot.Type_class.t val bin_error : (_, _, 'error) t -> 'error Bin_prot.Type_class.t end module State_rpc : sig type ('query, 'state, 'update, 'error) t = ('query, 'state, 'update, 'error) State_rpc.t val create : ?client_pushes_back:unit -> name:string -> version:int -> bin_query:'query Bin_prot.Type_class.t -> bin_state:'state Bin_prot.Type_class.t -> bin_update:'update Bin_prot.Type_class.t -> bin_error:'error Bin_prot.Type_class.t -> unit -> ('query, 'state, 'update, 'error) t val description : (_, _, _, _) t -> Description.t val bin_query : ('query, _, _, _) t -> 'query Bin_prot.Type_class.t val bin_state : (_, 'state, _, _) t -> 'state Bin_prot.Type_class.t val bin_update : (_, _, 'update, _) t -> 'update Bin_prot.Type_class.t val bin_error : (_, _, _, 'error) t -> 'error Bin_prot.Type_class.t end module One_way : sig type 'msg t = 'msg One_way.t val create : name:string -> version:int -> bin_msg:'msg Bin_prot.Type_class.t -> 'msg t val description : _ t -> Description.t val bin_msg : 'msg t -> 'msg Bin_prot.Type_class.t end module Description = Description.Stable module Pipe_close_reason = Pipe_close_reason.Stable end async_rpc_kernel-0.15.0/src/rpc_error.ml000066400000000000000000000024631420273305200202370ustar00rootroot00000000000000open Core open Async_kernel include Protocol.Rpc_error include Sexpable.To_stringable (Protocol.Rpc_error) exception Rpc of t * Info.t [@@deriving sexp] let raise t connection_description = raise (Rpc (t, connection_description)) let sexp_of_t t ~get_connection_close_reason = match t with | Connection_closed -> [%sexp `Connection_closed (get_connection_close_reason () : Sexp.t)] | Bin_io_exn _ | Write_error _ | Uncaught_exn _ | Unimplemented_rpc _ | Unknown_query_id _ -> sexp_of_t t ;; (* it would make sense to just take a [Connection.t], but we take its pieces instead to avoid a dependency cycle *) let to_error t ~rpc_description:{ Description.name = rpc_name; version = rpc_version } ~connection_description ~connection_close_started = let rpc_error = sexp_of_t t ~get_connection_close_reason:(fun () -> let close_reason = (* Usually (always?) here we will have the deferred already full because Connection_closed error means the connection is already closed *) Deferred.peek connection_close_started in [%sexp (close_reason : Info.t option)]) in Error.create_s [%sexp { rpc_error : Sexp.t ; connection_description : Info.t ; rpc_name : string ; rpc_version : int }] ;; async_rpc_kernel-0.15.0/src/rpc_error.mli000066400000000000000000000006461420273305200204110ustar00rootroot00000000000000open! Core open! Async_kernel include module type of struct include Protocol.Rpc_error end val sexp_of_t : t -> get_connection_close_reason:(unit -> Sexp.t) -> Sexp.t include Stringable.S with type t := t exception Rpc of t * Info.t val raise : t -> Info.t -> 'a val to_error : t -> rpc_description:Description.t -> connection_description:Info.t -> connection_close_started:Info.t Deferred.t -> Error.t async_rpc_kernel-0.15.0/src/rpc_result.ml000066400000000000000000000021001420273305200204100ustar00rootroot00000000000000open Core open Async_kernel type 'a t = ('a, Rpc_error.t) Result.t [@@deriving bin_io] type located_error = { location : string ; exn : Exn.t } [@@deriving sexp_of] let uncaught_exn ~location exn = Error (Rpc_error.Uncaught_exn (sexp_of_located_error { location; exn })) ;; let bin_io_exn ~location exn = Error (Rpc_error.Bin_io_exn (sexp_of_located_error { location; exn })) ;; let try_with ?on_background_exception ?run ~location f = let x = let rest = match on_background_exception with | None -> `Log | Some callback -> `Call callback in Monitor.try_with ~rest ~run:(Option.value run ~default:`Schedule) f in let join = function | Ok x -> x | Error exn -> uncaught_exn ~location exn in match Deferred.peek x with | None -> x >>| join | Some x -> return (join x) ;; let or_error ~rpc_description ~connection_description ~connection_close_started = Result.map_error ~f: (Rpc_error.to_error ~rpc_description ~connection_description ~connection_close_started) ;; async_rpc_kernel-0.15.0/src/rpc_result.mli000066400000000000000000000007521420273305200205740ustar00rootroot00000000000000open! Core open! Async_kernel type 'a t = 'a Protocol.Rpc_result.t val uncaught_exn : location:string -> exn -> 'a t val bin_io_exn : location:string -> exn -> 'a t val try_with : ?on_background_exception:(exn -> unit) -> ?run:[ `Now | `Schedule ] -> location:string -> (unit -> 'a t Deferred.t) -> 'a t Deferred.t val or_error : rpc_description:Description.t -> connection_description:Info.t -> connection_close_started:Info.t Deferred.t -> 'a t -> 'a Or_error.t async_rpc_kernel-0.15.0/src/transport.ml000066400000000000000000000103121420273305200202660ustar00rootroot00000000000000open Core open Async_kernel module Header = struct let length = 8 let unsafe_get_payload_length buf ~pos = Bigstring.unsafe_get_int64_le_exn buf ~pos let unsafe_set_payload_length buf ~pos payload_len = Bigstring.unsafe_set_int64_le buf ~pos payload_len ;; end module Handler_result = Transport_intf.Handler_result module Reader = struct module type S = Transport_intf.Reader type t = T : (module S with type t = 'a) * 'a -> t let pack m t = T (m, t) (* We put type annotations to be sure the type is not a function type, i.e. to avoid creating closures *) let sexp_of_t (T ((module M), t)) : Sexp.t = M.sexp_of_t t let close (T ((module M), t)) : unit Deferred.t = M.close t let is_closed (T ((module M), t)) : bool = M.is_closed t let read_forever (T ((module M), t)) ~on_message ~on_end_of_batch : _ Deferred.t = M.read_forever t ~on_message ~on_end_of_batch ;; let read_one_message_bin_prot t (bin_reader : _ Bin_prot.Type_class.reader) = read_forever t ~on_message:(fun buf ~pos ~len -> let pos_ref = ref pos in let x = bin_reader.read buf ~pos_ref in if !pos_ref <> pos + len then failwithf "message length (%d) did not match expected length (%d)" (!pos_ref - pos) len () else Stop x) ~on_end_of_batch:ignore ;; end module Send_result = Transport_intf.Send_result module Writer = struct module type S = Transport_intf.Writer type 'a writer = { impl : (module S with type t = 'a) ; t : 'a (* We cache the result of [stopped] because it is often the [Deferred.any] of several other deferreds and we want [can_send] to be simple. *) ; stopped : unit Deferred.t } type t = T : 'a writer -> t let pack (type a) (module M : S with type t = a) t = T { impl = (module M); t; stopped = M.stopped t } ;; let sexp_of_t (T { impl = (module M); t; _ }) : Sexp.t = M.sexp_of_t t let close (T { impl = (module M); t; _ }) : unit Deferred.t = M.close t let is_closed (T { impl = (module M); t; _ }) : bool = M.is_closed t let monitor (T { impl = (module M); t; _ }) : Monitor.t = M.monitor t let bytes_to_write (T { impl = (module M); t; _ }) : int = M.bytes_to_write t let flushed (T { impl = (module M); t; _ }) : unit Deferred.t = M.flushed t let ready_to_write (T { impl = (module M); t; _ }) : unit Deferred.t = M.ready_to_write t ;; let send_bin_prot (T { impl = (module M); t; _ }) bin_writer x : _ Send_result.t = M.send_bin_prot t bin_writer x ;; let send_bin_prot_and_bigstring (T { impl = (module M); t; _ }) bin_writer x ~buf ~pos ~len : _ Send_result.t = M.send_bin_prot_and_bigstring t bin_writer x ~buf ~pos ~len ;; let send_bin_prot_and_bigstring_non_copying (T { impl = (module M); t; _ }) bin_writer x ~buf ~pos ~len : _ Send_result.t = M.send_bin_prot_and_bigstring_non_copying t bin_writer x ~buf ~pos ~len ;; let stopped (T { stopped; _ }) = stopped let can_send (T { impl = (module M); t; stopped }) = not (M.is_closed t || Deferred.is_determined stopped) ;; let transfer t ?(max_num_values_per_read = 1_000) pipe f = let consumer = Pipe.add_consumer pipe ~downstream_flushed:(fun () -> let%map () = flushed t in `Ok) in let end_of_pipe = Deferred.create (fun ivar -> let rec iter () = if can_send t then ( match Pipe.read_now' pipe ~consumer ~max_queue_length:max_num_values_per_read with | `Ok q -> Queue.iter q ~f; Pipe.Consumer.values_sent_downstream consumer; ready_to_write t >>> iter | `Nothing_available -> Pipe.values_available pipe >>> fun (`Ok | `Eof) -> iter () | `Eof -> Ivar.fill ivar ()) in iter ()) in let%map () = Deferred.any [ end_of_pipe; stopped t ] in Pipe.close_read pipe ;; end type t = { reader : Reader.t ; writer : Writer.t } [@@deriving sexp_of] let close t = let%bind () = Writer.close t.writer in Reader.close t.reader ;; async_rpc_kernel-0.15.0/src/transport.mli000066400000000000000000000035271420273305200204510ustar00rootroot00000000000000(** RPC transport layer A transport is a way to send and receive messages. It is split between a [Reader] and a [Writer] part. [Async_rpc_kernel] only provides an async [Pipe.t] transport. [Async_rpc] provides a unix transport based on [Async_unix]'s [Reader] and [Writer] modules. *) open! Core open! Async_kernel (** Binary headers containing message lengths. All transports should use this to ensure binary compatibility. *) module Header : sig val length : int val unsafe_get_payload_length : Bigstring.t -> pos:int -> int val unsafe_set_payload_length : Bigstring.t -> pos:int -> int -> unit end module Handler_result = Transport_intf.Handler_result module Reader : sig module type S = Transport_intf.Reader include S val pack : (module S with type t = 'a) -> 'a -> t (** Convenience function to wait for the first message and un-bin_prot it. Async RPC uses this to handle the handshake at the beginning of the message stream. *) val read_one_message_bin_prot : t -> 'a Bin_prot.Type_class.reader -> ('a, [ `Closed | `Eof ]) Result.t Deferred.t end module Send_result = Transport_intf.Send_result module Writer : sig module type S = Transport_intf.Writer include S val pack : (module S with type t = 'a) -> 'a -> t (** [can_send t = not (is_closed t || Deferred.is_determined (stopped t))] *) val can_send : t -> bool (** This function is similar to [Async_unix.Writer.transfer], except that it doesn't wait on [Pipe.upstream_flushed] when the writer is closed. *) val transfer : t -> ?max_num_values_per_read:int (* default: 1_000 *) -> 'a Pipe.Reader.t -> ('a -> unit) -> unit Deferred.t end type t = { reader : Reader.t ; writer : Writer.t } [@@deriving sexp_of] (** Closes both parts of the transport. *) val close : t -> unit Deferred.t async_rpc_kernel-0.15.0/src/transport_intf.ml000066400000000000000000000055711420273305200213210ustar00rootroot00000000000000open Core open Async_kernel type 'a message_handler = Bigstring.t -> pos:int -> len:int -> 'a module Handler_result = struct (** Result of an [on_message] callback. We split the [Continue] and [Wait _] cases to make it clear that [Continue] is the expected case. The implementation should be optimized for this case. *) type 'a t = | Stop of 'a | Continue | Wait of unit Deferred.t end module type Reader = sig type t [@@deriving sexp_of] val close : t -> unit Deferred.t val is_closed : t -> bool (** Start reading incoming messages and pass them to [on_message], until it returns [Stop _]. [on_end_of_batch] is called after processing a batch of messages, before waiting for the file descriptor to become readable again. *) val read_forever : t -> on_message:(Bigstring.t -> pos:int -> len:int -> 'a Handler_result.t) -> on_end_of_batch:(unit -> unit) -> ('a, [ `Eof | `Closed ]) Result.t Deferred.t end module Send_result = struct type message_too_big = { size : int ; max_message_size : int } [@@deriving sexp_of] type 'a t = | Sent of 'a | Closed | Message_too_big of message_too_big [@@deriving sexp_of] end module type Writer = sig type t [@@deriving sexp_of] val close : t -> unit Deferred.t val is_closed : t -> bool val monitor : t -> Monitor.t val bytes_to_write : t -> int (** Becomes determined when it is no longer possible to send message using this writer, for instance when the writer is closed or the consumer leaves. The result of this function is cached by [Rpc.Transport] *) val stopped : t -> unit Deferred.t (** [flushed t] returns a deferred that must become determined when all prior sent messages are delivered. It must be OK to call [flushed t] after [t] has been closed. *) val flushed : t -> unit Deferred.t (** [ready_to_write t] becomes determined when it is a good time to send messages again. Async RPC calls this function after sending a batch of messages, to avoid flooding the transport. Using [let ready_to_write = flushed] is an acceptable implementation. *) val ready_to_write : t -> unit Deferred.t (** All the following functions send exactly one message. *) val send_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> unit Send_result.t val send_bin_prot_and_bigstring : t -> 'a Bin_prot.Type_class.writer -> 'a -> buf:Bigstring.t -> pos:int -> len:int -> unit Send_result.t (** Same as [send_bin_prot_and_bigstring] but the bigstring can't be modified until the returned deferred becomes determined. This can be used to avoid copying the bigstring. *) val send_bin_prot_and_bigstring_non_copying : t -> 'a Bin_prot.Type_class.writer -> 'a -> buf:Bigstring.t -> pos:int -> len:int -> unit Deferred.t Send_result.t end async_rpc_kernel-0.15.0/src/util.ml000066400000000000000000000012771420273305200172210ustar00rootroot00000000000000open Core (* utility function for bin-io'ing out of a Bigstring.t *) let bin_read_from_bigstring (bin_reader_t : _ Bin_prot.Type_class.reader) ?add_len buf ~pos_ref ~(len : Nat0.t) ~location = try let init_pos = !pos_ref in let data = bin_reader_t.read buf ~pos_ref in let add_len = match add_len with | None -> 0 | Some add_len -> add_len data in if !pos_ref - init_pos + add_len <> (len :> int) then failwithf "message length (%d) did not match expected length (%d)" (!pos_ref - init_pos) (len : Nat0.t :> int) (); Ok data with | e -> Rpc_result.bin_io_exn ~location e ;; async_rpc_kernel-0.15.0/src/util.mli000066400000000000000000000003361420273305200173650ustar00rootroot00000000000000open Core val bin_read_from_bigstring : 'a Bin_prot.Type_class.reader -> ?add_len:('a -> int) -> Bin_prot.Common.buf -> pos_ref:int ref -> len:Nat0.t -> location:string -> ('a, Protocol.Rpc_error.t) result async_rpc_kernel-0.15.0/src/versioned_rpc.ml000066400000000000000000001500251420273305200211020ustar00rootroot00000000000000open Core open Async_kernel open Rpc module Versioned_direct_stream_writer = struct module Direct_stream_writer = Pipe_rpc.Direct_stream_writer type 'input t = | T : { convert : 'input -> 'output ; writer : 'output Direct_stream_writer.t } -> 'input t let create ~convert ~writer = T { convert; writer } let write (T { convert; writer }) input = Direct_stream_writer.write writer (convert input) ;; let write_without_pushback (T { convert; writer }) input = Direct_stream_writer.write_without_pushback writer (convert input) ;; let close (T { convert = _; writer }) = Direct_stream_writer.close writer let is_closed (T { convert = _; writer }) = Direct_stream_writer.is_closed writer let closed (T { convert = _; writer }) = Direct_stream_writer.closed writer end let failed_conversion x = Error.create "type conversion failure" x [%sexp_of: [ `Msg | `Query | `Response | `Error | `State | `Update ] * [ `Rpc of string ] * [ `Version of int ] * exn] ;; let multiple_registrations x = Error.create "multiple rpc registrations" x [%sexp_of: [ `Rpc of string ] * [ `Version of int ]] ;; let unknown_version x = Error.create "unknown rpc version" x [%sexp_of: string * int] module Callee_converts = struct module Rpc = struct module Simple = struct type ('query, 'response) adapter = { adapt : 'state. ('state -> 'query -> 'response Deferred.t) -> 'state Implementation.t } type ('query, 'response) t = { name : string ; adapters : ('query, 'response) adapter Int.Map.t } [@@deriving fields] let create ~name = { name; adapters = Int.Map.empty } let wrap_error fn state query = match%map fn state query with | Ok value -> Ok value | Error error -> Error (Error.to_string_hum error) ;; let add { name; adapters } rpc adapter = if String.( <> ) name (Rpc.name rpc) then Or_error.error "Rpc names don't agree" (name, Rpc.name rpc) [%sexp_of: string * string] else ( let version = Rpc.version rpc in match Map.find adapters version with | Some _ -> Or_error.error "Version already exists" (name, version) [%sexp_of: string * int] | None -> let adapters = Map.set adapters ~key:version ~data:adapter in Ok { name; adapters }) ;; let add_rpc_version t old_rpc upgrade downgrade = let adapt fn = let adapted state old_query = let%map result = fn state (upgrade old_query) in downgrade result in Rpc.implement old_rpc adapted in add t old_rpc { adapt } ;; let add_rpc_version_with_failure t old_rpc upgrade_or_error downgrade_or_error = let adapt fn = let adapted state old_query = let open Deferred.Result.Let_syntax in let%bind query = Deferred.return (upgrade_or_error old_query) in let%bind response = fn state query in Deferred.return (downgrade_or_error response) in Rpc.implement old_rpc (wrap_error adapted) in add t old_rpc { adapt } ;; let add_version t ~version ~bin_query ~bin_response upgrade downgrade = let rpc = Rpc.create ~name:t.name ~version ~bin_query ~bin_response in add_rpc_version t rpc upgrade downgrade ;; let add_version_with_failure t ~version ~bin_query ~bin_response upgrade downgrade = let rpc = Rpc.create ~name:t.name ~version ~bin_query ~bin_response in add_rpc_version_with_failure t rpc upgrade downgrade ;; let implement t fn = Map.data t.adapters |> List.map ~f:(fun { adapt } -> adapt fn) end module type S = sig type query type response val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> query -> response Deferred.t) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type query type response end) = struct let name = Model.name type 's impl = 's -> version:int -> Model.query -> Model.response Deferred.t type implementer = { implement : 's. log_version:(int -> unit) -> 's impl -> 's Implementation.t } let registry : (int, implementer * Any.t) Hashtbl.t = Int.Table.create ~size:1 () let implement_multi ?log_not_previously_seen_version f = let log_version = match log_not_previously_seen_version with | None -> ignore (* prevent calling [f] more than once per version *) | Some f -> Memo.general (f ~name) in List.map (Hashtbl.data registry) ~f:(fun (i, _rpc) -> i.implement ~log_version f) ;; let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Hashtbl.keys registry) module Register (Version_i : sig type query [@@deriving bin_io] type response [@@deriving bin_io] val version : int val model_of_query : query -> Model.query val response_of_model : Model.response -> response end) = struct open Version_i let rpc = Rpc.create ~name ~version ~bin_query ~bin_response let () = let implement ~log_version f = Rpc.implement rpc (fun s q -> log_version version; match Result.try_with (fun () -> Version_i.model_of_query q) with | Error exn -> Error.raise (failed_conversion (`Query, `Rpc name, `Version version, exn)) | Ok q -> let%map r = f s ~version q in (match Result.try_with (fun () -> Version_i.response_of_model r) with | Ok r -> r | Error exn -> Error.raise (failed_conversion (`Response, `Rpc name, `Version version, exn)))) in match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:({ implement }, Any.Rpc rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end end end module Pipe_rpc = struct module type S = sig type query type response type error val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> query -> (response Pipe.Reader.t, error) Result.t Deferred.t) -> 'state Implementation.t list val implement_direct_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> query -> response Versioned_direct_stream_writer.t -> (unit, error) Result.t Deferred.t) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type query type response type error end) = struct let name = Model.name type 's impl = | Pipe of ('s -> version:int -> Model.query -> (Model.response Pipe.Reader.t, Model.error) Result.t Deferred.t) | Direct of ('s -> version:int -> Model.query -> Model.response Versioned_direct_stream_writer.t -> (unit, Model.error) Result.t Deferred.t) type implementer = { implement : 's. log_version:(int -> unit) -> 's impl -> 's Implementation.t } let registry = Int.Table.create ~size:1 () let implement_multi_gen ?log_not_previously_seen_version impl = let log_version = match log_not_previously_seen_version with | None -> ignore (* prevent calling [f] more than once per version *) | Some f -> Memo.general (f ~name) in List.map (Hashtbl.data registry) ~f:(fun (i, _) -> i.implement ~log_version impl) ;; let implement_multi ?log_not_previously_seen_version f = implement_multi_gen ?log_not_previously_seen_version (Pipe f) ;; let implement_direct_multi ?log_not_previously_seen_version f = implement_multi_gen ?log_not_previously_seen_version (Direct f) ;; let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Int.Table.keys registry) module type Version_shared = sig type query [@@deriving bin_io] type response [@@deriving bin_io] type error [@@deriving bin_io] val version : int val model_of_query : query -> Model.query val error_of_model : Model.error -> error val client_pushes_back : bool end module Make_shared (Version_i : Version_shared) (Convert : sig val convert_elt : (Model.response -> Version_i.response) Or_error.t val convert_pipe : Model.response Pipe.Reader.t -> Version_i.response Pipe.Reader.t end) = struct open Version_i open Convert let rpc = Pipe_rpc.create ~name ~version ~bin_query ~bin_response ~bin_error ?client_pushes_back:(Option.some_if client_pushes_back ()) () ;; let wrapped_model_of_query q = match Version_i.model_of_query q with | exception exn -> Error.raise (failed_conversion (`Response, `Rpc name, `Version version, exn)) | q -> q ;; let wrapped_error_of_model error = match Version_i.error_of_model error with | error -> Error error | exception exn -> Error.raise (failed_conversion (`Error, `Rpc name, `Version version, exn)) ;; let implement ~log_version impl = match impl with | Pipe f -> Pipe_rpc.implement rpc (fun s q -> log_version version; match%bind f s ~version (wrapped_model_of_query q) with | Ok pipe -> Monitor.handle_errors (fun () -> return (Ok (convert_pipe pipe))) (fun exn -> Error.raise (failed_conversion (`Response, `Rpc name, `Version version, exn))) | Error error -> return (wrapped_error_of_model error)) | Direct f -> let convert_elt = Or_error.ok_exn convert_elt in Pipe_rpc.implement_direct rpc (fun s q dsw -> let writer = Versioned_direct_stream_writer.create ~convert:convert_elt ~writer:dsw in match%map f s ~version (wrapped_model_of_query q) writer with | Ok () -> Ok () | Error error -> wrapped_error_of_model error) ;; let () = match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:({ implement }, Any.Pipe rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end module Register_raw (Version_i : sig include Version_shared val response_of_model : Model.response Pipe.Reader.t -> response Pipe.Reader.t end) = Make_shared (Version_i) (struct let convert_elt = Or_error.error_string "cannot use direct interface with Register_raw" ;; let convert_pipe = Version_i.response_of_model end) module Register (Version_i : sig include Version_shared val response_of_model : Model.response -> response end) = Make_shared (Version_i) (struct let convert_elt = Ok Version_i.response_of_model let convert_pipe pipe = Pipe.map pipe ~f:Version_i.response_of_model end) end end module State_rpc = struct module type S = sig type query type state type update type error val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('connection_state -> version:int -> query -> (state * update Pipe.Reader.t, error) Result.t Deferred.t) -> 'connection_state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type query type state type update type error end) = struct let name = Model.name type 's impl = 's -> version:int -> Model.query -> (Model.state * Model.update Pipe.Reader.t, Model.error) Result.t Deferred.t type implementer = { implement : 's. log_version:(int -> unit) -> 's impl -> 's Implementation.t } let registry = Int.Table.create ~size:1 () let implement_multi ?log_not_previously_seen_version f = let log_version = match log_not_previously_seen_version with | None -> ignore (* prevent calling [f] more than once per version *) | Some f -> Memo.general (f ~name) in List.map (Hashtbl.data registry) ~f:(fun (i, _) -> i.implement ~log_version f) ;; let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Int.Table.keys registry) module type Version_shared = sig type query [@@deriving bin_io] type state [@@deriving bin_io] type update [@@deriving bin_io] type error [@@deriving bin_io] val version : int val model_of_query : query -> Model.query val state_of_model : Model.state -> state val error_of_model : Model.error -> error val client_pushes_back : bool end module Register_raw (Version_i : sig include Version_shared val update_of_model : Model.state -> Model.update Pipe.Reader.t -> update Pipe.Reader.t end) = struct open Version_i let rpc = State_rpc.create ~name ~version ~bin_query ~bin_state ~bin_update ~bin_error ?client_pushes_back:(Option.some_if client_pushes_back ()) () ;; let () = let implement ~log_version f = State_rpc.implement rpc (fun s q -> log_version version; match Version_i.model_of_query q with | exception exn -> Error.raise (failed_conversion (`Response, `Rpc name, `Version version, exn)) | q -> (match%bind f s ~version q with | Ok (model_state, pipe) -> let state = match Version_i.state_of_model model_state with | state -> state | exception exn -> Error.raise (failed_conversion (`State, `Rpc name, `Version version, exn)) in Monitor.handle_errors (fun () -> return (Ok (state, Version_i.update_of_model model_state pipe))) (fun exn -> Error.raise (failed_conversion (`Update, `Rpc name, `Version version, exn))) | Error error -> return (match Version_i.error_of_model error with | error -> Error error | exception exn -> Error.raise (failed_conversion (`Error, `Rpc name, `Version version, exn))))) in match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:({ implement }, Any.State rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end module Register (Version_i : sig include Version_shared val update_of_model : Model.update -> update end) = struct include Register_raw (struct include Version_i let update_of_model _state pipe = Pipe.map ~f:update_of_model pipe end) end end end module One_way = struct module type S = sig type msg val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> msg -> unit) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type msg end) = struct let name = Model.name type 's impl = 's -> version:int -> Model.msg -> unit type implementer = { implement : 's. log_version:(int -> unit) -> 's impl -> 's Implementation.t } let registry : (int, implementer * Any.t) Hashtbl.t = Int.Table.create ~size:1 () let implement_multi ?log_not_previously_seen_version f = let log_version = match log_not_previously_seen_version with | None -> ignore (* prevent calling [f] more than once per version *) | Some f -> Memo.general (f ~name) in List.map (Hashtbl.data registry) ~f:(fun (i, _rpc) -> i.implement ~log_version f) ;; let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Hashtbl.keys registry) module Register (Version_i : sig type msg [@@deriving bin_io] val version : int val model_of_msg : msg -> Model.msg end) = struct open Version_i let rpc = One_way.create ~name ~version ~bin_msg let () = let implement ~log_version f = One_way.implement rpc (fun s q -> log_version version; match Result.try_with (fun () -> Version_i.model_of_msg q) with | Error exn -> Error.raise (failed_conversion (`Msg, `Rpc name, `Version version, exn)) | Ok q -> f s ~version q) in match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:({ implement }, Any.One_way rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end end end end module Menu = struct (***************** some prohibitions for this module ****************** (1) !!! never prune old versions of this rpc !!! It is too fundamental to the workings of various versioning schemes and it probably won't change very much anyway. (2) !!! only ever say "with bin_io" on built-in ocaml types !!! Examples of built-in types are int, list, string, etc. This is to protect ourselves against changes to Core data structures, for example. *********************************************************************) module Model = struct let name = "__Versioned_rpc.Menu" type query = unit type response = Description.t list end include Callee_converts.Rpc.Make (Model) let rpc_name = Model.name module V1 = struct module T = struct let version = 1 type query = unit [@@deriving bin_io] type response = (string * int) list [@@deriving bin_io] let model_of_query q = q let response_of_model = List.map ~f:(fun { Description.name; version } -> name, version) ;; end include T include Register (T) end module Current_version = V1 let add impls = let menu = List.map impls ~f:Implementation.description in let menu_impls = implement_multi (fun _ ~version:_ () -> return menu) in impls @ menu_impls ;; type t = Int.Set.t String.Table.t [@@deriving sexp_of] let supported_rpcs t = let open List.Let_syntax in let%bind name, versions = String.Table.to_alist t in let%map version = Int.Set.to_list versions in { Description.name; version } ;; let supported_versions t ~rpc_name = Option.value ~default:Int.Set.empty (Hashtbl.find t rpc_name) ;; let of_entries entries = Hashtbl.map ~f:Int.Set.of_list (String.Table.of_alist_multi entries) ;; let request conn = let%map result = Rpc.dispatch Current_version.rpc conn () in Result.map result ~f:of_entries ;; let create descriptions = List.map descriptions ~f:(fun { Description.name; version } -> name, version) |> of_entries ;; end module Connection_with_menu = struct type t = { connection : Connection.t ; menu : Menu.t } [@@deriving fields] let create connection = let open Deferred.Or_error.Let_syntax in let%map menu = Menu.request connection in { connection; menu } ;; let create_directly connection menu = { connection; menu } end module Caller_converts = struct let most_recent_common_version ~rpc_name ~caller_versions ~callee_versions ~callee_menu = match Set.max_elt (Set.inter callee_versions caller_versions) with | Some version -> Ok version | None -> error_s [%message "caller and callee share no common versions for rpc" (rpc_name : string) (caller_versions : Int.Set.t) (callee_versions : Int.Set.t) (callee_menu : Menu.t)] ;; let%expect_test "highest version number is taken in most_recent_common_version" = let rpc_name = "the-rpc" in let menu = Menu.of_entries [ rpc_name, 2 ] in let result = most_recent_common_version ~rpc_name ~caller_versions:(Int.Set.of_list [ 1; 2; 3 ]) ~callee_versions:(Int.Set.of_list [ 2 ]) ~callee_menu:menu in print_s [%sexp (result : int Or_error.t)]; [%expect {| (Ok 2) |}] ;; let%expect_test "error from most_recent_common_version looks reasonable" = let the_rpc = "the-rpc" in let not_the_rpc = "other-rpc" in let menu = Menu.of_entries [ not_the_rpc, 1; not_the_rpc, 2 ] in let result = most_recent_common_version ~rpc_name:the_rpc ~caller_versions:(Int.Set.of_list [ 1; 2; 3 ]) ~callee_versions:(Menu.supported_versions menu ~rpc_name:the_rpc) ~callee_menu:menu in print_s [%sexp (result : int Or_error.t)]; [%expect {| (Error ("caller and callee share no common versions for rpc" (rpc_name the-rpc) (caller_versions (1 2 3)) (callee_versions ()) (callee_menu ((other-rpc (1 2))))))|}] ;; module Dispatch = struct module Make (M : Monad) = struct open M let with_specific_version ~version ~connection ~name ~query ~dispatcher ~registry = match Hashtbl.find registry version with | None -> return (Error (unknown_version (name, version))) | Some (dispatch, _rpc) -> dispatcher dispatch connection query ;; let with_version_menu { Connection_with_menu.connection; menu } query ~name ~versions ~registry ~dispatcher = let callee_versions = Menu.supported_versions menu ~rpc_name:name in let caller_versions = versions () in match most_recent_common_version ~rpc_name:name ~caller_versions ~callee_versions ~callee_menu:menu with | Error e -> return (Error e) | Ok version -> with_specific_version ~version ~connection ~name ~query ~registry ~dispatcher ;; end module Async = Make (Deferred) module Direct = Make (Monad.Ident) end module Rpc = struct module type S = sig type query type response val dispatch_multi : Connection_with_menu.t -> query -> response Or_error.t Deferred.t val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type query type response end) = struct let name = Model.name let registry = Int.Table.create ~size:1 () let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Int.Table.keys registry) let dispatch_multi conn_with_menu query = Dispatch.Async.with_version_menu conn_with_menu query ~name ~versions ~registry ~dispatcher:Fn.id ;; module Register' (Version_i : sig type query [@@deriving bin_io] type response [@@deriving bin_io] val version : int val query_of_model : Model.query -> query val model_of_response : Model.query -> response -> Model.response end) = struct open Version_i let rpc = Rpc.create ~name ~version ~bin_query ~bin_response let () = let dispatch conn mq = match Result.try_with (fun () -> Version_i.query_of_model mq) with | Error exn -> return (Error (failed_conversion (`Query, `Rpc name, `Version version, exn))) | Ok q -> let%map result = Rpc.dispatch rpc conn q in Result.bind result ~f:(fun r -> match Result.try_with (fun () -> Version_i.model_of_response mq r) with | Ok r -> Ok r | Error exn -> Error (failed_conversion (`Response, `Rpc name, `Version version, exn))) in match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:(dispatch, Any.Rpc rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end module Register (Version_i : sig type query [@@deriving bin_io] type response [@@deriving bin_io] val version : int val query_of_model : Model.query -> query val model_of_response : response -> Model.response end) = Register' (struct include Version_i let model_of_response _ r = model_of_response r end) end end module Pipe_rpc = struct module type S = sig type query type response type error val dispatch_multi : Connection_with_menu.t -> query -> (response Or_error.t Pipe.Reader.t * Pipe_rpc.Metadata.t, error) Result.t Or_error.t Deferred.t val dispatch_iter_multi : Connection_with_menu.t -> query -> f:(response Pipe_rpc.Pipe_message.t -> Pipe_rpc.Pipe_response.t) -> (Pipe_rpc.Id.t, error) Result.t Or_error.t Deferred.t val abort_multi : Connection_with_menu.t -> Pipe_rpc.Id.t -> unit Or_error.t val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type query type response type error end) = struct type dispatcher = { abort : Connection.t -> Pipe_rpc.Id.t -> unit ; dispatch : Connection.t -> Model.query -> ( Model.response Or_error.t Pipe.Reader.t * Pipe_rpc.Metadata.t , Model.error ) Result.t Or_error.t Deferred.t ; dispatch_iter : Connection.t -> Model.query -> f:(Model.response Pipe_rpc.Pipe_message.t -> Pipe_rpc.Pipe_response.t) -> (Pipe_rpc.Id.t, Model.error) Result.t Or_error.t Deferred.t } let name = Model.name let registry : (dispatcher * Any.t) Int.Table.t = Int.Table.create ~size:1 () let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Int.Table.keys registry) let dispatch_iter_multi conn_with_menu query ~f = Dispatch.Async.with_version_menu conn_with_menu query ~name ~versions ~registry ~dispatcher:(fun { dispatch_iter; _ } conn query -> dispatch_iter conn query ~f) ;; let dispatch_multi conn_with_menu query = Dispatch.Async.with_version_menu conn_with_menu query ~name ~versions ~registry ~dispatcher:(fun { dispatch; _ } conn query -> dispatch conn query) ;; let abort_multi conn_with_menu id = Dispatch.Direct.with_version_menu conn_with_menu id ~name ~versions ~registry ~dispatcher:(fun { abort; _ } conn id -> abort conn id; Ok ()) ;; module type Version_shared = sig type query [@@deriving bin_io] type response [@@deriving bin_io] type error [@@deriving bin_io] val version : int val query_of_model : Model.query -> query val model_of_error : error -> Model.error val client_pushes_back : bool end module Make_shared (Version_i : Version_shared) (Convert : sig val convert_elt : (Version_i.response -> Model.response) Or_error.t val convert_pipe : Version_i.response Pipe.Reader.t -> Model.response Or_error.t Pipe.Reader.t end) = struct open Version_i open Convert let rpc = Pipe_rpc.create ~name ~version ~bin_query ~bin_response ~bin_error ?client_pushes_back:(Option.some_if client_pushes_back ()) () ;; let wrapped_query_of_model q = match Version_i.query_of_model q with | exception exn -> return (Error (failed_conversion (`Query, `Rpc name, `Version version, exn))) | q -> return (Ok q) ;; let convert_result result ~convert_ok = match result with | Error _ as e -> e | Ok (Error e) -> (match Version_i.model_of_error e with | e' -> Ok (Error e') | exception exn -> Error (failed_conversion (`Error, `Rpc name, `Version version, exn))) | Ok (Ok ok) -> Ok (Ok (convert_ok ok)) ;; let dispatch conn q = wrapped_query_of_model q >>=? fun q -> let%map result = Pipe_rpc.dispatch rpc conn q in convert_result result ~convert_ok:(fun (pipe, id) -> convert_pipe pipe, id) ;; let dispatch_iter conn q ~f = let convert_elt = Or_error.ok_exn convert_elt in wrapped_query_of_model q >>=? fun q -> let convert_message (m : _ Pipe_rpc.Pipe_message.t) = match m with | Closed _ as closed -> closed | Update u -> Update (convert_elt u) in let%map result = Pipe_rpc.dispatch_iter rpc conn q ~f:(fun message -> f (convert_message message)) in convert_result result ~convert_ok:Fn.id ;; let abort conn id = Pipe_rpc.abort rpc conn id let () = match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:({ abort; dispatch; dispatch_iter }, Any.Pipe rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end module Register_raw (Version_i : sig include Version_shared val model_of_response : response Pipe.Reader.t -> Model.response Or_error.t Pipe.Reader.t end) = Make_shared (Version_i) (struct let convert_elt = Or_error.error_string "Cannot use Direct with Register_raw" let convert_pipe = Version_i.model_of_response end) module Register (Version_i : sig include Version_shared val model_of_response : response -> Model.response end) = Make_shared (Version_i) (struct let convert_elt = Ok Version_i.model_of_response let convert_pipe rs = Pipe.map rs ~f:(fun r -> match Version_i.model_of_response r with | r -> Ok r | exception exn -> Error (failed_conversion (`Response, `Rpc name, `Version Version_i.version, exn))) ;; end) end end module State_rpc = struct module type S = sig type query type state type update type error val dispatch_multi : Connection_with_menu.t -> query -> ( state * update Or_error.t Pipe.Reader.t * State_rpc.Metadata.t , error ) Result.t Or_error.t Deferred.t val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type query type state type update type error end) = struct let name = Model.name let registry = Int.Table.create ~size:1 () let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Int.Table.keys registry) let dispatch_multi conn_with_menu query = Dispatch.Async.with_version_menu conn_with_menu query ~name ~versions ~registry ~dispatcher:Fn.id ;; module type Version_shared = sig type query [@@deriving bin_io] type state [@@deriving bin_io] type update [@@deriving bin_io] type error [@@deriving bin_io] val version : int val query_of_model : Model.query -> query val model_of_state : state -> Model.state val model_of_error : error -> Model.error val client_pushes_back : bool end module Register_raw (Version_i : sig include Version_shared val model_of_update : update Pipe.Reader.t -> Model.update Or_error.t Pipe.Reader.t end) = struct open Version_i let rpc = State_rpc.create ~name ~version ~bin_query ~bin_state ~bin_update ~bin_error ?client_pushes_back:(Option.some_if client_pushes_back ()) () ;; let () = let dispatch conn q = match Version_i.query_of_model q with | exception exn -> return (Error (failed_conversion (`Query, `Rpc name, `Version version, exn))) | q -> let%map result = State_rpc.dispatch rpc conn q in (match result with | Error exn -> Error exn | Ok (Error e) -> (match Version_i.model_of_error e with | e' -> Ok (Error e') | exception exn -> Error (failed_conversion (`Error, `Rpc name, `Version version, exn))) | Ok (Ok (state, pipe, id)) -> (match Version_i.model_of_state state with | exception exn -> Error (failed_conversion (`State, `Rpc name, `Version version, exn)) | state -> Ok (Ok (state, Version_i.model_of_update pipe, id)))) in match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:(dispatch, Any.State rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end module Register (Version_i : sig include Version_shared val model_of_update : update -> Model.update end) = struct include Register_raw (struct include Version_i let model_of_update rs = Pipe.map rs ~f:(fun r -> match Version_i.model_of_update r with | r -> Ok r | exception exn -> Error (failed_conversion (`Update, `Rpc name, `Version version, exn))) ;; end) end end end module One_way = struct module type S = sig type msg val dispatch_multi : Connection_with_menu.t -> msg -> unit Or_error.t val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string type msg end) = struct let name = Model.name let registry = Int.Table.create ~size:1 () let rpcs () = List.map (Hashtbl.data registry) ~f:(fun (_, rpc) -> rpc) let versions () = Int.Set.of_list (Int.Table.keys registry) let dispatch_multi conn_with_menu msg = Dispatch.Direct.with_version_menu conn_with_menu msg ~name ~versions ~registry ~dispatcher:Fn.id ;; module Register (Version_i : sig type msg [@@deriving bin_io] val version : int val msg_of_model : Model.msg -> msg end) = struct open Version_i let rpc = One_way.create ~name ~version ~bin_msg let () = let dispatch conn q = match Result.try_with (fun () -> Version_i.msg_of_model q) with | Error exn -> Error (failed_conversion (`Msg, `Rpc name, `Version version, exn)) | Ok q -> One_way.dispatch rpc conn q in match Hashtbl.find registry version with | None -> Hashtbl.set registry ~key:version ~data:(dispatch, Any.One_way rpc) | Some _ -> Error.raise (multiple_registrations (`Rpc name, `Version version)) ;; end end end end module Both_convert = struct module Plain = struct module type S = sig type caller_query type callee_query type caller_response type callee_response val dispatch_multi : Connection_with_menu.t -> caller_query -> caller_response Or_error.t Deferred.t val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> callee_response Deferred.t) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type query type response end module Callee : sig type query type response end end) = struct open Model let name = name module Caller = Caller_converts.Rpc.Make (struct let name = name include Caller end) module Callee = Callee_converts.Rpc.Make (struct let name = name include Callee end) let%test _ = Int.Set.equal (Caller.versions ()) (Callee.versions ()) module Register (Version : sig open Model val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] val query_of_caller_model : Caller.query -> query val callee_model_of_query : query -> Callee.query val response_of_callee_model : Callee.response -> response val caller_model_of_response : response -> Caller.response end) = struct include Callee.Register (struct include Version let model_of_query = callee_model_of_query let response_of_model = response_of_callee_model end) include Caller.Register (struct include Version let query_of_model = query_of_caller_model let model_of_response = caller_model_of_response end) let%test _ = Int.Set.equal (Caller.versions ()) (Callee.versions ()) end let dispatch_multi = Caller.dispatch_multi let implement_multi = Callee.implement_multi (* Note: Caller.versions is the same as Callee.versions, so it doesn't matter which one we call here. Same for [rpcs]. *) let versions () = Caller.versions () let rpcs () = Caller.rpcs () end end module Pipe_rpc = struct module type S = sig type caller_query type callee_query type caller_response type callee_response type caller_error type callee_error val dispatch_multi : Connection_with_menu.t -> caller_query -> ( caller_response Or_error.t Pipe.Reader.t * Pipe_rpc.Metadata.t , caller_error ) Result.t Or_error.t Deferred.t val dispatch_iter_multi : Connection_with_menu.t -> caller_query -> f:(caller_response Pipe_rpc.Pipe_message.t -> Pipe_rpc.Pipe_response.t) -> (Pipe_rpc.Id.t, caller_error) Result.t Or_error.t Deferred.t val abort_multi : Connection_with_menu.t -> Pipe_rpc.Id.t -> unit Or_error.t val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> (callee_response Pipe.Reader.t, callee_error) Result.t Deferred.t) -> 'state Implementation.t list val implement_direct_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> callee_response Versioned_direct_stream_writer.t -> (unit, callee_error) Result.t Deferred.t) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type query type response type error end module Callee : sig type query type response type error end end) = struct open Model let name = name module Caller = Caller_converts.Pipe_rpc.Make (struct let name = name include Caller end) module Callee = Callee_converts.Pipe_rpc.Make (struct let name = name include Callee end) let%test _ = Int.Set.equal (Caller.versions ()) (Callee.versions ()) module type Version_shared = sig val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] type error [@@deriving bin_io] val query_of_caller_model : Model.Caller.query -> query val callee_model_of_query : query -> Model.Callee.query val error_of_callee_model : Model.Callee.error -> error val caller_model_of_error : error -> Model.Caller.error val client_pushes_back : bool end module Register_raw (Version_i : sig include Version_shared val response_of_callee_model : Model.Callee.response Pipe.Reader.t -> response Pipe.Reader.t val caller_model_of_response : response Pipe.Reader.t -> Model.Caller.response Or_error.t Pipe.Reader.t end) = struct include Callee.Register_raw (struct include Version_i let model_of_query = callee_model_of_query let response_of_model = response_of_callee_model let error_of_model = error_of_callee_model end) include Caller.Register_raw (struct include Version_i let query_of_model = query_of_caller_model let model_of_response = caller_model_of_response let model_of_error = caller_model_of_error end) end module Register (Version_i : sig include Version_shared val response_of_callee_model : Model.Callee.response -> response val caller_model_of_response : response -> Model.Caller.response end) = struct include Callee.Register (struct include Version_i let model_of_query = callee_model_of_query let response_of_model = response_of_callee_model let error_of_model = error_of_callee_model end) include Caller.Register (struct include Version_i let query_of_model = query_of_caller_model let model_of_response = caller_model_of_response let model_of_error = caller_model_of_error end) end let dispatch_multi = Caller.dispatch_multi let dispatch_iter_multi = Caller.dispatch_iter_multi let abort_multi = Caller.abort_multi let implement_multi = Callee.implement_multi let implement_direct_multi = Callee.implement_direct_multi let versions () = Caller.versions () let rpcs () = Caller.rpcs () end end module State_rpc = struct module type S = sig type caller_query type callee_query type caller_state type callee_state type caller_update type callee_update type caller_error type callee_error val dispatch_multi : Connection_with_menu.t -> caller_query -> ( caller_state * caller_update Or_error.t Pipe.Reader.t * State_rpc.Metadata.t , caller_error ) Result.t Or_error.t Deferred.t val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> (callee_state * callee_update Pipe.Reader.t, callee_error) Result.t Deferred.t) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type query type state type update type error end module Callee : sig type query type state type update type error end end) = struct open Model let name = name module Caller = Caller_converts.State_rpc.Make (struct let name = name include Caller end) module Callee = Callee_converts.State_rpc.Make (struct let name = name include Callee end) let%test _ = Int.Set.equal (Caller.versions ()) (Callee.versions ()) module type Version_shared = sig val version : int type query [@@deriving bin_io] type state [@@deriving bin_io] type update [@@deriving bin_io] type error [@@deriving bin_io] val query_of_caller_model : Model.Caller.query -> query val callee_model_of_query : query -> Model.Callee.query val caller_model_of_state : state -> Model.Caller.state val state_of_callee_model : Model.Callee.state -> state val caller_model_of_error : error -> Model.Caller.error val error_of_callee_model : Model.Callee.error -> error val client_pushes_back : bool end module Register_raw (Version_i : sig include Version_shared val caller_model_of_update : update Pipe.Reader.t -> Model.Caller.update Or_error.t Pipe.Reader.t val update_of_callee_model : Model.Callee.state -> Model.Callee.update Pipe.Reader.t -> update Pipe.Reader.t end) = struct include Callee.Register_raw (struct include Version_i let model_of_query = callee_model_of_query let state_of_model = state_of_callee_model let update_of_model = update_of_callee_model let error_of_model = error_of_callee_model end) include Caller.Register_raw (struct include Version_i let query_of_model = query_of_caller_model let model_of_state = caller_model_of_state let model_of_update = caller_model_of_update let model_of_error = caller_model_of_error end) end module Register (Version_i : sig include Version_shared val update_of_callee_model : Model.Callee.update -> update val caller_model_of_update : update -> Model.Caller.update end) = struct include Callee.Register (struct include Version_i let model_of_query = callee_model_of_query let state_of_model = state_of_callee_model let update_of_model = update_of_callee_model let error_of_model = error_of_callee_model end) include Caller.Register (struct include Version_i let query_of_model = query_of_caller_model let model_of_state = caller_model_of_state let model_of_update = caller_model_of_update let model_of_error = caller_model_of_error end) end let dispatch_multi = Caller.dispatch_multi let implement_multi = Callee.implement_multi let versions () = Caller.versions () let rpcs () = Caller.rpcs () end end module One_way = struct module type S = sig type caller_msg type callee_msg val dispatch_multi : Connection_with_menu.t -> caller_msg -> unit Or_error.t val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_msg -> unit) -> 'state Implementation.t list val rpcs : unit -> Any.t list val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type msg end module Callee : sig type msg end end) = struct open Model let name = name module Caller = Caller_converts.One_way.Make (struct let name = name include Caller end) module Callee = Callee_converts.One_way.Make (struct let name = name include Callee end) let%test _ = Int.Set.equal (Caller.versions ()) (Callee.versions ()) module Register (Version : sig open Model val version : int type msg [@@deriving bin_io] val msg_of_caller_model : Caller.msg -> msg val callee_model_of_msg : msg -> Callee.msg end) = struct include Callee.Register (struct include Version let model_of_msg = callee_model_of_msg end) include Caller.Register (struct include Version let msg_of_model = msg_of_caller_model end) let%test _ = Int.Set.equal (Caller.versions ()) (Callee.versions ()) end let dispatch_multi = Caller.dispatch_multi let implement_multi = Callee.implement_multi (* Note: Caller.versions is the same as Callee.versions, so it doesn't matter which one we call here. Same for [rpcs]. *) let versions () = Caller.versions () let rpcs () = Caller.rpcs () end end end async_rpc_kernel-0.15.0/src/versioned_rpc.mli000066400000000000000000001221251420273305200212530ustar00rootroot00000000000000 (** Infrastructure code for managing RPCs that evolve over time to use different types at different versions. Three scenarios are supported: {ul {li The {e caller} is responsible for managing versions and dispatches to callees that are written in a version-oblivious way. The prototypical example of this scenario is a commander that needs to call out to many assistants for that same system. In this scenario, the assistants each implement a single version of the rpc and the commander has to take this into account. } {li The {e callee} is responsible for managing versions and callers need not bother themselves with any versions. The proto-typical example of this scenario is an assistant from one system calling out the commander of another system. In this scenario, the assistants each know a single version of the rpc to call and the commander has to implement them all. } {li Both {e caller} and {e callee} cooperate to decide which version to use, each one being able to use some subset of all possible versions. The prototypical example of this scenario is when two systems developed independently with their rpc types defined in some shared library that has yet another independent rollout schedule. In this case one may roll out a new rpc version (V) in the shared library (L) and then the caller and callee systems can each upgrade to the new version of L supporting version V at their own pace, with version V only being exercised once both caller and callee have upgraded. } } In each scenario, it is desirable that the party responsible for managing versions be coded largely in terms of a single "master" version of the types involved, with all necessary type conversions relegated to a single module. [Versioned_rpc] is intended for implementing such a module. Type coercions into and out of the model go in the directions indicated by the following diagram: {v Caller converts Callee converts =============== =============== caller callee | callee | callee | | caller | | callee | | | | | | ,-->-- Q1 --> R1 -->-. Q1 -->-. | ,-->-- R1 / \ \ | / Q --->-- Q2 --> R2 -->-- R Q2 -->-- Q --> R --->-- R2 \ / / \ `-->-- Q3 --> R3 -->-´ Q3 -->-´ `-->-- R3 v} *) open! Core open! Async_kernel open Rpc (** Over-the-network discovery of rpc names and versions supported by a callee. This is used by the [dispatch_multi] functions in [Caller_converts] and [Both_convert] to dynamically determine the most appropriate version to use. *) module Menu : sig (** A directory of supported rpc names and versions. *) type t (** [add impls] extends a list of rpc implementations with an additional rpc implementation for providing a [Menu.t] when one is requested via [Menu.request]. *) val add : 's Implementation.t list -> 's Implementation.t list (** Specifies directly how to handle the version menu rpc. *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('s -> version:int -> unit -> Description.t list Deferred.t) -> 's Implementation.t list (** Requests an rpc version menu from an rpc connection. *) val request : Connection.t -> t Or_error.t Deferred.t (** Finds what rpcs are supported. *) val supported_rpcs : t -> Description.t list (** Finds what versions of a particular rpc are supported. *) val supported_versions : t -> rpc_name:string -> Int.Set.t (** Creates a menu directly -- generally you should use [request] instead. *) val create : Description.t list -> t (** The internal name of this RPC -- for example to be used in [Rpc.Expert] to distinguish it from other queries. *) val rpc_name : string end module Connection_with_menu : sig (** An rpc connection paired with the menu of rpcs one may call on it. *) type t val create : Connection.t -> t Deferred.Or_error.t val create_directly : Connection.t -> Menu.t -> t val connection : t -> Connection.t val menu : t -> Menu.t end (** A [Versioned_direct_stream_writer.t] is an extension of an [Rpc.Direct_stream_writer]. @see [Rpc.Pipe_rpc.Direct_stream_writer] for documentation. *) module Versioned_direct_stream_writer : sig type 'a t val write : 'a t -> 'a -> [ `Flushed of unit Deferred.t | `Closed ] val write_without_pushback : 'a t -> 'a -> [ `Ok | `Closed ] val close : _ t -> unit val closed : _ t -> unit Deferred.t val is_closed : _ t -> bool end module Caller_converts : sig module Rpc : sig (* signature for rpc dispatchers *) module type S = sig type query type response (** Multi-version dispatch. *) val dispatch_multi : Connection_with_menu.t -> query -> response Or_error.t Deferred.t (** All rpcs supported by [dispatch_multi]. *) val rpcs : unit -> Any.t list (** All versions supported by [dispatch_multi] (useful for computing which old versions may be pruned). *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of RPCs, this functor provides a single RPC versioned dispatch function [dispatch_multi] in terms of that model and a mechanism for registering the individual versions that [dispatch_multi] knows about. Registration requires knowing how to get into and out of the model. {v ,-->-- Q1 --> R1 -->-. / \ Q --->-- Q2 --> R2 -->-- R \ / `-->-- Q3 --> R3 -->-´ v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type query type response end) : sig (** Adds a new version to the set of versions available via [dispatch_multi]. *) module Register (Version_i : sig val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] val query_of_model : Model.query -> query val model_of_response : response -> Model.response end) : sig val rpc : (Version_i.query, Version_i.response) Rpc.t end (** A variant of [Register] in which the query is made available when transforming the response *) module Register' (Version_i : sig val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] val query_of_model : Model.query -> query val model_of_response : Model.query -> response -> Model.response end) : sig val rpc : (Version_i.query, Version_i.response) Rpc.t end include S with type query := Model.query with type response := Model.response end end module Pipe_rpc : sig (* signature for dispatchers *) module type S = sig type query type response type error (** Multi-version dispatch. The return type varies slightly from [Rpc.Pipe_rpc.dispatch] to make it clear that conversion of each individual element in the returned pipe may fail. *) val dispatch_multi : Connection_with_menu.t -> query -> (response Or_error.t Pipe.Reader.t * Pipe_rpc.Metadata.t, error) Result.t Or_error.t Deferred.t val dispatch_iter_multi : Connection_with_menu.t -> query -> f:(response Pipe_rpc.Pipe_message.t -> Pipe_rpc.Pipe_response.t) -> (Pipe_rpc.Id.t, error) Result.t Or_error.t Deferred.t val abort_multi : Connection_with_menu.t -> Pipe_rpc.Id.t -> unit Or_error.t (** All rpcs supported by [dispatch_multi] *) val rpcs : unit -> Any.t list (** All versions supported by [dispatch_multi]. (useful for computing which old versions may be pruned) *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of Pipe_RPCs, this functor provides a single Pipe_RPC versioned dispatch function [dispatch_multi] in terms of that model and a mechanism for registering the individual versions that [dispatch_multi] knows about. Registration requires knowing how to get into and out of the model. {v ,-->-- Q1 --> R1 -->-. E1 -->-. / \ \ Q --->-- Q2 --> R2 -->-- R E2 -->-- E \ / / `-->-- Q3 --> R3 -->-´ E3 -->-´ v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type query type response type error end) : sig module type Version_shared = sig type query [@@deriving bin_io] type response [@@deriving bin_io] type error [@@deriving bin_io] val version : int val query_of_model : Model.query -> query val model_of_error : error -> Model.error val client_pushes_back : bool end (** add a new version to the set of versions available via [dispatch_multi] and [dispatch_iter_multi]. *) module Register (Version_i : sig include Version_shared val model_of_response : response -> Model.response end) : sig val rpc : (Version_i.query, Version_i.response, Version_i.error) Pipe_rpc.t end (** [Register_raw] is like [Register] except you get to deal with the whole pipe. This is useful if, e.g., your [model_of_response] function can fail, so that you'd like to filter items out from the result pipe. *) module Register_raw (Version_i : sig include Version_shared (** [model_of_response] should never raise exceptions. If it does, [dispatch_multi] is going to raise, which is not supposed to happen. One may not call [dispatch_iter_multi] when using [Register_raw] as [Pipe_rpc.dispatch_iter] never has access to a pipe. *) val model_of_response : response Pipe.Reader.t -> Model.response Or_error.t Pipe.Reader.t end) : sig val rpc : (Version_i.query, Version_i.response, Version_i.error) Pipe_rpc.t end include S with type query := Model.query with type response := Model.response with type error := Model.error end end module State_rpc : sig (* signature for dispatchers *) module type S = sig type query type state type update type error (** Multi-version dispatch The return type varies slightly from [Rpc.State_rpc.dispatch] to make it clear that conversion of each individual element in the returned pipe may fail. *) val dispatch_multi : Connection_with_menu.t -> query -> ( state * update Or_error.t Pipe.Reader.t * State_rpc.Metadata.t , error ) Result.t Or_error.t Deferred.t (** All rpcs supported by [dispatch_multi] *) val rpcs : unit -> Any.t list (** All versions supported by [dispatch_multi] (useful for computing which old versions may be pruned). *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of State_RPCs, this functor provides a single State_RPC versioned dispatch function [dispatch_multi] in terms of that model and a mechanism for registering the individual versions that [dispatch_multi] knows about. Registration requires knowing how to get into and out of the model. {v ,-->-- Q1 --> (S1, U1s) -->----. E1 -->-. / \ \ Q --->-- Q2 --> (S2, U2s) -->-- (S, Us) E2 -->-- E \ / / `-->-- Q3 --> (S3, U3s) -->----´ E3 -->-´ v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type query type state type update type error end) : sig module type Version_shared = sig type query [@@deriving bin_io] type state [@@deriving bin_io] type update [@@deriving bin_io] type error [@@deriving bin_io] val version : int val query_of_model : Model.query -> query val model_of_state : state -> Model.state val model_of_error : error -> Model.error val client_pushes_back : bool end (** Adds a new version to the set of versions available via [dispatch_multi]. *) module Register (Version_i : sig include Version_shared val model_of_update : update -> Model.update end) : sig val rpc : ( Version_i.query , Version_i.state , Version_i.update , Version_i.error ) State_rpc.t end (** [Register_raw] is like [Register] except you get to deal with the whole pipe. This is useful if, e.g., your [model_of_update] function can fail, so that you'd like to filter items out from the result pipe. *) module Register_raw (Version_i : sig include Version_shared (** [model_of_update] should never raise exceptions. If it does, [dispatch_multi] is going to raise, which is not supposed to happen. *) val model_of_update : update Pipe.Reader.t -> Model.update Or_error.t Pipe.Reader.t end) : sig val rpc : ( Version_i.query , Version_i.state , Version_i.update , Version_i.error ) State_rpc.t end include S with type query := Model.query with type state := Model.state with type update := Model.update with type error := Model.error end end module One_way : sig (** signature for rpc dispatchers *) module type S = sig type msg (** multi-version dispatch *) val dispatch_multi : Connection_with_menu.t -> msg -> unit Or_error.t (** All rpcs supported by [dispatch_multi] *) val rpcs : unit -> Any.t list (** All versions supported by [dispatch_multi]. (useful for computing which old versions may be pruned) *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of RPCs, this functor provides a single RPC versioned dispatch function [dispatch_multi] in terms of that model and a mechanism for registering the individual versions that [dispatch_multi] knows about. Registration requires knowing how to get out of the model. {v ,-->-- M1 / M --->-- M2 \ `-->-- M3 v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type msg end) : sig (** add a new version to the set of versions available via [dispatch_multi]. *) module Register (Version_i : sig val version : int type msg [@@deriving bin_io] val msg_of_model : Model.msg -> msg end) : sig val rpc : Version_i.msg One_way.t end include S with type msg := Model.msg end end end module Callee_converts : sig module Rpc : sig module Simple : sig type ('query, 'response) t val create : name:string -> ('query, 'response) t val name : (_, _) t -> string val add_version : ('query, 'response) t -> version:int -> bin_query:'old_query Bin_prot.Type_class.t -> bin_response:'old_response Bin_prot.Type_class.t -> ('old_query -> 'query) -> ('response -> 'old_response) -> ('query, 'response) t Or_error.t val add_version_with_failure : ('query, 'response Or_error.t) t -> version:int -> bin_query:'old_query Bin_prot.Type_class.t -> bin_response:('old_response, string) Result.t Bin_prot.Type_class.t -> ('old_query -> 'query Or_error.t) -> ('response -> 'old_response Or_error.t) -> ('query, 'response Or_error.t) t Or_error.t val add_rpc_version : ('query, 'response) t -> ('old_query, 'old_response) Rpc.t -> ('old_query -> 'query) -> ('response -> 'old_response) (** [Error _] if the version has already been implemented, or the name disagrees. *) -> ('query, 'response) t Or_error.t val add_rpc_version_with_failure : ('query, 'response Or_error.t) t -> ('old_query, ('old_response, string) Result.t) Rpc.t -> ('old_query -> 'query Or_error.t) -> ('response -> 'old_response Or_error.t) -> ('query, 'response Or_error.t) t Or_error.t val implement : ('query, 'response) t -> ('state -> 'query -> 'response Deferred.t) -> 'state Implementation.t list end module type S = sig type query type response (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> query -> response Deferred.t) -> 'state Implementation.t list (** All rpcs implemented by [implement_multi] *) val rpcs : unit -> Any.t list (** All versions implemented by [implement_multi]. (useful for computing which old versions may be pruned) *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of RPCs, this functor provides a single multi-version implementation function [implement_multi] in terms of that model and a mechanism for registering the individual versions that [implement_multi] knows about. Registration requires knowing how to get into and out of the model. {v Q1 -->-. ,-->-- R1 \ / Q2 -->-- Q --> R --->-- R2 / \ Q3 -->-´ `-->-- R3 v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type query type response end) : sig (** Add a new version to the set of versions implemented by [implement_multi]. *) module Register (Version_i : sig val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] val model_of_query : query -> Model.query val response_of_model : Model.response -> response end) : sig val rpc : (Version_i.query, Version_i.response) Rpc.t end include S with type query := Model.query with type response := Model.response end end module Pipe_rpc : sig module type S = sig type query type response type error (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> query -> (response Pipe.Reader.t, error) Result.t Deferred.t) -> 'state Implementation.t list (** implement multiple versions at once, using a [Versioned_direct_stream_writer] *) val implement_direct_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> query -> response Versioned_direct_stream_writer.t -> (unit, error) Result.t Deferred.t) -> 'state Implementation.t list (** All rpcs implemented by [implement_multi] *) val rpcs : unit -> Any.t list (** All versions supported by [implement_multi]. (useful for computing which old versions may be pruned) *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of Pipe_RPCs, this functor provides a single multi-version implementation function [implement_multi] in terms of that model and a mechanism for registering the individual versions that [implement_multi] knows about. Registration requires knowing how to get into and out of the model. {v Q1 -->-. ,-->-- R1 \ / Q2 -->-- Q --> R --->-- R2 / \ Q3 -->-´ `-->-- R3 v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type query type response type error end) : sig module type Version_shared = sig type query [@@deriving bin_io] type response [@@deriving bin_io] type error [@@deriving bin_io] val version : int val model_of_query : query -> Model.query val error_of_model : Model.error -> error val client_pushes_back : bool end (** add a new version to the set of versions available via [implement_multi] or [implement_direct]. *) module Register (Version_i : sig include Version_shared val response_of_model : Model.response -> response end) : sig val rpc : (Version_i.query, Version_i.response, Version_i.error) Pipe_rpc.t end (** [Register_raw] is like [Register] except you get the whole pipe to deal with. This is useful if, e.g., your [response_of_model] function can fail, so that you'd like to filter items out from the result pipe. You may not call [implement_direct_multi] when using [Register_raw], as [Pipe_rpc.implement_direct] never has access to a pipe. *) module Register_raw (Version_i : sig include Version_shared val response_of_model : Model.response Pipe.Reader.t -> response Pipe.Reader.t end) : sig val rpc : (Version_i.query, Version_i.response, Version_i.error) Pipe_rpc.t end include S with type query := Model.query with type response := Model.response with type error := Model.error end end module State_rpc : sig module type S = sig type query type state type update type error (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('connection_state -> version:int -> query -> (state * update Pipe.Reader.t, error) Result.t Deferred.t) -> 'connection_state Implementation.t list (** All rpcs implemented by [implement_multi] *) val rpcs : unit -> Any.t list (** All versions supported by [implement_multi]. (useful for computing which old versions may be pruned) *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of State_RPCs, this functor provides a single multi-version implementation function [implement_multi] in terms of that model and a mechanism for registering the individual versions that [implement_multi] knows about. Registration requires knowing how to get into and out of the model. {v Q1 -->-. ,---->-- (S1, U1s) \ / Q2 -->-- Q --> (S, Us) -->-- (S2, U2s) / \ Q3 -->-´ `---->-- (S3, U3s) v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type query type state type update type error end) : sig module type Version_shared = sig type query [@@deriving bin_io] type state [@@deriving bin_io] type update [@@deriving bin_io] type error [@@deriving bin_io] val version : int val model_of_query : query -> Model.query val state_of_model : Model.state -> state val error_of_model : Model.error -> error val client_pushes_back : bool end (** add a new version to the set of versions available via [implement_multi]. *) module Register (Version_i : sig include Version_shared val update_of_model : Model.update -> update end) : sig val rpc : ( Version_i.query , Version_i.state , Version_i.update , Version_i.error ) State_rpc.t end (** [Register_raw] is like [Register] except you get the whole update pipe to deal with. This is useful if, e.g., your [update_of_model] function can fail, so that you'd like to filter items out from the result pipe. *) module Register_raw (Version_i : sig include Version_shared val update_of_model : Model.state -> Model.update Pipe.Reader.t -> update Pipe.Reader.t end) : sig val rpc : ( Version_i.query , Version_i.state , Version_i.update , Version_i.error ) State_rpc.t end include S with type query := Model.query with type state := Model.state with type update := Model.update with type error := Model.error end end module One_way : sig module type S = sig type msg (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> msg -> unit) -> 'state Implementation.t list (** All rpcs implemented by [implement_multi] *) val rpcs : unit -> Any.t list (** All versions implemented by [implement_multi]. (useful for computing which old versions may be pruned) *) val versions : unit -> Int.Set.t val name : string end (** Given a model of the types involved in a family of RPCs, this functor provides a single multi-version implementation function [implement_multi] in terms of that model and a mechanism for registering the individual versions that [implement_multi] knows about. Registration requires knowing how to get into the model. {v M1 -->-. \ M2 -->-- M / M3 -->-´ v} *) module Make (Model : sig val name : string (* the name of the Rpc's being unified in the model *) type msg end) : sig (** Add a new version to the set of versions implemented by [implement_multi]. *) module Register (Version_i : sig val version : int type msg [@@deriving bin_io] val model_of_msg : msg -> Model.msg end) : sig val rpc : Version_i.msg One_way.t end include S with type msg := Model.msg end end end module Both_convert : sig (** [Both_convert] rpcs combine features of both caller-converts and callee-converts versioning schemes in such a way that one can smoothly add a new version of the rpc to a shared library, and it doesn't matter whether the callee or caller upgrades to the latest version of the shared library first, the new version will not be exercised until both sides support it. *) module Plain : sig (** {v (conv) (conv) (conv) (conv) caller callee callee caller | | | | | | | | Q.caller ---->-- Q1 -->-. (impl) .->-- R1 -->---- R.caller \ \ callee / / \--->-- Q2 -->---\ | /--->-- R2 -->---/ \ \ | / / `->-- Q3 -->---- Q.callee --> R.callee ---->-- R3 -->-´ v} *) module type S = sig type caller_query type caller_response type callee_query type callee_response (** multi-version dispatch *) val dispatch_multi : Connection_with_menu.t -> caller_query -> caller_response Or_error.t Deferred.t (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> callee_response Deferred.t) -> 'state Implementation.t list (** All supported rpcs. *) val rpcs : unit -> Any.t list (** All supported versions. Useful for detecting old versions that may be pruned. *) val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type query type response end module Callee : sig type query type response end end) : sig open Model module Register (Version : sig val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] val query_of_caller_model : Caller.query -> query val callee_model_of_query : query -> Callee.query val response_of_callee_model : Callee.response -> response val caller_model_of_response : response -> Caller.response end) : sig val rpc : (Version.query, Version.response) Rpc.t end include S with type caller_query := Caller.query with type caller_response := Caller.response with type callee_query := Callee.query with type callee_response := Callee.response end end module Pipe_rpc : sig (** {v (conv) (conv) (conv) (conv) caller callee callee caller | | | | | | | | Q.caller ---->-- Q1 -->-. (impl) .->-- R1 -->---- R.caller \ \ callee / / \--->-- Q2 -->---\ | /--->-- R2 -->---/ \ \ | / / `->-- Q3 -->---- Q.callee --> R.callee ---->-- R3 -->-´ v} *) module type S = sig type caller_query type caller_response type caller_error type callee_query type callee_response type callee_error (** multi-version dispatch *) val dispatch_multi : Connection_with_menu.t -> caller_query -> ( caller_response Or_error.t Pipe.Reader.t * Pipe_rpc.Metadata.t , caller_error ) Result.t Or_error.t Deferred.t val dispatch_iter_multi : Connection_with_menu.t -> caller_query -> f:(caller_response Pipe_rpc.Pipe_message.t -> Pipe_rpc.Pipe_response.t) -> (Pipe_rpc.Id.t, caller_error) Result.t Or_error.t Deferred.t val abort_multi : Connection_with_menu.t -> Pipe_rpc.Id.t -> unit Or_error.t (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> (callee_response Pipe.Reader.t, callee_error) Result.t Deferred.t) -> 'state Implementation.t list val implement_direct_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> callee_response Versioned_direct_stream_writer.t -> (unit, callee_error) Result.t Deferred.t) -> 'state Implementation.t list (** All supported rpcs. *) val rpcs : unit -> Any.t list (** All supported versions. Useful for detecting old versions that may be pruned. *) val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type query type response type error end module Callee : sig type query type response type error end end) : sig open Model module type Version_shared = sig val version : int type query [@@deriving bin_io] type response [@@deriving bin_io] type error [@@deriving bin_io] val query_of_caller_model : Caller.query -> query val callee_model_of_query : query -> Callee.query val error_of_callee_model : Callee.error -> error val caller_model_of_error : error -> Caller.error val client_pushes_back : bool end module Register (Version_i : sig include Version_shared val response_of_callee_model : Callee.response -> response val caller_model_of_response : response -> Caller.response end) : sig val rpc : (Version_i.query, Version_i.response, Version_i.error) Pipe_rpc.t end (** [Register_raw] is like [Register] except you get the whole pipe to deal with. This is useful if, e.g., your [caller_model_of_response] function can fail, so that you'd like to filter items out from the result pipe. You can use neither [dispatch_iter_multi] nor [implement_direct_multi] if you use this, as their non-versioned counterparts do not get access to pipes. *) module Register_raw (Version_i : sig include Version_shared val response_of_callee_model : Callee.response Pipe.Reader.t -> response Pipe.Reader.t val caller_model_of_response : response Pipe.Reader.t -> Caller.response Or_error.t Pipe.Reader.t end) : sig val rpc : (Version_i.query, Version_i.response, Version_i.error) Pipe_rpc.t end include S with type caller_query := Caller.query with type caller_response := Caller.response with type caller_error := Caller.error with type callee_query := Callee.query with type callee_response := Callee.response with type callee_error := Callee.error end end module State_rpc : sig (** {v (conv) (conv) (conv) (conv) caller callee callee caller | | | | caller| | | | caller Q ---->- Q1 ->-. (impl) .->- (S1, U1s) ->---- (S, Us) \ \ callee / / \--->- Q2 ->---\ | /--->- (S2, U2s) ->---/ \ \callee | callee / / `->- Q3 ->---- Q ------> (S, Us) ---->- (S3, U3s) ->-´ v} *) module type S = sig type caller_query type callee_query type caller_state type callee_state type caller_update type callee_update type caller_error type callee_error (** multi-version dispatch *) val dispatch_multi : Connection_with_menu.t -> caller_query -> ( caller_state * caller_update Or_error.t Pipe.Reader.t * State_rpc.Metadata.t , caller_error ) Result.t Or_error.t Deferred.t (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_query -> (callee_state * callee_update Pipe.Reader.t, callee_error) Result.t Deferred.t) -> 'state Implementation.t list (** All supported rpcs. *) val rpcs : unit -> Any.t list (** All supported versions. Useful for detecting old versions that may be pruned. *) val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type query type state type update type error end module Callee : sig type query type state type update type error end end) : sig open Model module type Version_shared = sig val version : int type query [@@deriving bin_io] type state [@@deriving bin_io] type update [@@deriving bin_io] type error [@@deriving bin_io] val query_of_caller_model : Model.Caller.query -> query val callee_model_of_query : query -> Model.Callee.query val caller_model_of_state : state -> Model.Caller.state val state_of_callee_model : Model.Callee.state -> state val caller_model_of_error : error -> Model.Caller.error val error_of_callee_model : Model.Callee.error -> error val client_pushes_back : bool end module Register (Version_i : sig include Version_shared val update_of_callee_model : Model.Callee.update -> update val caller_model_of_update : update -> Model.Caller.update end) : sig val rpc : ( Version_i.query , Version_i.state , Version_i.update , Version_i.error ) State_rpc.t end (** [Register_raw] is like [Register] except you get the whole pipe to deal with. This is useful if, e.g., your [caller_model_of_update] function can fail, so that you'd like to filter items out from the result pipe. *) module Register_raw (Version_i : sig include Version_shared (** [caller_model_of_update] should never raise exceptions. If it does, [dispatch_multi] is going to raise, which is not supposed to happen. *) val caller_model_of_update : update Pipe.Reader.t -> Model.Caller.update Or_error.t Pipe.Reader.t val update_of_callee_model : Model.Callee.state -> Model.Callee.update Pipe.Reader.t -> update Pipe.Reader.t end) : sig val rpc : ( Version_i.query , Version_i.state , Version_i.update , Version_i.error ) State_rpc.t end include S with type caller_query := Caller.query with type caller_state := Caller.state with type caller_update := Caller.update with type caller_error := Caller.error with type callee_query := Callee.query with type callee_state := Callee.state with type callee_update := Callee.update with type callee_error := Callee.error end end module One_way : sig (** {v (conv) (conv) caller callee | | | | M.caller ---->-- M1 -->-. (impl) \ \ callee \--->-- M2 -->---\ | \ \ | `->-- M3 -->---- M.callee --> unit v} *) module type S = sig type caller_msg type callee_msg (** multi-version dispatch *) val dispatch_multi : Connection_with_menu.t -> caller_msg -> unit Or_error.t (** implement multiple versions at once *) val implement_multi : ?log_not_previously_seen_version:(name:string -> int -> unit) -> ('state -> version:int -> callee_msg -> unit) -> 'state Implementation.t list (** All supported rpcs. *) val rpcs : unit -> Any.t list (** All supported versions. Useful for detecting old versions that may be pruned. *) val versions : unit -> Int.Set.t val name : string end module Make (Model : sig val name : string module Caller : sig type msg end module Callee : sig type msg end end) : sig open Model module Register (Version : sig val version : int type msg [@@deriving bin_io] val msg_of_caller_model : Caller.msg -> msg val callee_model_of_msg : msg -> Callee.msg end) : sig val rpc : Version.msg One_way.t end include S with type caller_msg := Caller.msg with type callee_msg := Callee.msg end end end async_rpc_kernel-0.15.0/src/writer_with_length.ml000066400000000000000000000025441420273305200221520ustar00rootroot00000000000000open Core open Poly let of_writer { Bin_prot.Type_class.write; size } = let write buf ~pos a = let len = Nat0.of_int_exn (size a) in let pos = Nat0.bin_write_t buf ~pos len in write buf ~pos a in let size a = let len = Nat0.of_int_exn (size a) in Nat0.bin_size_t len + ((len : Bin_prot.Nat0.t) :> int) in { Bin_prot.Type_class.write; size } ;; let of_type_class (bin_a : _ Bin_prot.Type_class.t) = of_writer bin_a.writer let%test_module _ = (module struct let bigstring_bin_prot s = let bigstring = Bin_prot.Utils.bin_dump Bytes.bin_writer_t s in Bin_prot.Utils.bin_dump Bigstring.Stable.V1.bin_writer_t bigstring ;; let bin_prot_with_length s = let writer_with_length = of_writer Bytes.bin_writer_t in Bin_prot.Utils.bin_dump writer_with_length s ;; let test len = let s = Bytes.create len in let bigstring_version = bigstring_bin_prot s in let with_length_version = bin_prot_with_length s in if Bigstring.to_string bigstring_version <> Bigstring.to_string with_length_version then failwithf "mismatch for length %d" len () ;; let%test_unit _ = for len = 0 to Int.pow 2 10 do test len done; for pow = 10 to 20 do let x = Int.pow 2 pow in test (x - 1); test x; test (x + 1) done ;; end) ;; async_rpc_kernel-0.15.0/src/writer_with_length.mli000066400000000000000000000027161420273305200223240ustar00rootroot00000000000000(** A hack to make the bin-prot representation of things look as though they are packed into bigstrings, for backwards compatibility. The original version of the protocol used bigstrings to hide away user-defined types. The bin-prot representation of a record with such a bigstring in it looks like {v {field1|field2|...|{length|content}} v} where the content is the bin-prot representation of the value being written, and the length is that content's length. This writer writes data in the same format without using an intermediate bigstring by first calculating the size of the content, then writing that as a Nat0 before writing the actual content. When reading, we use the fact that the length can be interpreted as a bin-prot encoded Nat0. The grouping is changed from: {v {field1|field2|...|{length|content}} v} (only one bin-prot read) to: {v {field1|field2|...|length}|{content} v} (two bin-prot reads). If the last field is a variant type, there will be a variant tag before the length, but the exact same change of grouping will work. Note that this only works when the bigstrings are in the last field of a record (or a variant in the last field of a record). It's easy to verify that this is true. *) val of_writer : 'a Bin_prot.Type_class.writer -> 'a Bin_prot.Type_class.writer val of_type_class : 'a Bin_prot.Type_class.t -> 'a Bin_prot.Type_class.writer async_rpc_kernel-0.15.0/test/000077500000000000000000000000001420273305200160735ustar00rootroot00000000000000async_rpc_kernel-0.15.0/test/dune000066400000000000000000000002501420273305200167460ustar00rootroot00000000000000(library (name async_rpc_kernel_test) (libraries core async_kernel async_rpc_kernel expect_test_helpers_async expect_test_helpers_core) (preprocess (pps ppx_jane)))async_rpc_kernel-0.15.0/test/test_connection_time_source.ml000066400000000000000000000121221420273305200242170ustar00rootroot00000000000000open! Core open! Async open! Async_rpc_kernel open! Async_rpc_kernel_private open! Expect_test_helpers_core open! Expect_test_helpers_async module Time_ns = Core.Core_private.Time_ns_alternate_sexp let sec = Time_ns.Span.of_sec let advance_by_span time_source span = let to_ = Time_ns.add (Synchronous_time_source.now time_source) span in Synchronous_time_source.advance_by_alarms time_source ~to_ |> ok_exn ;; let heartbeat_every = sec 2. let heartbeat_timeout = sec 10. let yield () = Async_kernel_scheduler.yield_until_no_jobs_remain () let establish_connection transport time_source description = let conn = Connection.create ~connection_state:(fun _ -> ()) ~heartbeat_config: (Connection.Heartbeat_config.create ~timeout:heartbeat_timeout ~send_every:heartbeat_every ()) ~description ~time_source transport in Deferred.upon conn (fun conn -> let conn = Result.ok_exn conn in let () = Deferred.upon (Connection.close_reason conn ~on_close:`started) (fun reason -> print_s [%message "connection closed" ~now:(Synchronous_time_source.now time_source : Time_ns.t) (description : Info.t) (reason : Info.t)]) in let () = Connection.add_heartbeat_callback conn (fun () -> print_s [%message "received heartbeat" ~now:(Synchronous_time_source.now time_source : Time_ns.t) (description : Info.t)]) in ()); conn >>| Result.ok_exn ;; let%expect_test "test connection with time_source <> wall_clock" = let server_time_source = Synchronous_time_source.create ~now:Time_ns.epoch () in let client_time_source = Synchronous_time_source.create ~now:Time_ns.epoch () in let server_r, server_w = Pipe.create () in let client_r, client_w = Pipe.create () in let server_transport = Pipe_transport.create Pipe_transport.Kind.bigstring client_r server_w in let client_transport = Pipe_transport.create Pipe_transport.Kind.bigstring server_r client_w in let server_conn = establish_connection server_transport (Synchronous_time_source.read_only server_time_source) (Info.of_string "server") in let client_conn = establish_connection client_transport (Synchronous_time_source.read_only client_time_source) (Info.of_string "client") in let%bind server_conn, client_conn = Deferred.both server_conn client_conn in [%expect {| |}]; let print_liveness conn = print_s [%message "" ~last_seen_alive:(Connection.last_seen_alive conn : Time_ns.t)] in advance_by_span client_time_source Time_ns.Span.zero; advance_by_span server_time_source Time_ns.Span.zero; let%bind () = yield () in [%expect {| ("received heartbeat" (now "1970-01-01 00:00:00Z") (description server)) ("received heartbeat" (now "1970-01-01 00:00:00Z") (description client)) |}]; print_liveness server_conn; print_liveness client_conn; [%expect {| (last_seen_alive "1970-01-01 00:00:00Z") (last_seen_alive "1970-01-01 00:00:00Z") |}]; advance_by_span server_time_source heartbeat_every; advance_by_span client_time_source heartbeat_every; let%bind () = yield () in [%expect {| ("received heartbeat" (now "1970-01-01 00:00:02Z") (description client)) ("received heartbeat" (now "1970-01-01 00:00:02Z") (description server)) |}]; print_liveness server_conn; print_liveness client_conn; [%expect {| (last_seen_alive "1970-01-01 00:00:02Z") (last_seen_alive "1970-01-01 00:00:02Z") |}]; advance_by_span server_time_source heartbeat_timeout; let%bind () = yield () in [%expect {| ("received heartbeat" (now "1970-01-01 00:00:02Z") (description client)) ("received heartbeat" (now "1970-01-01 00:00:02Z") (description client)) ("received heartbeat" (now "1970-01-01 00:00:02Z") (description client)) ("received heartbeat" (now "1970-01-01 00:00:02Z") (description client)) ("received heartbeat" (now "1970-01-01 00:00:02Z") (description client)) |}]; print_liveness server_conn; print_liveness client_conn; [%expect {| (last_seen_alive "1970-01-01 00:00:02Z") (last_seen_alive "1970-01-01 00:00:02Z") |}]; advance_by_span server_time_source heartbeat_every; let%bind () = yield () in [%expect {| ("connection closed" (now "1970-01-01 00:00:14Z") (description server) (reason "No heartbeats received for 10s.")) ("connection closed" (now "1970-01-01 00:00:02Z") (description client) (reason "EOF or connection closed")) |}]; print_liveness server_conn; print_liveness client_conn; [%expect {| (last_seen_alive "1970-01-01 00:00:02Z") (last_seen_alive "1970-01-01 00:00:02Z") |}]; Deferred.all_unit [ Connection.close_finished server_conn; Connection.close_finished client_conn ] ;; async_rpc_kernel-0.15.0/test/test_connection_time_source.mli000066400000000000000000000000371420273305200243720ustar00rootroot00000000000000(* intentionally left blank *) async_rpc_kernel-0.15.0/test/test_type_ids.ml000066400000000000000000000044141420273305200213070ustar00rootroot00000000000000open! Core open Async_rpc.Rpc (* The test in this module is pretty silly; It mainly ensures that we aren't minting a new type-id every time that we call the type_id getter-functions. If the functions were implemented incorrectly, [same_witness_exn] would crash. Our type-ids also have been given names, which can be helpful for debugging, so the test prints out the names that have been given to these ids. *) let test_type_id_similarity t ~f = let T = Type_equal.Id.same_witness_exn (f t) (f t) in print_endline (Type_equal.Id.name (f t)) ;; let rpc = Rpc.create ~version:1 ~name:"my-rpc" ~bin_query:Bin_prot.Type_class.bin_unit ~bin_response:Bin_prot.Type_class.bin_int ;; let state_rpc = State_rpc.create ~version:1 ~name:"my-state-rpc" ~bin_query:Bin_prot.Type_class.bin_unit ~bin_error:Bin_prot.Type_class.bin_unit ~bin_state:Bin_prot.Type_class.bin_int ~bin_update:Bin_prot.Type_class.bin_string () ;; let pipe_rpc = Pipe_rpc.create ~version:1 ~name:"my-pipe-rpc" ~bin_query:Bin_prot.Type_class.bin_unit ~bin_error:Bin_prot.Type_class.bin_unit ~bin_response:Bin_prot.Type_class.bin_int () ;; let one_way_rpc = One_way.create ~version:1 ~name:"my-one-way-rpc" ~bin_msg:Bin_prot.Type_class.bin_unit ;; let%expect_test _ = (* rpc *) test_type_id_similarity rpc ~f:Rpc.query_type_id; test_type_id_similarity rpc ~f:Rpc.response_type_id; [%expect {| my-rpc:query my-rpc:response |}]; (* state rpc *) test_type_id_similarity state_rpc ~f:State_rpc.query_type_id; test_type_id_similarity state_rpc ~f:State_rpc.error_type_id; test_type_id_similarity state_rpc ~f:State_rpc.state_type_id; test_type_id_similarity state_rpc ~f:State_rpc.update_type_id; [%expect {| my-state-rpc:query my-state-rpc:error my-state-rpc:state my-state-rpc:update |}]; (* pipe rpc *) test_type_id_similarity pipe_rpc ~f:Pipe_rpc.query_type_id; test_type_id_similarity pipe_rpc ~f:Pipe_rpc.error_type_id; test_type_id_similarity pipe_rpc ~f:Pipe_rpc.response_type_id; [%expect {| my-pipe-rpc:query my-pipe-rpc:error my-pipe-rpc:response |}]; (* one-way rpc *) test_type_id_similarity one_way_rpc ~f:One_way.msg_type_id; [%expect {| my-one-way-rpc:msg |}] ;; async_rpc_kernel-0.15.0/test/test_type_ids.mli000066400000000000000000000000551420273305200214550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *)