├── .github └── workflows │ └── test.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── example ├── dune ├── example.ml ├── example2.ml ├── example2_client.ml ├── example2_idl.ml ├── example2_server.ml ├── example3_client.ml ├── example3_idl.ml └── template.html ├── ppx ├── common.ml ├── dune ├── ppx_deriving_rpc.ml └── ppx_deriving_rpcty.ml ├── ppx_deriving_rpc.opam ├── rpclib-async.opam ├── rpclib-html.opam ├── rpclib-js.opam ├── rpclib-lwt.opam ├── rpclib.opam ├── src ├── async │ ├── dune │ ├── rpc_async.ml │ └── rpc_async.mli ├── html │ ├── dune │ ├── htmlgen.ml │ └── htmlgen.mli ├── js │ ├── dune │ ├── rpc_client_js.ml │ ├── rpc_client_js.mli │ └── rpc_client_js_helper.ml ├── lib │ ├── cmdlinergen.ml │ ├── codegen.ml │ ├── codegen.mli │ ├── dune │ ├── idl.ml │ ├── idl.mli │ ├── internals.ml │ ├── jsonrpc.ml │ ├── jsonrpc.mli │ ├── markdowngen.ml │ ├── pythongen.ml │ ├── rpc.ml │ ├── rpc.mli │ ├── rpc_client.mli │ ├── rpc_empty_module.ml │ ├── rpc_genfake.ml │ ├── rpclib.ml │ ├── rpcmarshal.ml │ ├── xmlrpc.ml │ └── xmlrpc.mli └── lwt │ ├── dune │ ├── rpc_lwt.ml │ └── rpc_lwt.mli └── tests ├── async ├── client_server_test.ml ├── dune └── suite.ml ├── common ├── dune └── test_interface.ml ├── lib ├── client_server_test.ml ├── dune ├── encoding.ml ├── json.ml ├── suite.ml └── xml_xapi.ml ├── lwt ├── client_server_test.ml ├── dune └── suite.ml ├── ppx ├── all_types.ml ├── dict.ml ├── dune ├── option.ml ├── phantom.ml ├── suite.ml ├── test_deriving_rpc.ml ├── test_deriving_rpcty.ml ├── testable.ml └── variants.ml └── rpc ├── client_async_new.ml ├── client_lwt_new.ml ├── client_new.ml ├── dune ├── python ├── calc_impl │ ├── Calc.add │ ├── Calc.land │ ├── Calc.noop │ └── calc.py ├── calc_test │ ├── Calc.add │ ├── Calc.land │ ├── Calc.noop │ └── calc.py └── exn_test.py ├── suite.ml ├── suite_async.ml ├── suite_lwt.ml └── test_pythongen.ml /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Rpclib CI 2 | on: 3 | - push 4 | - pull_request 5 | jobs: 6 | run: 7 | name: Tests 8 | runs-on: ${{ matrix.operating-system }} 9 | strategy: 10 | matrix: 11 | # windows-latest async does not support it for now 12 | operating-system: [macos-latest, ubuntu-latest] 13 | ocaml-version: [ '5.2.0', '4.14.0' ] 14 | steps: 15 | - uses: actions/checkout@master 16 | - name: Setup Python 17 | uses: actions/setup-python@v5 18 | with: 19 | python-version: '3.x' 20 | - name: Cache pip 21 | uses: actions/cache@v4 22 | with: 23 | # This path is specific to Ubuntu 24 | path: ~/.cache/pip 25 | # Look to see if there is a cache hit 26 | key: ${{ runner.os }}-pip 27 | restore-keys: | 28 | ${{ runner.os }}- 29 | - name: Install Python dependencies 30 | run: pip install pylint pycodestyle 31 | - name: Install OCaml 32 | uses: ocaml/setup-ocaml@v3 33 | with: 34 | ocaml-compiler: ${{ matrix.ocaml-version }} 35 | - name: Install OCaml dependencies 36 | run: opam install -t . --deps-only 37 | - name: Build and test independently 38 | run: opam install -t rpclib rpclib-js rpclib-html rpclib-lwt rpclib-async 39 | - name: Run Rpc and Ppx_deriving_rpc Tests 40 | run: opam exec -- dune runtest -p ppx_deriving_rpc 41 | - name: Build and run Examples 42 | run: opam exec -- dune build @runexamples -p ppx_deriving_rpc 43 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | idl_test_gen.ml 3 | *.gen.ml 4 | 5 | *.install 6 | .merlin 7 | **/.merlin 8 | 9 | _opam 10 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | wrap-comments=false 3 | let-binding-spacing=sparse 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## unreleased 2 | * Removed deprecated rpc virutal package 3 | 4 | ## 9.0.0 (June 2022) 5 | * Breaking: change Cmdlinergen to use non-deprecated types (psafont #172) 6 | 7 | ## 8.1.2 (February 2022) 8 | * Add the `noargs` constructor for declaring interfaces that do not take any 9 | parameters. (tbrk #170) 10 | * Allow Xmlrpc callers to override the base64 decoding function. (tbrk #171) 11 | 12 | ## 8.1.1 (November 2021) 13 | * Ignore error about using f-strings in python bindings (psafont) 14 | * Compatibility with rresult 0.7.0 (psafont) 15 | 16 | ## 8.1.0 (March 2021) 17 | * github: test with 4.12 (psafont) 18 | * ppx_deriving_rpc: make compatible with ppxlib.0.18.0 (NathanReb) 19 | 20 | ## 8.0.0 (October 2020) 21 | * Drop reliance on base in ppx_deriving_rpc 22 | * rpclib-async: cleanup opam file 23 | * rpclib (breaking) rename notif -> is_notification 24 | 25 | ## 7.2.0 (October 2020) 26 | * ppx_deriving_rpc: fix a transitive dep on base to enable support for recent ppxlib 27 | 28 | ## 7.1.0 (June 2020) 29 | * Test suite refactoring 30 | * Port to latest ppxlib 31 | * Add ~strict flag to xmlrpc generation 32 | * Support encoding/decoding of base64 33 | * port to dune 2 34 | * Add the possibility of having null as params in a requests for JSON-RPC 35 | 36 | ## 7.0.0 (December 2019) 37 | * Add basic support for JSON-RPC notifications 38 | 39 | ## 6.1.0 (December 2019) 40 | * opam: updated bounds on a more conservative basis 41 | * travis: tests more compilers 42 | * tests: disable useless-object-inheritance on pylint checks 43 | * pythongen: generate python2-3 compatible bindings 44 | * Add ISC license 45 | * Incremented the upper bound for async's version. 46 | * Added lower bound for js_of_ocaml in related .opam file. 47 | * Fixed compilation issue with js_of_ocaml 3.5.0 and 3.5.1. 48 | * opam: remove the 'build' directive on dune dependency 49 | * opam: remove unnecessary flag 50 | * port to dune 51 | 52 | ## 6.0.0 (November 2018) 53 | * Fix ppx_deriving_rpc for newer ppxlib 54 | * test_pythongen: ignore W504, it's breaking the internet and is pointless 55 | * Add more tests and documentation 56 | * ppx_deriving_rpc: Switch to ppxlib from ppx_deriving 57 | * Fix marshalling of optional named parameters 58 | * Add failing test of optional/unnamed args for rpcs 59 | * CA-291118: Register an exception printer for IDL errors 60 | 61 | ## 5.8.0 (June 2018) 62 | * rpclib: 63 | - New `Rpc.Types` variants for 3- and 4-tuples 64 | - pythongen: fix generated exceptions 65 | - Remove broken `Rpc_client` 66 | * ppx_deriving_rpc: 67 | - rpcty ppx: Add support for 3- and 4-tuples 68 | 69 | ## 5.7.0 (June 2018) -- rpclib only 70 | - Add optional `strict` parameter to `jsonrpc.of_string` to ignore trailing 71 | junk from input. The old behaviour (`strict=true`) is the default. 72 | 73 | ## 5.6.0 (June 2018) -- 74 | * rpclib, rpclib-async, rpclib-ppx: 75 | - Remove duplication in .mlis, expose MarshalError, add docs 76 | * README 77 | - Document IDL generator 78 | * rpclib: 79 | - pythongen test: make pylint checks stricter 80 | 81 | ## 5.5.0 (June 2018) -- rpclib only 82 | - pythongen: 83 | - Correctly call superclass init in exceptions 84 | - Generate classes for errors in interface 85 | - Fix tuple typechecking 86 | 87 | ## 5.4.0 (June 2018) 88 | * ppx_deriving_rpc: 89 | - rpcty ppx: Fix warning 27 in generated field setter 90 | * rpclib: 91 | - pythongen: 92 | - Fix Python argparse CLI 93 | - Fix generated _test class to pass typechecking 94 | - Add tests using CLI 95 | 96 | ## 5.3.0 (May 2018) 97 | * ppx_deriving_rpc: 98 | - rpcty ppx: Avoid warning 23: "with clause is useless" 99 | * rpclib: 100 | - markdowngen: 101 | - document params with same types but different defs 102 | - escape special HTML and markdown chars 103 | 104 | ## 5.2.0 (May 2018) -- rpclib only 105 | - markdowngen: document nested variants and structs 106 | - rpc: remove rpclib-html from compat layer 107 | 108 | ## 5.1.0 (May 2018) 109 | - Lint generated Python code in unit test 110 | - Reorganize tests & convert to alcotest 111 | - markdowngen: show content of structs and variants in the documentation 112 | - drop support for ocaml 4.03.0 113 | - pythongen: generate pythonic code that passes linting 114 | - pythongen: introduce an optional helpers field to inject custom versions of helpers 115 | - pythongen: use a dictionary lookup for the dispatchers 116 | - pythongen: display method description for methods 117 | 118 | ## 5.0.0 (May 2018) 119 | * camlp4: delete as it is moved in ocaml-rpc-legacy 120 | * port to jbuilder, and splut the library into 121 | - ppx_deriving_rpc 122 | - rpc (compatibility meta-package) 123 | - rpclib-async 124 | - rpclib-html 125 | - rpclib-js 126 | - rpclib-lwt 127 | - rpclib 128 | 129 | ## 4.2.0 (May 2018) 130 | * idl: support unnamed parameters in Lwt and Async GenClient & GenServer 131 | * Lwt, Async GenClient: use correct RPC call wire name 132 | * Make sure fns are added with correct name in GenServer 133 | * Add client<->server interop test for IDL 134 | 135 | ## 4.1.0 (Apr 2018) 136 | * rpc_lwt: runtime check if all server as been bound to a function 137 | * rpc_async: runtime check if all server as been bound to a function 138 | * Avoid stack overflow due to List.map in Jsonrpc, Rpcmarshal, ppx 139 | 140 | ## 4.0.0 (Apr 2018) 141 | * idl.ml: Change marshalling of named optional arguments to exclude them from the argument record 142 | * pythongen.ml: Fix type checking for optional record fields 143 | 144 | ## 3.2.0 (Mar 2018) 145 | * idl.ml: make server check for completeness of the implementation 146 | * idl.mli: hide details of server impl 147 | * Add a space to store test data in an abstract type 148 | * Add the type name to the ppx-generated variant value 149 | * Improve the markdown documentation generator. 150 | * idl: enforce use of 'internal_error_of' in Error.Make 151 | 152 | ## 3.1.0 (Feb 2018) 153 | * ppx_deriving_rpcty: use native split_on_char on ocaml >= 4.04.0 154 | * ppx_deriving_rpcty: Fix 'Warning 27: unused variable x.' on deriving rpcty for structs 155 | 156 | ## 3.0.0 (Jan 2018) 157 | * lib: remove use of cppo after dropping support for ocaml 4.02.3 158 | * add support for async and core >= v0.9.0 159 | 160 | ## 2.3.0 (Jan 2018) 161 | * For tuple contains more than 2 elements, fix the element order when deriving rpcty 162 | * pythongen, rpc_genfake: improved failures for Abstract types 163 | * cmdlinergen: implement Abstract 164 | * add support for ocaml 4.06 165 | * Remove unnecessary warnings 166 | * Add failable tests for ocaml-4.06 167 | * opam: add upper bound to async 168 | * opam: remove [configure] from the build stanza 169 | 170 | ## 2.2.0 (Dec 2017) 171 | * Remove warnings by extending pattern matches in {cmdliner,markdown}gen 172 | * Redefined `to_a` with a safer interface 173 | * Add a way to explicitly mark a tuple list as a dict 174 | * Allow the use ocamldoc tags rather than [@doc ...] 175 | * Add an 'abstract' typ. 176 | * Deprecate xmlrpc from/to char producers 177 | * Deprecate jsonrpc from/to char producers 178 | * Port the jsonrpc module to yojson 179 | 180 | ## 2.1.0 (Sep 2017) 181 | * Add defaults for polymorphic variants (@jonludlam) 182 | 183 | ## 2.0.0 (Aug 2017) 184 | * Fix some cases of non-compliance with the JsonRpc v2.0 specs (@kc284) 185 | * Check the structure of error objects of JsonRpc v2.0 is spec compliant (@kc284) 186 | * Add new function to retrieve the version and id of JSON-RPC alongside the Rpc.call from the request body (@kc284) 187 | 188 | ## 1.9.53 (Jul 2017) 189 | * Delay evaluation of Cmdlinergen terms (API breaking change) (@jonludlam) 190 | * Accept marshalled ints when unmarshalling floats (@johnelse) 191 | 192 | ## 1.9.52 (Jun 2017) 193 | * Fix compilation on MacOS X (@djs55) 194 | * Add a ClientExnRpc functor that takes an RPC impl as argument (@jonludlam) 195 | * ppx_deriving_rpc: Fix marshalling of dictionaries in the rpcty code too (@jonludlam) 196 | * ppx_deriving_rpc: Allow unnamed parameters in functions to introduce compatibility with the old camlp4 idl (@jonludlam) 197 | 198 | ## 1.9.51 (May 2017) 199 | * Support Ocaml 4.03+ (@mseri) 200 | * Fixed javascript and htmlgen backends (@mseri) 201 | 202 | ## 1.9.50 (Mar 2017) 203 | * Add a ppx to replace 'with rpc' 204 | * Add a new mechanism for defining IDLs (inspired by ctypes), to replace 205 | the 'idl' syntax extension 206 | 207 | ## 1.6.0 (July 2016) 208 | * Add support for JSON-RPC v2 209 | 210 | ## 1.5.4 (June 2015) 211 | * Fix struct_extend handling of option types (with test) 212 | * Add opam file for development 213 | * Add travis 214 | 215 | ## 1.5.3 (Nov 2014) 216 | * Add a mechanism for performing upgrade 217 | 218 | ## 1.5.2 (June 2014) 219 | * Change license to ISC 220 | 221 | ## 1.5.1 (May 2014) 222 | * make js_of_ocaml dependency optional (@djs55) 223 | 224 | ## 1.5.0 (Oct 2013) 225 | * Abstract interface over Async and Lwt (@jonludlam) 226 | * Remove some debug messages (@djs55) 227 | 228 | ## 1.4.1 (May 2013) 229 | * Add support for using the browser's JSON parser (@jonludlam) 230 | 231 | ## 1.3.0 (Jan 2013) 232 | * Add support for Int32 (@jonludlam) 233 | * Make unmarshalling of variant types case insensitive (@jonludlam) 234 | * Make Xmlrpc and Jsonrpc interface look more alike (@jonludlam) 235 | * Support for recursive types in the IDL (@jonludlam) 236 | * Improve installation instructions (Daniel Weil) 237 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (X) 2010-2019, the [MirageOS contributors](https://mirage.io/community/#team) 4 | 5 | Permission to use, copy, modify, and distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build release install uninstall clean test examples reindent reformat 2 | 3 | build: 4 | dune build @install 5 | 6 | release: 7 | dune build @install --profile=release 8 | 9 | install: 10 | dune install 11 | 12 | uninstall: 13 | dune uninstall 14 | 15 | clean: 16 | dune clean 17 | 18 | test: examples 19 | dune runtest 20 | 21 | examples: 22 | dune build @runexamples -p rpc 23 | 24 | reindent: 25 | git ls-files '*.ml*' | xargs ocp-indent -i 26 | 27 | reformat: 28 | git ls-files '*.ml*' | xargs ocamlformat -i 29 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name rpclib) 3 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name example) 3 | (modules example) 4 | (libraries rpclib rpclib.markdown rresult) 5 | (preprocess 6 | (pps ppx_deriving_rpc))) 7 | 8 | (executable 9 | (name example2) 10 | (modules example2 example2_client example2_idl example2_server) 11 | (libraries rpclib rpclib.cmdliner rpclib.json threads unix) 12 | (preprocess 13 | (pps ppx_deriving_rpc))) 14 | 15 | (executable 16 | (name example3_client) 17 | (modules example3_idl example3_client) 18 | (libraries rpclib rpclib.cmdliner rpclib.markdown unix) 19 | (preprocess 20 | (pps ppx_deriving_rpc))) 21 | 22 | (rule 23 | (alias runexamples) 24 | (deps 25 | (:e example.exe)) 26 | (package ppx_deriving_rpc) 27 | (action 28 | (run %{e}))) 29 | 30 | (rule 31 | (alias runexamples) 32 | (deps 33 | (:e example2.exe)) 34 | (package ppx_deriving_rpc) 35 | (action 36 | (run %{e}))) 37 | 38 | (rule 39 | (alias runexamples) 40 | (deps 41 | (:e example3_client.exe)) 42 | (package ppx_deriving_rpc) 43 | (action 44 | (run %{e}))) 45 | -------------------------------------------------------------------------------- /example/example2.ml: -------------------------------------------------------------------------------- 1 | let _ = Example2_client.cli () 2 | -------------------------------------------------------------------------------- /example/example2_client.ml: -------------------------------------------------------------------------------- 1 | open Example2_idl 2 | module M = Idl.IdM 3 | module MyIdl = Idl.Make (M) 4 | module Client = API (MyIdl.GenClient ()) 5 | module Cmds = API (Cmdlinergen.Gen ()) 6 | 7 | (* Use a binary 16-byte length to frame RPC messages *) 8 | let binary_rpc path (call : Rpc.call) : Rpc.response = 9 | let sockaddr = Unix.ADDR_UNIX path in 10 | let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in 11 | Unix.connect s sockaddr; 12 | let ic = Unix.in_channel_of_descr s in 13 | let oc = Unix.out_channel_of_descr s in 14 | let msg_buf = Jsonrpc.string_of_call call in 15 | let len = Printf.sprintf "%016d" (String.length msg_buf) in 16 | output_string oc len; 17 | output_string oc msg_buf; 18 | flush oc; 19 | let len_buf = Bytes.make 16 '\000' in 20 | really_input ic len_buf 0 16; 21 | let len = int_of_string (Bytes.unsafe_to_string len_buf) in 22 | let msg_buf = Bytes.make len '\000' in 23 | really_input ic msg_buf 0 len; 24 | let (response : Rpc.response) = 25 | Jsonrpc.response_of_string (Bytes.unsafe_to_string msg_buf) 26 | in 27 | response 28 | 29 | let server_cmd = 30 | let doc = "Start the server" in 31 | Cmdliner.(Cmd.v 32 | (Cmd.info "server" ~doc ) 33 | (Term.(const Example2_server.start_server $ const ()))) 34 | 35 | 36 | let cli () = 37 | let default = 38 | Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) 39 | in 40 | let info = Cmdliner.Cmd.info "cli" ~version:"1.6.1" ~doc:"a cli for an API" in 41 | let rpc = binary_rpc Example2_idl.sockpath in 42 | let cmds = server_cmd 43 | :: List.map 44 | (fun t -> 45 | let term, info = t rpc in 46 | Cmdliner.(Cmd.v info Term.(term $ const ()))) 47 | (Cmds.implementation ()) 48 | in 49 | let cmd = Cmdliner.Cmd.group ~default info cmds in 50 | exit (Cmdliner.Cmd.eval cmd) 51 | -------------------------------------------------------------------------------- /example/example2_idl.ml: -------------------------------------------------------------------------------- 1 | (* Example2 *) 2 | 3 | (* In this one we're going to use the PPX to generate the structure and 4 | variant values rather than doing it by hand as in example1. We'll also 5 | actually create a client and a server process. *) 6 | 7 | open Rpc 8 | open Idl 9 | 10 | let sockpath = "/tmp/rpcsock" 11 | 12 | module Datatypes = struct 13 | module Query = struct 14 | type t = 15 | { name : string 16 | ; vendor : string 17 | ; version : string 18 | ; features : string list 19 | ; instance_id : string 20 | } 21 | [@@deriving rpcty] 22 | end 23 | 24 | (** This is the error type *) 25 | type errty = 26 | | InternalError of string 27 | | FrobnicationFailed 28 | | OperationInProgress 29 | [@@deriving rpcty] 30 | 31 | exception DatatypeError of errty 32 | 33 | let err = 34 | Error. 35 | { def = errty 36 | ; raiser = 37 | (function 38 | | e -> raise (DatatypeError e)) 39 | ; matcher = 40 | (function 41 | | DatatypeError e -> Some e 42 | | _ -> None) 43 | } 44 | end 45 | 46 | module API (R : RPC) = struct 47 | open R 48 | 49 | let description = 50 | Interface. 51 | { name = "API" 52 | ; namespace = None 53 | ; description = [ "This is another example of the ocaml-rpc IDL." ] 54 | ; version = 1, 0, 0 55 | } 56 | 57 | 58 | let implementation = implement description 59 | 60 | let query_p = 61 | Param.mk 62 | ~name:"query" 63 | ~description:[ "The result of the query operation" ] 64 | Datatypes.Query.t 65 | 66 | 67 | let unit_p = Param.mk Types.unit 68 | let string_p = Param.mk Types.string 69 | 70 | let domid_p = 71 | Param.mk ~name:"domid" ~description:[ "The domid on which to operate" ] Types.int64 72 | 73 | 74 | let vm_p = Param.mk ~name:"vm" ~description:[ "The uuid of the VM" ] Types.string 75 | 76 | let vm_desc = 77 | Param.mk ~name:"description" ~description:[ "The description of the VM" ] Types.string 78 | 79 | 80 | let err = Datatypes.err 81 | 82 | let query = 83 | declare 84 | "query" 85 | [ "Query the details of the server." ] 86 | (unit_p @-> returning query_p err) 87 | 88 | 89 | let diagnostics = 90 | declare 91 | "get_diagnostics" 92 | [ "Get diagnostics information from the server." ] 93 | (unit_p @-> returning string_p err) 94 | 95 | 96 | let test = 97 | declare 98 | "test" 99 | [ "A test of a bit more of the IDL stuff." ] 100 | (domid_p @-> vm_p @-> vm_desc @-> returning query_p err) 101 | end 102 | -------------------------------------------------------------------------------- /example/example2_server.ml: -------------------------------------------------------------------------------- 1 | open Example2_idl 2 | 3 | (* You can swap the rpc engine, by using a different monad here, 4 | note however that if you are using an asynchronous one, like 5 | lwt or async, you should also use their specific IO functions 6 | including the print functions. *) 7 | module M = Idl.IdM (* You can easily put ExnM here and the code would stay unchanged *) 8 | 9 | module MyIdl = Idl.Make (M) 10 | module Server = API (MyIdl.GenServer ()) 11 | 12 | (* Implementations of the methods *) 13 | let query () = 14 | let open Datatypes.Query in 15 | Printf.printf "Received query API call\n%!"; 16 | let result = 17 | { name = "Example2 server" 18 | ; vendor = "This is the example server showing how to use the ocaml-rpc IDL" 19 | ; version = "2.0.0" 20 | ; features = [ "defaults"; "upgradability" ] 21 | ; instance_id = string_of_int (Random.int 1000) 22 | } 23 | in 24 | MyIdl.ErrM.return result 25 | 26 | 27 | let diagnostics () = MyIdl.ErrM.return "This should be the diagnostics of the server" 28 | 29 | let test i s1 s2 = 30 | Printf.printf "%Ld %s %s\n%!" i s1 s2; 31 | query () 32 | 33 | 34 | (* Utility and general non-specific server bits and bobs *) 35 | let finally f g = 36 | try 37 | let result = f () in 38 | g (); 39 | result 40 | with 41 | | e -> 42 | g (); 43 | raise e 44 | 45 | 46 | let mkdir_rec dir perm = 47 | let rec p_mkdir dir = 48 | let p_name = Filename.dirname dir in 49 | if p_name <> "/" && p_name <> "." then p_mkdir p_name; 50 | try Unix.mkdir dir perm with 51 | | Unix.Unix_error (Unix.EEXIST, _, _) -> () 52 | in 53 | p_mkdir dir 54 | 55 | 56 | let binary_handler process s = 57 | let ic = Unix.in_channel_of_descr s in 58 | let oc = Unix.out_channel_of_descr s in 59 | (* Read a 16 byte length encoded as a string *) 60 | let len_buf = Bytes.make 16 '\000' in 61 | really_input ic len_buf 0 (Bytes.length len_buf); 62 | let len = int_of_string (Bytes.unsafe_to_string len_buf) in 63 | let msg_buf = Bytes.make len '\000' in 64 | really_input ic msg_buf 0 (Bytes.length msg_buf); 65 | let ( >>= ) = M.bind in 66 | process msg_buf 67 | >>= fun result -> 68 | let len_buf = Printf.sprintf "%016d" (String.length result) in 69 | output_string oc len_buf; 70 | output_string oc result; 71 | flush oc; 72 | M.return () 73 | 74 | 75 | let serve_requests rpcfn path = 76 | (try Unix.unlink path with 77 | | Unix.Unix_error (Unix.ENOENT, _, _) -> ()); 78 | mkdir_rec (Filename.dirname path) 0o0755; 79 | let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in 80 | Unix.bind sock (Unix.ADDR_UNIX path); 81 | Unix.listen sock 5; 82 | Printf.fprintf stdout "Listening on %s" path; 83 | while true do 84 | let this_connection, _ = Unix.accept sock in 85 | let (_ : Thread.t) = 86 | Thread.create 87 | (fun () -> 88 | finally 89 | (* Here I am calling M.run to make sure that I am running the process, 90 | this is not much of a problem with IdM or ExnM, but in general you 91 | should ensure that the computation is started by a runner. *) 92 | (fun () -> binary_handler rpcfn this_connection |> M.run) 93 | (fun () -> Unix.close this_connection)) 94 | () 95 | in 96 | () 97 | done 98 | 99 | 100 | let start_server () = 101 | Server.query query; 102 | Server.diagnostics diagnostics; 103 | Server.test test; 104 | let rpc_fn = MyIdl.server Server.implementation in 105 | let process x = 106 | let open M in 107 | rpc_fn (Jsonrpc.call_of_string (Bytes.unsafe_to_string x)) 108 | >>= fun response -> Jsonrpc.string_of_response response |> return 109 | in 110 | serve_requests process sockpath 111 | -------------------------------------------------------------------------------- /example/example3_client.ml: -------------------------------------------------------------------------------- 1 | open Example3_idl 2 | module M = Idl.IdM 3 | module MyIdl = Idl.Make (M) 4 | module PClient = Datapath (MyIdl.GenClient ()) 5 | module PCmds = Datapath (Cmdlinergen.Gen ()) 6 | module DClient = Data (MyIdl.GenClient ()) 7 | module DCmds = Data (Cmdlinergen.Gen ()) 8 | module CD = Datapath (Codegen.Gen ()) 9 | module DD = Data (Codegen.Gen ()) 10 | 11 | let generate_md () = 12 | let interfaces = 13 | Codegen.Interfaces.create 14 | ~name:"SMAPIv3" 15 | ~title:"Storage APIs version 3" 16 | ~description: 17 | [ "This set of interfaces is the third example of how to use the" 18 | ; "ocaml-rpc library as an IDL to describe RPCs. This example is inspired" 19 | ; "by the xapi-storage repository under the xapi-project organisation on" 20 | ; "github." 21 | ] 22 | ~interfaces:[ CD.implementation (); DD.implementation () ] 23 | in 24 | let write fname str = 25 | let oc = open_out fname in 26 | Printf.fprintf oc "%s" str; 27 | close_out oc 28 | in 29 | Markdowngen.to_string interfaces |> write "smapi.md"; 30 | () 31 | 32 | 33 | (*let generate_py () = 34 | let interfaces = Codegen.Interfaces.empty "SMAPIv3" "Storage APIs version 3" 35 | "This set of interfaces is the third example of how to use the ocaml-rpc 36 | library as an IDL to describe RPCs. This example is inspired by the 37 | xapi-storage repository under the xapi-project organisation on github." 38 | in 39 | let interfaces = 40 | interfaces 41 | |> Codegen.Interfaces.add_interface (C.get_interface ()) 42 | |> Codegen.Interfaces.add_interface (D.get_interface ()) 43 | in 44 | let write fname str = 45 | let oc = open_out fname in 46 | Printf.fprintf oc "%s" str; 47 | close_out oc 48 | in 49 | 50 | (* Pythongen.to_string interfaces |> write "smapi.py";*) 51 | () 52 | *) 53 | 54 | let generate_md_cmd = 55 | let doc = "Generate Markdown for the interfaces" in 56 | Cmdliner.(Cmd.v (Cmd.info "markdown" ~doc) Term.(const generate_md $ const ())) 57 | 58 | (*let generate_md_cmd = 59 | let doc = "Generate Python for the interfaces" in 60 | Cmdliner.Term.(const generate_py $ const ()), 61 | Cmdliner.Term.info "python" ~doc 62 | *) 63 | (* Use a binary 16-byte length to frame RPC messages *) 64 | let binary_rpc path (call : Rpc.call) : Rpc.response = 65 | let sockaddr = Unix.ADDR_UNIX path in 66 | let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in 67 | Unix.connect s sockaddr; 68 | let ic = Unix.in_channel_of_descr s in 69 | let oc = Unix.out_channel_of_descr s in 70 | let msg_buf = Jsonrpc.string_of_call call in 71 | let len = Printf.sprintf "%016d" (String.length msg_buf) in 72 | output_string oc len; 73 | output_string oc msg_buf; 74 | flush oc; 75 | let len_buf = Bytes.make 16 '\000' in 76 | really_input ic len_buf 0 16; 77 | let len = int_of_string (Bytes.unsafe_to_string len_buf) in 78 | let msg_buf = Bytes.make len '\000' in 79 | really_input ic msg_buf 0 len; 80 | let (response : Rpc.response) = 81 | Jsonrpc.response_of_string (Bytes.unsafe_to_string msg_buf) 82 | in 83 | response 84 | 85 | 86 | (*let server_cmd = 87 | let doc = "Start the server" in 88 | Cmdliner.Term.(const Example2_server.start_server $ const ()), 89 | Cmdliner.Term.info "server" ~doc*) 90 | 91 | let cli () = 92 | let rpc = binary_rpc "path" in 93 | let default = Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) in 94 | let info = 95 | let doc = "a cli for an API" in 96 | Cmdliner.Cmd.info "cli" ~version:"1.6.1" ~doc 97 | in 98 | let cmds = generate_md_cmd 99 | :: List.map 100 | (fun t -> 101 | let term, info = t rpc in 102 | Cmdliner.(Cmd.v info (Term.(term $ const ())))) 103 | (PCmds.implementation () @ DCmds.implementation ()) 104 | in 105 | let cmd = Cmdliner.Cmd.group ~default info cmds in 106 | exit (Cmdliner.Cmd.eval cmd) 107 | 108 | 109 | let _ = cli () 110 | -------------------------------------------------------------------------------- /example/example3_idl.ml: -------------------------------------------------------------------------------- 1 | open Idl 2 | open Rpc 3 | 4 | (* Common parameters *) 5 | let dbg = 6 | Param.mk ~name:"dbg" ~description:[ "Debug context from the caller" ] Types.string 7 | 8 | 9 | let unit = Param.mk Types.unit 10 | 11 | let task_id = 12 | Param.mk 13 | ~name:"task_id" 14 | ~description: 15 | [ "Opaque string representing the task associated with the"; "operation." ] 16 | Types.string 17 | 18 | 19 | (** A URI representing the means for accessing the volume data. The 20 | interpretation of the URI is specific to the implementation. Xapi will 21 | choose which implementation to use based on the URI scheme. *) 22 | type uri = string [@@deriving rpcty] 23 | 24 | (** A list of blocks for copying *) 25 | type blocklist = 26 | { blocksize : int [@version 1, 1, 0] (** Size of the individual blocks *) 27 | ; ranges : (int64 * int64) list 28 | (** list of block ranges, where a range is 29 | a (start,length) pair,measured in units 30 | of [blocksize] *) 31 | } 32 | [@@deriving rpcty] 33 | 34 | type error = 35 | | Unimplemented of string 36 | | UnexpectedError of string 37 | [@@deriving rpcty] 38 | 39 | module E = Idl.Error.Make (struct 40 | type t = error 41 | 42 | let t = error 43 | let internal_error_of e = Some (UnexpectedError (Printexc.to_string e)) 44 | end) 45 | 46 | let error = E.error 47 | 48 | (** A string representing a Xen domain on the local host. The string is 49 | guaranteed to be unique per-domain but it is not guaranteed to take any 50 | particular form. It may (for example) be a Xen domain id, a Xen VM uuid 51 | or a Xenstore path or anything else chosen by the toolstack. 52 | Implementations should not assume the string has any meaning. *) 53 | type domain = string [@@deriving rpcty] 54 | 55 | (** The choice of blkback to use. *) 56 | type implementation = 57 | | Blkback of string (** Use kernel blkback with the given 'params' key *) 58 | | Qdisk of string (** Use userspace qemu qdisk with the given 'params' key *) 59 | | Tapdisk3 of string (** Use userspace tapdisk3 with the given 'params' key *) 60 | [@@deriving rpcty] 61 | 62 | (** A description of which Xen block backend to use. The toolstack needs this 63 | to setup the shared memory connection to blkfront in the VM. *) 64 | type backend = 65 | { domain_uuid : string (** UUID of the domain hosting the backend *) 66 | ; implementation : implementation (** choice of implementation technology *) 67 | } 68 | [@@deriving rpcty] 69 | 70 | (** True means the disk data is persistent and should be preserved when the 71 | datapath is closed i.e. when a VM is shutdown or rebooted. False means the 72 | data should be thrown away when the VM is shutdown or rebooted. *) 73 | type persistent = bool [@@deriving rpcty] 74 | 75 | (* Create some handy parameters for use in the function definitions below *) 76 | let uri_p = 77 | Param.mk 78 | ~description:[ "A URI which represents how to access the volume disk data." ] 79 | uri 80 | 81 | 82 | let persistent = Param.mk persistent 83 | 84 | let domain = 85 | Param.mk ~description:[ "An opaque string which represents the Xen domain." ] domain 86 | 87 | 88 | let backend = Param.mk backend 89 | 90 | open Idl 91 | 92 | module Datapath (R : RPC) = struct 93 | open R 94 | 95 | let implementation = 96 | R.implement 97 | Idl.Interface. 98 | { name = "Datapath" 99 | ; namespace = None 100 | ; description = 101 | [ "Xapi will call the functions here on VM start / shutdown / suspend" 102 | ; "/ resume / migrate. Every function is idempotent. Every function" 103 | ; "takes a domain parameter which allows the implementation to track" 104 | ; "how many domains are currently using the volume." 105 | ] 106 | ; version = 1, 0, 0 107 | } 108 | 109 | 110 | let open_ = 111 | declare 112 | "open" 113 | [ "[open uri persistent] is called before a disk is attached to a VM." 114 | ; "If persistent is true then care should be taken to persist all writes" 115 | ; "to the disk. If persistent is false then the implementation should" 116 | ; "configure a temporary location for writes so they can be thrown away" 117 | ; "on [close]." 118 | ] 119 | (uri_p @-> persistent @-> returning unit error) 120 | 121 | 122 | let attach = 123 | declare 124 | "attach" 125 | [ "[attach uri domain] prepares a connection between the storage named by" 126 | ; "[uri] and the Xen domain with id [domain]. The return value is the" 127 | ; "information needed by the Xen toolstack to setup the shared-memory" 128 | ; "blkfront protocol. Note that the same volume may be simultaneously" 129 | ; "attached to multiple hosts for example over a migrate. If an" 130 | ; "implementation needs to perform an explicit handover, then it should" 131 | ; "implement [activate] and [deactivate]. This function is idempotent." 132 | ] 133 | (uri_p @-> domain @-> returning backend error) 134 | 135 | 136 | let activate = 137 | declare 138 | "activate" 139 | [ "[activate uri domain] is called just before a VM needs to read or write" 140 | ; "its disk. This is an opportunity for an implementation which needs to " 141 | ; "perform an explicit volume handover to do it. This function is called" 142 | ; "in the migration downtime window so delays here will be noticeable to" 143 | ; "users and should be minimised. This function is idempotent." 144 | ] 145 | (uri_p @-> domain @-> returning unit error) 146 | 147 | 148 | let deactivate = 149 | declare 150 | "deactivate" 151 | [ "[deactivate uri domain] is called as soon as a VM has finished reading" 152 | ; "or writing its disk. This is an opportunity for an implementation which" 153 | ; "needs to perform an explicit volume handover to do it. This function is" 154 | ; "called in the migration downtime window so delays here will be" 155 | ; "noticeable to users and should be minimised. This function is" 156 | ; "idempotent." 157 | ] 158 | (uri_p @-> domain @-> returning unit error) 159 | 160 | 161 | let detach = 162 | declare 163 | "detach" 164 | [ "[detach uri domain] is called sometime after a VM has finished reading" 165 | ; "or writing its disk. This is an opportunity to clean up any resources" 166 | ; "associated with the disk. This function is called outside the migration" 167 | ; "downtime window so can be slow without affecting users. This function" 168 | ; "is idempotent. This function should never fail. If an implementation is" 169 | ; "unable to perform some cleanup right away then it should queue the" 170 | ; "action internally. Any error result represents a bug in the" 171 | ; "implementation." 172 | ] 173 | (uri_p @-> domain @-> returning unit error) 174 | 175 | 176 | let close = 177 | declare 178 | "close" 179 | [ "[close uri] is called after a disk is detached and a VM shutdown. This" 180 | ; "is an opportunity to throw away writes if the disk is not persistent." 181 | ] 182 | (uri_p @-> returning unit error) 183 | end 184 | 185 | module Data (R : RPC) = struct 186 | open R 187 | 188 | let implementation = 189 | implement 190 | Idl.Interface. 191 | { name = "Data" 192 | ; namespace = Some "Data" 193 | ; description = 194 | [ "This interface is used for long-running data operations such as" 195 | ; "copying the contents of volumes or mirroring volumes to remote" 196 | ; "destinations" 197 | ] 198 | ; version = 1, 0, 0 199 | } 200 | 201 | 202 | type operation = 203 | | Copy of uri * uri 204 | [@doc 205 | [ "Copy (src,dst) represents an on-going copy operation from" 206 | ; "the [src] URI to the [dst] URI" 207 | ]] 208 | | Mirror of uri * uri 209 | [@doc 210 | [ "Mirror (src,dst) represents an on-going mirror operation" 211 | ; "from the [src] URI to the [dst] URI" 212 | ]] 213 | [@@deriving rpcty] 214 | [@@doc [ "The primary key for referring to a long-running operation" ]] 215 | 216 | type operations = operation list [@@deriving rpcty] [@@doc [ "A list of operations" ]] 217 | 218 | type status = 219 | { failed : bool 220 | [@doc 221 | [ "[failed] will be set to true if the operation has failed for some" 222 | ; "reason" 223 | ]] 224 | ; progress : float option 225 | [@doc 226 | [ "[progress] will be returned for a copy operation, and ranges" 227 | ; "between 0 and 1" 228 | ]] 229 | } 230 | [@@deriving rpcty] [@@doc [ "Status information for on-going tasks" ]] 231 | 232 | let remote = 233 | Param.mk 234 | ~name:"remote" 235 | ~description: 236 | [ "A URI which represents how to access a remote volume"; "disk data." ] 237 | uri 238 | 239 | 240 | let operation = Param.mk operation 241 | let blocklist = Param.mk blocklist 242 | 243 | let copy = 244 | declare 245 | "copy" 246 | [ "[copy uri domain remote blocks] copies [blocks] from the local disk to" 247 | ; "a remote URI. This may be called as part of a Volume Mirroring" 248 | ; "operation, and hence may need to cooperate with whatever process is" 249 | ; "currently mirroring writes to ensure data integrity is maintained" 250 | ] 251 | (uri_p @-> domain @-> remote @-> blocklist @-> returning operation error) 252 | 253 | 254 | let mirror = 255 | declare 256 | "mirror" 257 | [ "[mirror uri domain remote] starts mirroring new writes to the volume to" 258 | ; "a remote URI (usually NBD). This is called as part of a volume" 259 | ; "mirroring process" 260 | ] 261 | (uri_p @-> domain @-> remote @-> returning operation error) 262 | 263 | 264 | let status = Param.mk status 265 | 266 | let stat = 267 | declare 268 | "stat" 269 | [ "[stat operation] returns the current status of [operation]. For a copy" 270 | ; "operation, this will contain progress information." 271 | ] 272 | (operation @-> returning status error) 273 | 274 | 275 | let cancel = 276 | declare 277 | "cancel" 278 | [ "[cancel operation] cancels a long-running operation. Note that the call" 279 | ; "may return before the operation has finished." 280 | ] 281 | (operation @-> returning unit error) 282 | 283 | 284 | let destroy = 285 | declare 286 | "destroy" 287 | [ "[destroy operation] destroys the information about a long-running" 288 | ; "operation. This should fail when run against an operation that is still" 289 | ; "in progress." 290 | ] 291 | (operation @-> returning unit error) 292 | 293 | 294 | let operations = Param.mk operations 295 | 296 | let ls = 297 | declare 298 | "ls" 299 | [ "[ls] returns a list of all current operations" ] 300 | (unit @-> returning operations error) 301 | end 302 | -------------------------------------------------------------------------------- /example/template.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | Your Project 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 29 | 30 | 31 | 32 |
33 |
34 |
35 |
36 |
37 |
38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /ppx/common.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ast_builder.Default 3 | 4 | let list_assoc_find_exn t ~equal key = 5 | match List.find_opt (fun (key', _) -> equal key key') t with 6 | | None -> raise Not_found 7 | | Some x -> snd x 8 | 9 | 10 | let list_assoc_mem t ~equal key = 11 | match List.find_opt (fun (key', _) -> equal key key') t with 12 | | None -> false 13 | | Some _ -> true 14 | 15 | 16 | let string_concat ?(sep = "") l = 17 | match l with 18 | | [] -> "" 19 | (* The stdlib does not specialize this case because it could break existing projects. *) 20 | | [ x ] -> x 21 | | l -> String.concat sep l 22 | 23 | 24 | let string_split_on_chars str ~on = 25 | let rec char_list_mem l (c : char) = 26 | match l with 27 | | [] -> false 28 | | hd :: tl -> Char.equal hd c || char_list_mem tl c 29 | in 30 | let split_gen str ~on = 31 | let is_delim c = char_list_mem on c in 32 | let len = String.length str in 33 | let rec loop acc last_pos pos = 34 | if pos = -1 35 | then String.sub str 0 last_pos :: acc 36 | else if is_delim str.[pos] 37 | then ( 38 | let pos1 = pos + 1 in 39 | let sub_str = String.sub str pos1 (last_pos - pos1) in 40 | loop (sub_str :: acc) pos (pos - 1)) 41 | else loop acc last_pos (pos - 1) 42 | in 43 | loop [] len (len - 1) 44 | in 45 | split_gen str ~on 46 | 47 | 48 | let is_whitespace = function 49 | | '\t' | '\n' | '\011' (* vertical tab *) | '\012' (* form feed *) | '\r' | ' ' -> true 50 | | _ -> false 51 | 52 | 53 | let string_strip ?(drop = is_whitespace) t = 54 | let lfindi ?(pos = 0) t ~f = 55 | let n = String.length t in 56 | let rec loop i = if i = n then None else if f i t.[i] then Some i else loop (i + 1) in 57 | loop pos 58 | in 59 | let rfindi ?pos t ~f = 60 | let rec loop i = if i < 0 then None else if f i t.[i] then Some i else loop (i - 1) in 61 | let pos = 62 | match pos with 63 | | Some pos -> pos 64 | | None -> String.length t - 1 65 | in 66 | loop pos 67 | in 68 | let last_non_drop ~drop t = rfindi t ~f:(fun _ c -> not (drop c)) in 69 | let first_non_drop ~drop t = lfindi t ~f:(fun _ c -> not (drop c)) in 70 | let length = String.length t in 71 | if length = 0 || not (drop t.[0] || drop t.[length - 1]) 72 | then t 73 | else ( 74 | match first_non_drop t ~drop with 75 | | None -> "" 76 | | Some first -> 77 | (match last_non_drop t ~drop with 78 | | None -> assert false 79 | | Some last -> String.sub t first (last - first + 1))) 80 | 81 | 82 | let list_partition_tf t ~f = 83 | let partition_map t ~f = 84 | let rec loop t fst snd = 85 | match t with 86 | | [] -> List.rev fst, List.rev snd 87 | | x :: t -> 88 | (match f x with 89 | | Ok y -> loop t (y :: fst) snd 90 | | Error y -> loop t fst (y :: snd)) 91 | in 92 | loop t [] [] 93 | in 94 | let f x = if f x then Ok x else Error x in 95 | partition_map t ~f 96 | 97 | 98 | let core_types loc = 99 | ListLabels.map 100 | ~f:(fun (s, y) -> s, y) 101 | [ "unit", [%expr Rpc.Types.Unit] 102 | ; "int", [%expr Rpc.Types.(Basic Int)] 103 | ; "int32", [%expr Rpc.Types.(Basic Int32)] 104 | ; "int64", [%expr Rpc.Types.(Basic Int64)] 105 | ; "string", [%expr Rpc.Types.(Basic String)] 106 | ; "float", [%expr Rpc.Types.(Basic Float)] 107 | ; "bool", [%expr Rpc.Types.(Basic Bool)] 108 | ] 109 | 110 | 111 | (** Many of the following functions are lifted from ppx_deriving. It's quite likely that 112 | there are good alternatives to these somewhere in ppxlib, but I've not yet found them. 113 | 114 | They are used to deal with parameterised types. When declaring a function derived from 115 | a parameterised type, the function will be extended to take an argument for each 116 | type parameter. The important functions below are `poly_fun_of_type_decl` and 117 | `poly_apply_of_type_decl` - for declaring and using the derived functions respectively. 118 | *) 119 | 120 | let fold_right_type_params fn params accum = 121 | ListLabels.fold_right 122 | ~f:(fun (param, _) accum -> 123 | match param with 124 | | { ptyp_desc = Ptyp_any; _ } -> accum 125 | | { ptyp_desc = Ptyp_var name; _ } -> fn name accum 126 | | _ -> assert false) 127 | params 128 | ~init:accum 129 | 130 | 131 | (** [fold_right_type_decl fn accum type_] performs a right fold over all type variable 132 | (i.e. not wildcard) parameters in [type_]. *) 133 | let fold_right_type_decl fn { ptype_params; _ } accum = 134 | fold_right_type_params fn ptype_params accum 135 | 136 | 137 | (** [poly_fun_of_type_decl type_ expr] wraps [expr] into [fun poly_N -> ...] for every 138 | type parameter ['N] present in [type_]. For example, if [type_] refers to 139 | [type ('a, 'b) map], [expr] will be wrapped into [fun poly_a poly_b -> [%e expr]]. *) 140 | let poly_fun_of_type_decl ~loc type_decl expr = 141 | fold_right_type_decl 142 | (fun name expr -> 143 | pexp_fun ~loc Nolabel None (ppat_var ~loc { txt = "poly_" ^ name; loc }) expr) 144 | type_decl 145 | expr 146 | 147 | 148 | let fold_left_type_params fn accum params = 149 | ListLabels.fold_left 150 | ~f:(fun accum (param, _) -> 151 | match param with 152 | | { ptyp_desc = Ptyp_any; _ } -> accum 153 | | { ptyp_desc = Ptyp_var name; _ } -> fn accum name 154 | | _ -> assert false) 155 | ~init:accum 156 | params 157 | 158 | 159 | (** [fold_left_type_decl fn accum type_] performs a left fold over all type variable 160 | (i.e. not wildcard) parameters in [type_]. *) 161 | let fold_left_type_decl fn accum { ptype_params; _ } = 162 | fold_left_type_params fn accum ptype_params 163 | 164 | 165 | (** [poly_apply_of_type_decl type_ expr] wraps [expr] into [expr poly_N] for every 166 | type parameter ['N] present in [type_]. For example, if [type_] refers to 167 | [type ('a, 'b) map], [expr] will be wrapped into [[%e expr] poly_a poly_b]. 168 | [_] parameters are ignored. *) 169 | let poly_apply_of_type_decl ~loc type_decl expr = 170 | fold_left_type_decl 171 | (fun expr name -> Ast_helper.Exp.apply expr [ Nolabel, evar ~loc ("poly_" ^ name) ]) 172 | expr 173 | type_decl 174 | 175 | 176 | (** [expr_of_option ~loc o] turns an optional expression into an expression 177 | of an optional value. In several places there are optional attributes, 178 | e.g. [@@version foo], which end up as values of type `expression option`. 179 | These are often turned into optional values in the generated code. *) 180 | let expr_of_option ~loc o = 181 | match o with 182 | | None -> [%expr None] 183 | | Some d -> [%expr Some [%e d]] 184 | 185 | 186 | (** Typed attribute getters *) 187 | module Attrs = struct 188 | let default context = 189 | Attribute.declare 190 | "rpc.default" 191 | context 192 | Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) 193 | (fun x -> x) 194 | 195 | 196 | let label_default = default Attribute.Context.label_declaration 197 | let td_default = default Attribute.Context.type_declaration 198 | let ct_default = default Attribute.Context.core_type 199 | let rtag_default = default Attribute.Context.rtag 200 | 201 | let doc context = 202 | Attribute.declare 203 | "rpc.doc" 204 | context 205 | Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) 206 | (fun x -> x) 207 | 208 | 209 | let label_doc = doc Attribute.Context.label_declaration 210 | let constr_doc = doc Attribute.Context.constructor_declaration 211 | let td_doc = doc Attribute.Context.type_declaration 212 | 213 | let version context = 214 | Attribute.declare 215 | "rpc.version" 216 | context 217 | Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) 218 | (fun x -> x) 219 | 220 | 221 | let label_version = version Attribute.Context.label_declaration 222 | let td_version = version Attribute.Context.type_declaration 223 | let constr_version = version Attribute.Context.constructor_declaration 224 | 225 | let label_typ = 226 | Attribute.declare 227 | "rpc.typ" 228 | Attribute.Context.label_declaration 229 | Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) 230 | (fun x -> x) 231 | 232 | 233 | let name context = 234 | Attribute.declare 235 | "rpc.name" 236 | context 237 | Ast_pattern.(pstr (pstr_eval (pexp_constant (pconst_string __ __ none)) nil ^:: nil)) 238 | (fun x _loc -> x) 239 | 240 | 241 | let constr_name = name Attribute.Context.constructor_declaration 242 | let rt_name = name Attribute.Context.rtag 243 | 244 | let key = 245 | Attribute.declare 246 | "rpc.key" 247 | Attribute.Context.label_declaration 248 | Ast_pattern.(pstr (pstr_eval (pexp_constant (pconst_string __ __ none)) nil ^:: nil)) 249 | (fun x _loc -> x) 250 | 251 | 252 | let is_dict = 253 | Attribute.declare "rpc.dict" Attribute.Context.core_type Ast_pattern.(pstr nil) () 254 | end 255 | 256 | (* The following functions are for extracting `ocaml.doc` attributes from the AST. These are 257 | captured and used for 'doc' fields of the generated values representing the types. Ppxlib 258 | seems to object to using these attributes as they are 'already in use', so we don't get to 259 | use the nice `Attributes` module and have to roll our own. *) 260 | let attr loc name attrs = 261 | let pat = 262 | Ast_pattern.(pstr (pstr_eval (pexp_constant (pconst_string __ __ none)) __ ^:: nil)) 263 | in 264 | List.find_opt (fun { attr_name = { txt; _ }; _ } -> String.equal txt name) attrs 265 | |> Option.map (fun { attr_payload; _ } -> attr_payload) 266 | |> fun o -> 267 | Option.bind o (fun str -> 268 | Ast_pattern.parse pat loc str ~on_error:(fun _ -> None) (fun str _loc _ -> Some str)) 269 | 270 | 271 | let split = string_split_on_chars ~on:[ '\n' ] 272 | 273 | let convert_doc x = 274 | split x 275 | |> ListLabels.map 276 | ~f: 277 | (string_strip ~drop:(function 278 | | '\n' | ' ' -> true 279 | | _ -> false)) 280 | 281 | 282 | (** [get_doc loc rpcdoc attrs] extracts documentation from the type declarations. rpcdoc is 283 | the result of looking for \@doc tags. If this is found, we use that. If not, we look for 284 | ocamldoc docstrings and return them instead. In both cases, the result is an expression of 285 | type list *) 286 | let get_doc ~loc rpcdoc (attrs : attributes) = 287 | let ocamldoc = attr loc "ocaml.doc" attrs in 288 | match rpcdoc, ocamldoc with 289 | | Some e, _ -> e 290 | | _, Some s -> elist ~loc (convert_doc s |> ListLabels.map ~f:(estring ~loc)) 291 | | _, _ -> elist ~loc [] 292 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_deriving_rpc) 3 | (public_name ppx_deriving_rpc) 4 | (synopsis "[@@deriving rpc]") 5 | (kind ppx_deriver) 6 | (ppx_runtime_libraries rpclib) 7 | (libraries ppxlib) 8 | (preprocess 9 | (pps ppxlib.metaquot ppxlib.runner)) 10 | (wrapped false)) 11 | -------------------------------------------------------------------------------- /ppx_deriving_rpc.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Ppx deriver for ocaml-rpc, a library to deal with RPCs in OCaml" 3 | maintainer: "Marcello Seri" 4 | authors: ["Thomas Gazagnaire" "Jon Ludlam"] 5 | tags: ["org:mirage" "org:xapi-project"] 6 | homepage: "https://github.com/mirage/ocaml-rpc" 7 | doc: "https://mirage.github.io/ocaml-rpc/ppx_deriving_rpc" 8 | bug-reports: "https://github.com/mirage/ocaml-rpc/issues" 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" {>= "4.08"} 12 | "dune" {>= "2.0.0"} 13 | "rpclib" {= version} 14 | "rresult" {>= "0.3.0"} 15 | "ppxlib" {>= "0.18.0"} 16 | "lwt" {with-test & >= "3.0.0"} 17 | "alcotest" {with-test} 18 | ] 19 | build: [ 20 | ["dune" "build" "-p" name "-j" jobs] 21 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 22 | ] 23 | dev-repo: "git://github.com/mirage/ocaml-rpc" 24 | description: """ 25 | `ocaml-rpc` is a library that provides remote procedure calls (RPC) 26 | using XML or JSON as transport encodings, and multiple generators 27 | for documentations, clients, servers, javascript bindings, python 28 | bindings, ... 29 | 30 | The transport mechanism itself is outside the scope of this library 31 | as all conversions are from and to strings. 32 | """ 33 | x-maintenance-intent: [ "(latest)" ] -------------------------------------------------------------------------------- /rpclib-async.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A library to deal with RPCs in OCaml - Async interface" 3 | maintainer: "Marcello Seri" 4 | authors: ["Thomas Gazagnaire" "Jon Ludlam"] 5 | tags: ["org:mirage" "org:xapi-project"] 6 | homepage: "https://github.com/mirage/ocaml-rpc" 7 | doc: "https://mirage.github.io/ocaml-rpc/rpclib-async" 8 | bug-reports: "https://github.com/mirage/ocaml-rpc/issues" 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" 12 | "alcotest" {with-test} 13 | "dune" {>= "2.0.0"} 14 | "rpclib" {=version} 15 | "async" {>= "v0.9.0"} 16 | "ppx_deriving_rpc" {with-test & =version} 17 | ] 18 | build: [ 19 | ["dune" "build" "-p" name "-j" jobs] 20 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 21 | ] 22 | dev-repo: "git://github.com/mirage/ocaml-rpc" 23 | description: """ 24 | `ocaml-rpc` is a library that provides remote procedure calls (RPC) 25 | using XML or JSON as transport encodings, and multiple generators 26 | for documentations, clients, servers, javascript bindings, python 27 | bindings, ... 28 | 29 | The transport mechanism itself is outside the scope of this library 30 | as all conversions are from and to strings. 31 | """ 32 | x-maintenance-intent: [ "(latest)" ] -------------------------------------------------------------------------------- /rpclib-html.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: 3 | "A library to deal with RPCs in OCaml - html documentation generator" 4 | maintainer: "Marcello Seri" 5 | authors: ["Thomas Gazagnaire" "Jon Ludlam"] 6 | tags: ["org:mirage" "org:xapi-project"] 7 | homepage: "https://github.com/mirage/ocaml-rpc" 8 | doc: "https://mirage.github.io/ocaml-rpc/rpclib-html" 9 | bug-reports: "https://github.com/mirage/ocaml-rpc/issues" 10 | license: "ISC" 11 | depends: [ 12 | "ocaml" 13 | "dune" {>= "2.0.0"} 14 | "rpclib" {=version} 15 | "cow" {>= "2.0.0"} 16 | ] 17 | build: ["dune" "build" "-p" name "-j" jobs] 18 | dev-repo: "git://github.com/mirage/ocaml-rpc" 19 | description: """ 20 | `ocaml-rpc` is a library that provides remote procedure calls (RPC) 21 | using XML or JSON as transport encodings, and multiple generators 22 | for documentations, clients, servers, javascript bindings, python 23 | bindings, ... 24 | 25 | The transport mechanism itself is outside the scope of this library 26 | as all conversions are from and to strings. 27 | """ 28 | x-maintenance-intent: [ "(latest)" ] -------------------------------------------------------------------------------- /rpclib-js.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A library to deal with RPCs in OCaml - Bindings for js_of_ocaml" 3 | maintainer: "Marcello Seri" 4 | authors: ["Thomas Gazagnaire" "Jon Ludlam"] 5 | tags: ["org:mirage" "org:xapi-project"] 6 | homepage: "https://github.com/mirage/ocaml-rpc" 7 | doc: "https://mirage.github.io/ocaml-rpc/rpclib-js" 8 | bug-reports: "https://github.com/mirage/ocaml-rpc/issues" 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" 12 | "dune" {>= "2.0.0"} 13 | "rpclib" {=version} 14 | "js_of_ocaml" {>= "3.5.0"} 15 | "js_of_ocaml-ppx" {>= "3.5.0"} 16 | "lwt" 17 | ] 18 | build: ["dune" "build" "-p" name "-j" jobs] 19 | dev-repo: "git://github.com/mirage/ocaml-rpc" 20 | description: """ 21 | `ocaml-rpc` is a library that provides remote procedure calls (RPC) 22 | using XML or JSON as transport encodings, and multiple generators 23 | for documentations, clients, servers, javascript bindings, python 24 | bindings, ... 25 | 26 | The transport mechanism itself is outside the scope of this library 27 | as all conversions are from and to strings. 28 | """ 29 | x-maintenance-intent: [ "(latest)" ] -------------------------------------------------------------------------------- /rpclib-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A library to deal with RPCs in OCaml - Lwt interface" 3 | maintainer: "Marcello Seri" 4 | authors: ["Thomas Gazagnaire" "Jon Ludlam"] 5 | tags: ["org:mirage" "org:xapi-project"] 6 | homepage: "https://github.com/mirage/ocaml-rpc" 7 | doc: "https://mirage.github.io/ocaml-rpc/rpclib-lwt" 8 | bug-reports: "https://github.com/mirage/ocaml-rpc/issues" 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" 12 | "alcotest" {with-test} 13 | "dune" {>= "2.0.0"} 14 | "rpclib" {=version} 15 | "lwt" {>= "3.0.0"} 16 | "alcotest-lwt" {with-test} 17 | "ppx_deriving_rpc" {with-test & =version} 18 | ] 19 | build: [ 20 | ["dune" "build" "-p" name "-j" jobs] 21 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 22 | ] 23 | dev-repo: "git://github.com/mirage/ocaml-rpc" 24 | description: """ 25 | `ocaml-rpc` is a library that provides remote procedure calls (RPC) 26 | using XML or JSON as transport encodings, and multiple generators 27 | for documentations, clients, servers, javascript bindings, python 28 | bindings, ... 29 | 30 | The transport mechanism itself is outside the scope of this library 31 | as all conversions are from and to strings. 32 | """ 33 | x-maintenance-intent: [ "(latest)" ] -------------------------------------------------------------------------------- /rpclib.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A library to deal with RPCs in OCaml" 3 | maintainer: "Marcello Seri" 4 | authors: ["Thomas Gazagnaire" "Jon Ludlam"] 5 | tags: ["org:mirage" "org:xapi-project"] 6 | homepage: "https://github.com/mirage/ocaml-rpc" 7 | doc: "https://mirage.github.io/ocaml-rpc/rpclib" 8 | bug-reports: "https://github.com/mirage/ocaml-rpc/issues" 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" {>= "4.08.0"} 12 | "alcotest" {with-test} 13 | "dune" {>= "2.0.0"} 14 | "base64" {>= "3.4.0"} 15 | "cmdliner" {>= "1.1.0"} 16 | "rresult" {>= "0.3.0"} 17 | "result" {>= "1.5"} 18 | "xmlm" 19 | "yojson" {>= "1.7.0"} 20 | ] 21 | conflicts: [ 22 | "result" {< "1.5"} 23 | ] 24 | build: [ 25 | ["dune" "build" "-p" name "-j" jobs] 26 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 27 | ] 28 | dev-repo: "git://github.com/mirage/ocaml-rpc" 29 | description: """ 30 | `ocaml-rpc` is a library that provides remote procedure calls (RPC) 31 | using XML or JSON as transport encodings, and multiple generators 32 | for documentations, clients, servers, javascript bindings, python 33 | bindings, ... 34 | 35 | The transport mechanism itself is outside the scope of this library 36 | as all conversions are from and to strings. 37 | """ 38 | x-maintenance-intent: [ "(latest)" ] -------------------------------------------------------------------------------- /src/async/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name rpclib_async) 3 | (public_name rpclib-async) 4 | (modules rpc_async) 5 | (libraries async rpclib.core threads) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /src/async/rpc_async.ml: -------------------------------------------------------------------------------- 1 | module AD = struct 2 | include Async.Deferred 3 | 4 | let bind x f = Async.Deferred.bind ~f x 5 | let fail = raise 6 | end 7 | 8 | module AsyncIdl = Idl.Make (AD) 9 | include AsyncIdl 10 | -------------------------------------------------------------------------------- /src/async/rpc_async.mli: -------------------------------------------------------------------------------- 1 | type client_implementation 2 | type server_implementation 3 | 4 | module T : sig 5 | type 'a box 6 | type ('a, 'b) resultb = ('a, 'b) Result.t box 7 | type rpcfn = Rpc.call -> Rpc.response Async.Deferred.t 8 | 9 | val lift : ('a -> 'b Async.Deferred.t) -> 'a -> 'b box 10 | val bind : 'a box -> ('a -> 'b Async.Deferred.t) -> 'b box 11 | val return : 'a -> 'a box 12 | val get : 'a box -> 'a Async.Deferred.t 13 | val ( !@ ) : 'a box -> 'a Async.Deferred.t 14 | val put : 'a Async.Deferred.t -> 'a box 15 | val ( ~@ ) : 'a Async.Deferred.t -> 'a box 16 | end 17 | 18 | module ErrM : sig 19 | val return : 'a -> ('a, 'b) T.resultb 20 | val return_err : 'b -> ('a, 'b) T.resultb 21 | 22 | val checked_bind 23 | : ('a, 'b) T.resultb 24 | -> ('a -> ('c, 'd) T.resultb) 25 | -> ('b -> ('c, 'd) T.resultb) 26 | -> ('c, 'd) T.resultb 27 | 28 | val bind : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 29 | val ( >>= ) : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 30 | end 31 | 32 | (** Client generator similar to {!Idl.GenClient} that uses [Async.Deferred]. *) 33 | module GenClient () : sig 34 | include 35 | Idl.RPC 36 | with type implementation = client_implementation 37 | and type 'a res = T.rpcfn -> 'a 38 | and type ('a, 'b) comp = ('a, 'b) T.resultb 39 | end 40 | 41 | (** Server generator similar to {!Idl.GenServer} that uses [Async.Deferred]. *) 42 | module GenServer () : sig 43 | include 44 | Idl.RPC 45 | with type implementation = server_implementation 46 | and type 'a res = 'a -> unit 47 | and type ('a, 'b) comp = ('a, 'b) T.resultb 48 | end 49 | 50 | val server : server_implementation -> T.rpcfn 51 | val combine : server_implementation list -> server_implementation 52 | -------------------------------------------------------------------------------- /src/html/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name htmlgen) 3 | (public_name rpclib-html) 4 | (modules htmlgen) 5 | (libraries cow rpclib.core) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /src/html/htmlgen.ml: -------------------------------------------------------------------------------- 1 | open Rpc.Types 2 | open Idl 3 | open Codegen 4 | open Cow.Html 5 | 6 | (* Printable string of type *) 7 | let rec html_of_t : type a. a typ -> string list = 8 | let of_basic : type b. b basic -> string = function 9 | | Int -> "int" 10 | | Int32 -> "int32" 11 | | Int64 -> "int64" 12 | | Bool -> "bool" 13 | | Float -> "float" 14 | | String -> "string" 15 | | Char -> "char" 16 | in 17 | let print txt = [ txt ] in 18 | function 19 | | Basic b -> print (of_basic b) 20 | | DateTime -> print (of_basic String) 21 | | Base64 -> print (of_basic String) 22 | | Struct _ -> print "struct { ... }" 23 | | Variant _ -> print "variant { ... }" 24 | | Array t -> html_of_t t @ print " list" 25 | | List t -> html_of_t t @ print " list" 26 | | Dict (key, v) -> 27 | print (Printf.sprintf "(%s * " (of_basic key)) @ html_of_t v @ print ") list" 28 | | Unit -> print "unit" 29 | | Option x -> html_of_t x @ print " option" 30 | | Tuple (a, b) -> html_of_t a @ print " * " @ html_of_t b 31 | | Tuple3 (a, b, c) -> 32 | html_of_t a @ print " * " @ html_of_t b @ print " * " @ html_of_t c 33 | | Tuple4 (a, b, c, d) -> 34 | html_of_t a 35 | @ print " * " 36 | @ html_of_t b 37 | @ print " * " 38 | @ html_of_t c 39 | @ print " * " 40 | @ html_of_t d 41 | | Abstract _ -> print "" 42 | 43 | 44 | (* Function inputs and outputs in a table *) 45 | let of_args args = 46 | let row_of_arg (is_in, Param.Boxed arg) = 47 | let name = arg.Param.name in 48 | let direction = if is_in then "in" else "out" in 49 | let ty = html_of_t arg.Param.typedef.ty |> List.map string in 50 | let description = arg.Param.description in 51 | tag 52 | "tr" 53 | (list 54 | [ tag 55 | "td" 56 | (tag 57 | "code" 58 | (string 59 | (match name with 60 | | Some s -> s 61 | | None -> "unnamed"))) 62 | ; tag "td" (string direction) 63 | ; tag "td" (tag "code" (list ty)) 64 | ; tag "td" (string (String.concat " " description)) 65 | ]) 66 | in 67 | tag 68 | "table" 69 | ~attrs:[ "width", "100%" ] 70 | (list 71 | [ tag 72 | "thead" 73 | (tag 74 | "tr" 75 | (list 76 | [ tag "th" (string "Name") 77 | ; tag "th" (string "Direction") 78 | ; tag "th" (string "Type") 79 | ; tag "th" (string "Description") 80 | ])) 81 | ; tag "tbody" (list (List.map row_of_arg args)) 82 | ]) 83 | 84 | 85 | let sidebar x = 86 | let of_typedef (BoxedDef t) = 87 | let target = Printf.sprintf "#a-%s" t.name in 88 | let name = t.name in 89 | tag "li" (a ~href:(Uri.of_string target) (string name)) 90 | in 91 | let of_method iname (BoxedFunction m) = 92 | let target = Printf.sprintf "#a-%s-%s" iname m.Method.name in 93 | let name = m.Method.name in 94 | tag "li" (a ~href:(Uri.of_string target) (string name)) 95 | in 96 | let of_interface i = 97 | let name = i.Interface.details.Idl.Interface.name in 98 | [ tag "li" ~cls:"docs-nav-title" (string name) ] 99 | @ List.map (of_method i.Interface.details.Idl.Interface.name) i.Interface.methods 100 | in 101 | div 102 | ~cls:"large-3 medium-3 columns" 103 | (tag 104 | "ul" 105 | ~cls:"menu vertical" 106 | (list 107 | ([ tag "li" ~cls:"docs-nav-title" (string "types") ] 108 | @ List.map of_typedef x.Interfaces.type_decls 109 | @ List.concat (List.map of_interface x.Interfaces.interfaces)))) 110 | 111 | 112 | let of_struct_fields : 'a boxed_field list -> Cow.Html.t = 113 | fun all -> 114 | let of_row (BoxedField f) = 115 | let ty = html_of_t f.field in 116 | tag 117 | "tr" 118 | (list 119 | [ tag "td" (tag "pre" (string f.fname)) 120 | ; tag "td" (tag "pre" (string (String.concat "" ty))) 121 | ; tag "td" (string (String.concat " " f.fdescription)) 122 | ]) 123 | in 124 | tag 125 | "table" 126 | ~attrs:[ "width", "100%" ] 127 | (list 128 | [ tag 129 | "thead" 130 | (tag 131 | "tr" 132 | (list 133 | [ tag "th" (string "Name") 134 | ; tag "th" (string "Type") 135 | ; tag "th" (string "Description") 136 | ])) 137 | ; tag "tbody" (list (List.map of_row all)) 138 | ]) 139 | 140 | 141 | (* TODO: Unify with the above! *) 142 | let of_variant_tags : 'a boxed_tag list -> Cow.Html.t = 143 | fun all -> 144 | let of_row (BoxedTag t) = 145 | let ty = html_of_t t.tcontents in 146 | tag 147 | "tr" 148 | (list 149 | [ tag "td" (tag "pre" (string t.tname)) 150 | ; tag "td" (tag "pre" (string (String.concat "" ty))) 151 | ; tag "td" (string (String.concat " " t.tdescription)) 152 | ]) 153 | in 154 | tag 155 | "table" 156 | ~attrs:[ "width", "100%" ] 157 | (list 158 | [ tag 159 | "thead" 160 | (tag 161 | "tr" 162 | (list 163 | [ tag "th" (string "Name") 164 | ; tag "th" (string "Type") 165 | ; tag "th" (string "Description") 166 | ])) 167 | ; tag "tbody" (list (List.map of_row all)) 168 | ]) 169 | 170 | 171 | let of_type_decl _ (BoxedDef t) = 172 | let anchor = Printf.sprintf "a-%s" t.name in 173 | let name = t.name in 174 | let defn = String.concat "" (html_of_t t.ty) in 175 | let description = t.description in 176 | let common = 177 | [ h4 ~id:anchor (string (Printf.sprintf "type %s = %s" name defn)) 178 | ; p (string (String.concat " " description)) 179 | ] 180 | in 181 | let rest = 182 | match t.ty with 183 | | Struct structure -> [ p (string "Members:"); of_struct_fields structure.fields ] 184 | | Variant variant -> [ p (string "Constructors:"); of_variant_tags variant.variants ] 185 | | _ -> [] 186 | in 187 | common @ rest 188 | 189 | 190 | let tabs_of _ i m = 191 | let mname = m.Method.name in 192 | let hash_defn = "#defn-" ^ mname in 193 | let hash_ocaml = "#ocaml-" ^ mname in 194 | let hash_python = "#python-" ^ mname in 195 | let id_tab = "tab-" ^ mname in 196 | let id_defn = "defn-" ^ mname in 197 | let id_ocaml = "ocaml-" ^ mname in 198 | let id_python = "python-" ^ mname in 199 | [ ul 200 | ~cls:"tabs" 201 | ~id:id_tab 202 | ~attrs:[ "data-tabs", "" ] 203 | [ li 204 | ~cls:"tabs-title is-active" 205 | (tag 206 | "a" 207 | ~attrs:[ "href", hash_defn; "aria-selected", "true" ] 208 | (string "Definition")) 209 | ; li ~cls:"tabs-title" (a ~href:(Uri.of_string hash_ocaml) (string "OCaml example")) 210 | ; li 211 | ~cls:"tabs-title" 212 | (a ~href:(Uri.of_string hash_python) (string "Python example")) 213 | ] 214 | ; div 215 | ~cls:"tabs-content" 216 | ~attrs:[ "data-tabs-content", id_tab ] 217 | (list 218 | [ div 219 | ~cls:"tabs-panel is-active" 220 | ~id:id_defn 221 | (of_args 222 | (List.map (fun p -> true, p) Method.(find_inputs m.ty) 223 | @ [ (false, Method.(find_output m.ty)) ])) 224 | ; div 225 | ~cls:"tabs-panel" 226 | ~id:id_ocaml 227 | (list [ h4 (string "Client:"); h4 (string "Server:") ]) 228 | ; div 229 | ~cls:"tabs-panel" 230 | ~id:id_python 231 | (list 232 | [ h4 (string "Client:") 233 | ; tag 234 | "pre" 235 | ~cls:"prettyprint lang-py" 236 | (string 237 | (Pythongen.example_stub_user i (BoxedFunction m) 238 | |> Pythongen.string_of_ts)) 239 | ; h4 (string "Server:") 240 | ; tag 241 | "pre" 242 | ~cls:"prettyprint lang-py" 243 | (string 244 | (Pythongen.example_skeleton_user i (BoxedFunction m) 245 | |> Pythongen.string_of_ts)) 246 | ]) 247 | ]) 248 | ] 249 | 250 | 251 | let of_method is i (Codegen.BoxedFunction m) = 252 | let anchor = 253 | Printf.sprintf "a-%s-%s" i.Interface.details.Idl.Interface.name m.Method.name 254 | in 255 | let name = m.Method.name in 256 | let description = m.Method.description in 257 | [ h3 ~id:anchor (string name); p (string (String.concat " " description)) ] 258 | @ tabs_of is i m 259 | 260 | 261 | let of_interface is i = 262 | let name = i.Interface.details.Idl.Interface.name in 263 | let anchor = "a-" ^ name in 264 | let description = i.Interface.details.Idl.Interface.description in 265 | [ h2 ~id:anchor (string name); p (string (String.concat " " description)) ] 266 | @ List.concat (List.map (of_method is i) i.Interface.methods) 267 | 268 | 269 | (* 270 | let of_exception ts = 271 | let row_of t = 272 | let ident = ident_of_type_decl t in 273 | let name = [ `Data (String.concat "/" ident.Ident.name) ] in 274 | let ty = [ `Data (Type.ocaml_of_t ident.Ident.original_ty) ] in 275 | let description = [ `Data ident.Ident.description ] in 276 | <:html< 277 | 278 | 
$name$
279 | 
$ty$
280 | $description$ 281 | 282 | >> in 283 | <:html< 284 |

exceptions

285 | 286 | 287 | 288 | 289 | 290 | 291 | 292 | 293 | 294 | $List.concat (List.map row_of ts)$ 295 | 296 |
NameTypeDescription
297 | >> 298 | *) 299 | 300 | let of_interfaces x = 301 | let name = x.Interfaces.name in 302 | let description = x.Interfaces.description in 303 | div 304 | ~cls:"row" 305 | (list 306 | [ sidebar x 307 | ; div 308 | ~cls:"large-9 medium-9 columns" 309 | (list 310 | ([ h1 (string name); p (string (String.concat " " description)) ] 311 | @ List.concat (List.map (of_type_decl None) x.Interfaces.type_decls) 312 | @ List.concat (List.map (of_interface x) x.Interfaces.interfaces))) 313 | ]) 314 | 315 | 316 | let to_string x = Cow.Html.to_string (of_interfaces x) 317 | -------------------------------------------------------------------------------- /src/html/htmlgen.mli: -------------------------------------------------------------------------------- 1 | val html_of_t : 'a Rpc.Types.typ -> string list 2 | val of_args : (bool * Idl.Param.boxed) list -> Cow.Html.t 3 | val sidebar : Codegen.Interfaces.t -> Cow.Html.t 4 | val of_struct_fields : 'a Rpc.Types.boxed_field list -> Cow.Html.t 5 | val of_variant_tags : 'a Rpc.Types.boxed_tag list -> Cow.Html.t 6 | val of_type_decl : 'a -> Rpc.Types.boxed_def -> Cow.Html.t list 7 | val tabs_of : 'a -> Codegen.Interface.t -> 'b Codegen.Method.t -> Cow.Html.t list 8 | val of_method : 'a -> Codegen.Interface.t -> Codegen.boxed_fn -> Cow.Html.t list 9 | val of_interface : 'a -> Codegen.Interface.t -> Cow.Html.t list 10 | val of_interfaces : Codegen.Interfaces.t -> Cow.Html.t 11 | val to_string : Codegen.Interfaces.t -> string 12 | -------------------------------------------------------------------------------- /src/js/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name rpc_client_js) 3 | (public_name rpclib-js) 4 | (libraries js_of_ocaml lwt rpclib.json rpclib.xml) 5 | (preprocess 6 | (pps js_of_ocaml-ppx))) 7 | -------------------------------------------------------------------------------- /src/js/rpc_client_js.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006-2009 Citrix Systems Inc. 3 | * Copyright (c) 2006-2014 Jon Ludlam 4 | * Copyright (c) 2006-2014 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | let do_rpc enc dec content_type ~url call = 20 | let method_ = "POST" in 21 | let contents = enc call in 22 | let res, w = Lwt.task () in 23 | let req = Js_of_ocaml.XmlHttpRequest.create () in 24 | req##_open 25 | (Js_of_ocaml.Js.string method_) 26 | (Js_of_ocaml.Js.string url) 27 | Js_of_ocaml.Js._true; 28 | req##setRequestHeader 29 | (Js_of_ocaml.Js.string "Content-type") 30 | (Js_of_ocaml.Js.string content_type); 31 | req##.onreadystatechange 32 | := Js_of_ocaml.Js.wrap_callback (fun _ -> 33 | match req##.readyState with 34 | | Js_of_ocaml.XmlHttpRequest.DONE -> 35 | Lwt.wakeup 36 | w 37 | (dec 38 | (Js_of_ocaml.Js.Opt.case 39 | req##.responseText 40 | (fun () -> "") 41 | (fun x -> Js_of_ocaml.Js.to_string x))) 42 | | _ -> ()); 43 | req##send (Js_of_ocaml.Js.some (Js_of_ocaml.Js.string contents)); 44 | Lwt.on_cancel res (fun () -> req##abort); 45 | res 46 | 47 | 48 | let do_xml_rpc = do_rpc Xmlrpc.string_of_call Xmlrpc.response_of_string "text/xml" 49 | let do_json_rpc = do_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string "text/json" 50 | 51 | let do_json_rpc_opt = 52 | do_rpc 53 | Rpc_client_js_helper.string_of_call 54 | Rpc_client_js_helper.response_of_string 55 | "text/json" 56 | -------------------------------------------------------------------------------- /src/js/rpc_client_js.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006-2009 Citrix Systems Inc. 3 | * Copyright (c) 2006-2014 Jon Ludlam 4 | * Copyright (c) 2006-2014 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | val do_json_rpc : url:string -> Rpc.call -> Rpc.response Lwt.t 20 | val do_json_rpc_opt : url:string -> Rpc.call -> Rpc.response Lwt.t 21 | val do_xml_rpc : url:string -> Rpc.call -> Rpc.response Lwt.t 22 | -------------------------------------------------------------------------------- /src/js/rpc_client_js_helper.ml: -------------------------------------------------------------------------------- 1 | (* This module uses the browser's native JSON parsing and converts 2 | * the result back to a Rpc.t type *) 3 | (* This require quite a lot of trial-and-error to make work :-( *) 4 | 5 | let keys obj = 6 | let arr = 7 | Js_of_ocaml.Js.Unsafe.meth_call 8 | (Js_of_ocaml.Js.Unsafe.pure_js_expr "Object") 9 | "keys" 10 | [| Js_of_ocaml.Js.Unsafe.inject obj |] 11 | in 12 | List.map Js_of_ocaml.Js.to_string (Array.to_list (Js_of_ocaml.Js.to_array arr)) 13 | 14 | 15 | (* This is apparently the ECMAscript approved way of checking whether something is an array *) 16 | let is_array obj = 17 | let str = 18 | Js_of_ocaml.Js.Unsafe.call 19 | (Js_of_ocaml.Js.Unsafe.pure_js_expr "Object.prototype.toString") 20 | obj 21 | [||] 22 | in 23 | Js_of_ocaml.Js.to_string str = "[object Array]" 24 | 25 | 26 | (* Magic to find out whether something is one of the Js_of_ocaml Javascript string types *) 27 | let mlString_constr = Js_of_ocaml.Js.Unsafe.pure_js_expr "MlString" 28 | let is_string obj = Js_of_ocaml.Js.instanceof obj mlString_constr 29 | 30 | (* Seems to work. I hope there's a better way of doing this! *) 31 | let nullobj = Js_of_ocaml.Json.unsafe_input (Js_of_ocaml.Js.string "null") 32 | let is_null obj = Js_of_ocaml.Json.output obj = Js_of_ocaml.Js.string "null" 33 | 34 | let rec rpc_of_json json = 35 | let ty = Js_of_ocaml.Js.typeof json in 36 | match Js_of_ocaml.Js.to_string ty with 37 | | "object" -> 38 | if is_array json 39 | then ( 40 | let l = Array.to_list (Js_of_ocaml.Js.to_array json) in 41 | Rpc.Enum (List.map rpc_of_json l)) 42 | else if is_string json 43 | then Rpc.String (Js_of_ocaml.Js.to_string (Js_of_ocaml.Js.Unsafe.coerce json)) 44 | else if is_null json 45 | then Rpc.Null 46 | else ( 47 | let okeys = keys json in 48 | Rpc.Dict 49 | (List.map 50 | (fun x -> 51 | x, rpc_of_json (Js_of_ocaml.Js.Unsafe.get json (Js_of_ocaml.Js.string x))) 52 | okeys)) 53 | | "boolean" -> Rpc.Bool (Js_of_ocaml.Js.to_bool (Obj.magic json)) 54 | | "number" -> 55 | (* Convert all numbers to strings - the generic Rpc-light layer can deal with this *) 56 | let str = Js_of_ocaml.Js.Unsafe.meth_call json "toString" [||] in 57 | Rpc.String (Js_of_ocaml.Js.to_string str) 58 | | _ -> 59 | (* Datetime maybe? *) 60 | Js_of_ocaml.Firebug.console##log 61 | (Js_of_ocaml.Js.string (Printf.sprintf "Ack! got %s" (Js_of_ocaml.Js.to_string ty))); 62 | Rpc.Bool false 63 | 64 | 65 | let of_string s = rpc_of_json (Js_of_ocaml.Json.unsafe_input (Js_of_ocaml.Js.string s)) 66 | 67 | (* Here be lots of magic. This is mostly untested *) 68 | let to_string rpc = 69 | let rec inner = function 70 | | Rpc.Dict kvs -> 71 | let o = Js_of_ocaml.Json.unsafe_input (Js_of_ocaml.Js.string "{}") in 72 | List.iter 73 | (fun (x, y) -> Js_of_ocaml.Js.Unsafe.set o (Js_of_ocaml.Js.string x) (inner y)) 74 | kvs; 75 | o 76 | | Rpc.Int x -> Obj.magic (Js_of_ocaml.Js.string (Int64.to_string x)) 77 | | Rpc.Int32 x -> Obj.magic x 78 | | Rpc.Float x -> Obj.magic (Js_of_ocaml.Js.string (string_of_float x)) 79 | | Rpc.String x -> Obj.magic (Js_of_ocaml.Js.string x) 80 | | Rpc.Bool x -> Obj.magic (if x then Js_of_ocaml.Js._true else Js_of_ocaml.Js._false) 81 | | Rpc.DateTime x -> Obj.magic (Js_of_ocaml.Js.string x) 82 | | Rpc.Base64 x -> Obj.magic (Js_of_ocaml.Js.string x) 83 | | Rpc.Enum l -> Obj.magic (Js_of_ocaml.Js.array (Array.of_list (List.map inner l))) 84 | | Rpc.Null -> Obj.magic Js_of_ocaml.Js.null 85 | in 86 | Js_of_ocaml.Json.output (inner rpc) 87 | 88 | 89 | let new_id = 90 | let count = ref 0l in 91 | fun () -> 92 | count := Int32.add 1l !count; 93 | !count 94 | 95 | 96 | let string_of_call call = 97 | let json = 98 | Rpc.Dict 99 | [ "method", Rpc.String call.Rpc.name 100 | ; "params", Rpc.Enum call.Rpc.params 101 | ; "id", Rpc.Int32 (new_id ()) 102 | ] 103 | in 104 | Js_of_ocaml.Js.to_string (to_string json) 105 | 106 | 107 | exception Malformed_method_response of string 108 | 109 | let get name dict = 110 | if List.mem_assoc name dict 111 | then List.assoc name dict 112 | else ( 113 | if Rpc.get_debug () then Printf.eprintf "%s was not found in the dictionary\n" name; 114 | let str = List.map (fun (n, _) -> Printf.sprintf "%s=..." n) dict in 115 | let str = Printf.sprintf "{%s}" (String.concat "," str) in 116 | raise (Malformed_method_response str)) 117 | 118 | 119 | let response_of_string str = 120 | match of_string str with 121 | | Rpc.Dict d -> 122 | let result = get "result" d in 123 | let error = get "error" d in 124 | let (_ : int64) = 125 | try 126 | match get "id" d with 127 | | Rpc.Int i -> i 128 | | Rpc.String s -> Int64.of_string s 129 | | _ -> failwith "inconsistent input" 130 | with 131 | | _ -> 132 | Js_of_ocaml.Firebug.console##log 133 | (Js_of_ocaml.Js.string 134 | (Printf.sprintf "Weirdness: %s" (Rpc.to_string (get "id" d)))); 135 | raise (Malformed_method_response "id") 136 | in 137 | (match result, error with 138 | | v, Rpc.Null -> Rpc.success v 139 | | Rpc.Null, v -> Rpc.failure v 140 | | x, y -> 141 | raise 142 | (Malformed_method_response 143 | (Printf.sprintf "" (Rpc.to_string x) (Rpc.to_string y)))) 144 | | rpc -> 145 | Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string (Rpc.to_string rpc)); 146 | failwith "Bah" 147 | -------------------------------------------------------------------------------- /src/lib/cmdlinergen.ml: -------------------------------------------------------------------------------- 1 | open Idl 2 | 3 | module Gen () = struct 4 | type implementation = 5 | unit 6 | -> ((Rpc.call -> Rpc.response) -> (unit -> unit) Cmdliner.Term.t * Cmdliner.Cmd.info) 7 | list 8 | 9 | type ('a, 'b) comp = ('a, 'b) Result.t 10 | type 'a rpcfn = Rpc.call -> Rpc.response 11 | type 'a res = unit 12 | 13 | let description = ref None 14 | let terms = ref [] 15 | 16 | let implement : Idl.Interface.description -> implementation = 17 | fun x -> 18 | description := Some x; 19 | fun () -> !terms 20 | 21 | 22 | type _ fn = 23 | | Function : 'a Param.t * 'b fn -> ('a -> 'b) fn 24 | | NoArgsFunction : 'b fn -> (unit -> 'b) fn 25 | | Returning : ('a Param.t * 'b Idl.Error.t) -> ('a, 'b) comp fn 26 | 27 | let returning a b = Returning (a, b) 28 | let ( @-> ) t f = Function (t, f) 29 | let noargs f = NoArgsFunction f 30 | let pos = ref 0 31 | 32 | let term_of_param : type a. a Param.t -> Rpc.t Cmdliner.Term.t = 33 | fun p -> 34 | let open Rpc.Types in 35 | let open Cmdliner in 36 | let pinfo = 37 | Cmdliner.Arg.info 38 | [] 39 | ~doc:(String.concat " " p.Param.description) 40 | ~docv: 41 | (match p.Param.name with 42 | | Some s -> s 43 | | None -> p.Param.typedef.Rpc.Types.name) 44 | in 45 | let incr () = 46 | let p = !pos in 47 | incr pos; 48 | p 49 | in 50 | match p.Param.typedef.Rpc.Types.ty with 51 | | Basic Int -> 52 | Term.app 53 | (Term.const Rpc.rpc_of_int64) 54 | Cmdliner.Arg.(required & pos (incr ()) (some int64) None & pinfo) 55 | | Basic Int32 -> 56 | Term.app 57 | (Term.const Rpc.rpc_of_int64) 58 | Cmdliner.Arg.(required & pos (incr ()) (some int64) None & pinfo) 59 | | Basic Int64 -> 60 | Term.app 61 | (Term.const Rpc.rpc_of_int64) 62 | Cmdliner.Arg.(required & pos (incr ()) (some int64) None & pinfo) 63 | | Basic String -> 64 | Term.app 65 | (Term.const Rpc.rpc_of_string) 66 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 67 | | Basic Bool -> 68 | Term.app 69 | (Term.const Rpc.rpc_of_bool) 70 | Cmdliner.Arg.(required & pos (incr ()) (some bool) None & pinfo) 71 | | Basic Float -> 72 | Term.app 73 | (Term.const Rpc.rpc_of_float) 74 | Cmdliner.Arg.(required & pos (incr ()) (some float) None & pinfo) 75 | | Basic Char -> 76 | Term.app 77 | (Term.const (fun s -> Rpc.rpc_of_char s.[0])) 78 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 79 | | Unit -> Term.(const Rpc.Null) 80 | | DateTime -> 81 | Term.app 82 | (Term.const Rpc.rpc_of_dateTime) 83 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 84 | | Base64 -> 85 | Term.app 86 | (Term.const Rpc.rpc_of_base64) 87 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 88 | | Array _ -> 89 | Term.app 90 | (Term.const (fun x -> 91 | let x = Jsonrpc.of_string x in 92 | match x with 93 | | Rpc.Enum _ -> x 94 | | _ -> failwith "Type error")) 95 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 96 | | List _ -> 97 | Term.app 98 | (Term.const (fun x -> 99 | let x = Jsonrpc.of_string x in 100 | match x with 101 | | Rpc.Enum _ -> x 102 | | _ -> failwith "Type error")) 103 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 104 | | Dict _ -> 105 | Term.app 106 | (Term.const (fun x -> 107 | let x = Jsonrpc.of_string x in 108 | match x with 109 | | Rpc.Dict _ -> x 110 | | _ -> failwith "Type error")) 111 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 112 | | Option _ -> Term.(const Rpc.Null) 113 | | Tuple _ -> Term.const Rpc.Null 114 | | Tuple3 _ -> Term.const Rpc.Null 115 | | Tuple4 _ -> Term.const Rpc.Null 116 | | Struct _ -> 117 | Term.app 118 | (Term.const (fun x -> 119 | let x = Jsonrpc.of_string x in 120 | match x with 121 | | Rpc.Dict _ -> x 122 | | _ -> failwith "Type error")) 123 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 124 | | Variant _ -> 125 | Term.app 126 | (Term.const (fun x -> 127 | let x = Jsonrpc.of_string x in 128 | match x with 129 | | Rpc.Enum _ | Rpc.String _ -> x 130 | | _ -> failwith "Type error")) 131 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 132 | | Abstract { of_rpc; _ } -> 133 | Term.app 134 | (Term.const (fun x -> 135 | let x = Jsonrpc.of_string x in 136 | match of_rpc x with 137 | | Ok _ -> x 138 | | Error _ -> failwith "Type error")) 139 | Cmdliner.Arg.(required & pos (incr ()) (some string) None & pinfo) 140 | 141 | 142 | let declare_ is_notification name desc_list ty = 143 | let generate rpc = 144 | let wire_name = Idl.get_wire_name !description name in 145 | let rec inner 146 | : type b. 147 | ((string * Rpc.t) list * Rpc.t list) Cmdliner.Term.t 148 | -> b fn 149 | -> (unit -> unit) Cmdliner.Term.t 150 | = 151 | fun cur f -> 152 | match f with 153 | | Function (t, f) -> 154 | let term = term_of_param t in 155 | (match t.Param.name with 156 | | Some param_name -> 157 | let term = 158 | let open Cmdliner.Term in 159 | const (fun x (named, unnamed) -> (param_name, x) :: named, unnamed) 160 | $ term 161 | $ cur 162 | in 163 | inner term f 164 | | None -> 165 | let term = 166 | let open Cmdliner.Term in 167 | const (fun x (named, unnamed) -> named, x :: unnamed) $ term $ cur 168 | in 169 | inner term f) 170 | | NoArgsFunction f -> 171 | let term = 172 | let open Cmdliner.Term in 173 | const (fun (named, unnamed) -> named, unnamed) $ cur 174 | in 175 | inner term f 176 | | Returning (_, _) -> 177 | let run (named, unnamed) = 178 | let args = 179 | match named with 180 | | [] -> List.rev unnamed 181 | | _ -> Rpc.Dict named :: List.rev unnamed 182 | in 183 | let call' = Rpc.call wire_name args in 184 | let call = { call' with is_notification } in 185 | let response = rpc call in 186 | match response.Rpc.contents with 187 | | x -> 188 | Printf.printf "%s\n" (Rpc.to_string x); 189 | () 190 | in 191 | Cmdliner.Term.(const (fun args () -> run args) $ cur) 192 | in 193 | let doc = String.concat " " desc_list in 194 | pos := 0; 195 | inner (Cmdliner.Term.const ([], [])) ty, Cmdliner.Cmd.info wire_name ~doc 196 | in 197 | terms := generate :: !terms 198 | 199 | 200 | let declare name desc_list ty = declare_ false name desc_list ty 201 | let declare_notification name desc_list ty = declare_ true name desc_list ty 202 | end 203 | -------------------------------------------------------------------------------- /src/lib/codegen.ml: -------------------------------------------------------------------------------- 1 | open Rpc.Types 2 | 3 | type _ outerfn = 4 | | Function : 'a Idl.Param.t * 'b outerfn -> ('a -> 'b) outerfn 5 | | NoArgsFunction : 'b outerfn -> (unit -> 'b) outerfn 6 | | Returning : ('a Idl.Param.t * 'b Idl.Error.t) -> ('a, 'b) Result.t outerfn 7 | 8 | module Method = struct 9 | type 'a t = 10 | { name : string 11 | ; description : string list 12 | ; ty : 'a outerfn 13 | ; is_notification : bool 14 | } 15 | 16 | let rec find_inputs : type a. a outerfn -> Idl.Param.boxed list = 17 | fun m -> 18 | match m with 19 | | Function (x, y) -> Idl.Param.Boxed x :: find_inputs y 20 | | NoArgsFunction y -> find_inputs y 21 | | Returning _ -> [] 22 | 23 | 24 | let rec find_output : type a. a outerfn -> Idl.Param.boxed = 25 | fun m -> 26 | match m with 27 | | Returning (x, _y) -> Idl.Param.Boxed x 28 | | NoArgsFunction y -> find_output y 29 | | Function (_x, y) -> find_output y 30 | 31 | 32 | let rec find_errors : type a. a outerfn -> Rpc.Types.boxed_def = 33 | fun m -> 34 | match m with 35 | | Returning (_x, y) -> Rpc.Types.BoxedDef y.Idl.Error.def 36 | | NoArgsFunction y -> find_errors y 37 | | Function (_x, y) -> find_errors y 38 | end 39 | 40 | type boxed_fn = BoxedFunction : 'a Method.t -> boxed_fn 41 | 42 | module Interface = struct 43 | include Idl.Interface 44 | 45 | type t = 46 | { details : Idl.Interface.description 47 | ; methods : boxed_fn list 48 | } 49 | 50 | let prepend_arg : t -> 'a Idl.Param.t -> t = 51 | fun interface param -> 52 | let prepend : type b. b outerfn -> ('a -> b) outerfn = 53 | fun arg -> Function (param, arg) 54 | in 55 | { interface with 56 | methods = 57 | List.map 58 | (fun (BoxedFunction m) -> 59 | BoxedFunction 60 | Method. 61 | { name = m.name 62 | ; description = m.description 63 | ; ty = prepend m.ty 64 | ; is_notification = m.is_notification 65 | }) 66 | interface.methods 67 | } 68 | 69 | 70 | let setify l = 71 | List.fold_left (fun set x -> if List.mem x set then set else x :: set) [] l 72 | |> List.rev 73 | 74 | 75 | let all_types : t -> boxed_def list = 76 | fun i -> 77 | let all_inputs = 78 | List.map 79 | (function 80 | | BoxedFunction f -> Method.(find_inputs f.ty)) 81 | i.methods 82 | in 83 | let all_outputs = 84 | List.map 85 | (function 86 | | BoxedFunction f -> Method.(find_output f.ty)) 87 | i.methods 88 | in 89 | let all = List.concat (all_inputs @ [ all_outputs ]) in 90 | let types = List.map (fun (Idl.Param.Boxed p) -> BoxedDef p.Idl.Param.typedef) all in 91 | setify types 92 | 93 | 94 | let all_errors i = 95 | i.methods 96 | |> List.map (function BoxedFunction f -> Method.(find_errors f.ty)) 97 | |> setify 98 | end 99 | 100 | module Interfaces = struct 101 | type t = 102 | { name : string 103 | ; title : string 104 | ; description : string list 105 | ; type_decls : boxed_def list 106 | ; error_decls : boxed_def list 107 | ; interfaces : Interface.t list 108 | } 109 | 110 | let empty name title description = 111 | { name; title; description; type_decls = []; error_decls = []; interfaces = [] } 112 | 113 | 114 | let add_interface i is = 115 | let not_in defs (BoxedDef def) = 116 | not (List.exists (fun (BoxedDef def') -> def'.name = def.name) defs) 117 | in 118 | let typedefs = Interface.all_types i in 119 | let new_typedefs = List.filter (not_in is.type_decls) typedefs in 120 | let new_errors = List.filter (not_in is.error_decls) (Interface.all_errors i) in 121 | { is with 122 | type_decls = new_typedefs @ is.type_decls 123 | ; error_decls = new_errors @ is.error_decls 124 | ; interfaces = i :: is.interfaces 125 | } 126 | 127 | 128 | let create ~name ~title ~description ~interfaces = 129 | let i = empty name title description in 130 | List.fold_right add_interface interfaces i 131 | end 132 | 133 | exception Interface_not_described 134 | 135 | module Gen () = struct 136 | type ('a, 'b) comp = ('a, 'b) Result.t 137 | type 'a fn = 'a outerfn 138 | type 'a res = unit 139 | type implementation = unit -> Interface.t 140 | 141 | let methods = ref [] 142 | 143 | let implement i () = 144 | let n = i.Interface.name in 145 | if String.capitalize_ascii n <> n then failwith "Interface names must be capitalized"; 146 | let i = Interface.{ details = i; methods = List.rev !methods } in 147 | i 148 | 149 | 150 | let returning a b = Returning (a, b) 151 | let ( @-> ) t f = Function (t, f) 152 | let noargs f = NoArgsFunction f 153 | 154 | let declare_ is_notification name description ty = 155 | let m = BoxedFunction Method.{ name; description; ty; is_notification } in 156 | methods := m :: !methods 157 | 158 | 159 | let declare : string -> string list -> 'a fn -> 'a res = 160 | fun name description ty -> declare_ false name description ty 161 | 162 | 163 | let declare_notification name description ty = declare_ true name description ty 164 | end 165 | -------------------------------------------------------------------------------- /src/lib/codegen.mli: -------------------------------------------------------------------------------- 1 | type _ outerfn = 2 | | Function : 'a Idl.Param.t * 'b outerfn -> ('a -> 'b) outerfn 3 | | NoArgsFunction : 'b outerfn -> (unit -> 'b) outerfn 4 | | Returning : ('a Idl.Param.t * 'b Idl.Error.t) -> ('a, 'b) Result.t outerfn 5 | 6 | module Method : sig 7 | type 'a t = 8 | { name : string 9 | ; description : string list 10 | ; ty : 'a outerfn 11 | ; is_notification : bool 12 | } 13 | 14 | val find_inputs : 'a outerfn -> Idl.Param.boxed list 15 | val find_output : 'a outerfn -> Idl.Param.boxed 16 | val find_errors : 'a outerfn -> Rpc.Types.boxed_def 17 | end 18 | 19 | type boxed_fn = BoxedFunction : 'a Method.t -> boxed_fn 20 | 21 | module Interface : sig 22 | type description = Idl.Interface.description = 23 | { name : string 24 | ; namespace : string option 25 | ; description : string list 26 | ; version : Rpc.Version.t 27 | } 28 | 29 | type t = 30 | { details : Idl.Interface.description 31 | ; methods : boxed_fn list 32 | } 33 | 34 | val prepend_arg : t -> 'a Idl.Param.t -> t 35 | val all_types : t -> Rpc.Types.boxed_def list 36 | val all_errors : t -> Rpc.Types.boxed_def list 37 | end 38 | 39 | module Interfaces : sig 40 | type t = 41 | { name : string 42 | ; title : string 43 | ; description : string list 44 | ; type_decls : Rpc.Types.boxed_def list 45 | ; error_decls : Rpc.Types.boxed_def list 46 | ; interfaces : Interface.t list 47 | } 48 | 49 | val empty : string -> string -> string list -> t 50 | val add_interface : Interface.t -> t -> t 51 | 52 | val create 53 | : name:string 54 | -> title:string 55 | -> description:string list 56 | -> interfaces:Interface.t list 57 | -> t 58 | end 59 | 60 | exception Interface_not_described 61 | 62 | module Gen () : sig 63 | type ('a, 'b) comp = ('a, 'b) Result.t 64 | type 'a fn = 'a outerfn 65 | type 'a res = unit 66 | type implementation = unit -> Interface.t 67 | 68 | val implement : Interface.description -> implementation 69 | val returning : 'a Idl.Param.t -> 'b Idl.Error.t -> ('a, 'b) Result.t outerfn 70 | val ( @-> ) : 'a Idl.Param.t -> 'b outerfn -> ('a -> 'b) outerfn 71 | val noargs : 'b outerfn -> (unit -> 'b) outerfn 72 | val declare : string -> string list -> 'a fn -> 'a res 73 | val declare_notification : string -> string list -> 'a fn -> 'a res 74 | end 75 | -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name internals) 3 | (public_name rpclib.internals) 4 | (modules internals) 5 | (wrapped false)) 6 | 7 | (library 8 | (name rpclib_core) 9 | (public_name rpclib.core) 10 | (modules rpc idl rpcmarshal pythongen codegen rpc_genfake) 11 | (libraries result base64 rresult) 12 | (wrapped false)) 13 | 14 | (library 15 | (name xml) 16 | (public_name rpclib.xml) 17 | (modules xmlrpc) 18 | (libraries internals base64 rpclib.core xmlm) 19 | (wrapped false)) 20 | 21 | (library 22 | (name json) 23 | (public_name rpclib.json) 24 | (modules jsonrpc) 25 | (libraries rpclib.core yojson) 26 | (wrapped false)) 27 | 28 | (library 29 | (name cmdlinergen) 30 | (public_name rpclib.cmdliner) 31 | (modules cmdlinergen) 32 | (libraries cmdliner rpclib.core rpclib.json) 33 | (wrapped false)) 34 | 35 | (library 36 | (name markdowngen) 37 | (public_name rpclib.markdown) 38 | (modules markdowngen) 39 | (libraries rpclib.core rpclib.json rpclib.xml) 40 | (wrapped false)) 41 | 42 | (library 43 | (name rpclib) 44 | (public_name rpclib) 45 | (libraries rpclib.core rpclib.xml) 46 | (modules rpclib)) 47 | -------------------------------------------------------------------------------- /src/lib/idl.mli: -------------------------------------------------------------------------------- 1 | (** The Idl module is for declaring the types and documentation for RPC calls *) 2 | 3 | (** The Param module is associated with parameters to RPCs. RPCs are defined in terms of 4 | 'a Param.t values. *) 5 | module Param : sig 6 | (** A Param.t has a name, description and a typedef. We may also want to add in here 7 | default values, example values and so on *) 8 | type 'a t = 9 | { name : string option 10 | ; description : string list 11 | ; typedef : 'a Rpc.Types.def 12 | ; version : Rpc.Version.t option 13 | } 14 | 15 | (** We box parameters to put them into lists *) 16 | type boxed = Boxed : 'a t -> boxed 17 | 18 | (** [mk ~name ~description typ] creates a Param.t out of a type definition 19 | from the Types module. If the name or description are omitted, the name 20 | or description from the type definition will be inherited *) 21 | val mk 22 | : ?name:string 23 | -> ?description:string list 24 | -> ?version:Rpc.Version.t 25 | -> 'a Rpc.Types.def 26 | -> 'a t 27 | end 28 | 29 | (* An error that might be raised by an RPC *) 30 | 31 | module Error : sig 32 | type 'a t = 33 | { def : 'a Rpc.Types.def 34 | ; raiser : 'a -> exn 35 | ; matcher : exn -> 'a option 36 | } 37 | 38 | module type ERROR = sig 39 | type t 40 | 41 | val t : t Rpc.Types.def 42 | val internal_error_of : exn -> t option 43 | end 44 | 45 | module Make (T : ERROR) : sig 46 | val error : T.t t 47 | end 48 | end 49 | 50 | (** An interface is a collection of RPC declarations. *) 51 | module Interface : sig 52 | type description = 53 | { name : string 54 | ; namespace : string option 55 | ; description : string list 56 | ; version : Rpc.Version.t 57 | } 58 | end 59 | 60 | (** Raised when the client/server failed to unmarshal the RPC response/request. *) 61 | exception MarshalError of string 62 | 63 | val get_wire_name : Interface.description option -> string -> string 64 | 65 | val get_arg 66 | : Rpc.call 67 | -> bool 68 | -> string option 69 | -> bool 70 | -> (Rpc.t * Rpc.call, [> `Msg of string ]) result 71 | 72 | (** The RPC module type is the standard module signature that the various 73 | specialization modules must conform to. *) 74 | module type RPC = sig 75 | (** The implementation is dependent on the module, and represents the 76 | 'result' of the entire module. For example, in the Server 77 | module, the `implementation` is the server function, with type 78 | 79 | Rpc.call -> Rpc.response. 80 | 81 | For the Client module, the individual declarations are used to perform 82 | the RPCs, and the 'implementation' type is simply unit. *) 83 | type implementation 84 | 85 | (** To actually construct the implementation, an interface description 86 | must be provided *) 87 | val implement : Interface.description -> implementation 88 | 89 | (** 'a res is the result type of declaring a function. For example, 90 | the Client module, given an (int -> int -> int) fn, will return 91 | a function of type 'a - in this case, (int -> int -> int) *) 92 | type 'a res 93 | 94 | (** This is for inserting a type in between the function application 95 | and its result. For example, this could be an Lwt.t, meaning that 96 | the result of a function application is a thread *) 97 | type ('a, 'b) comp 98 | 99 | (** The GADT specifying the type of the RPC *) 100 | type _ fn 101 | 102 | (** This infix operator is for constructing function types *) 103 | val ( @-> ) : 'a Param.t -> 'b fn -> ('a -> 'b) fn 104 | 105 | (** Require a unit argument in OCaml without sending a parameter. 106 | Useful for methods that take no arguments. *) 107 | val noargs : 'b fn -> (unit -> 'b) fn 108 | 109 | (** This defines the return type of an RPC *) 110 | val returning : 'a Param.t -> 'b Error.t -> ('a, 'b) comp fn 111 | 112 | (** [declare name description typ] is how an RPC is declared to the 113 | module implementing the functionality. The return type is dependent 114 | upon the module being used *) 115 | val declare : string -> string list -> 'a fn -> 'a res 116 | 117 | (** [declare_notification name description typ] is mostly the same as 118 | declare, only that it allows support from JSON-RPC notifications. *) 119 | val declare_notification : string -> string list -> 'a fn -> 'a res 120 | end 121 | 122 | module type MONAD = sig 123 | type 'a t 124 | 125 | val return : 'a -> 'a t 126 | val bind : 'a t -> ('a -> 'b t) -> 'b t 127 | val fail : exn -> 'a t 128 | end 129 | 130 | (** For the Server generation, the 'implement' function call _must_ be called 131 | before any RPCs are described. This exception will be raised if the user 132 | tries to do this. *) 133 | exception NoDescription 134 | 135 | module Make (M : MONAD) : sig 136 | type client_implementation 137 | type server_implementation 138 | 139 | module type RPCTRANSFORMER = sig 140 | type 'a box 141 | type ('a, 'b) resultb = ('a, 'b) Result.t box 142 | type rpcfn = Rpc.call -> Rpc.response M.t 143 | 144 | val lift : ('a -> 'b M.t) -> 'a -> 'b box 145 | val bind : 'a box -> ('a -> 'b M.t) -> 'b box 146 | val return : 'a -> 'a box 147 | val get : 'a box -> 'a M.t 148 | val ( !@ ) : 'a box -> 'a M.t 149 | val put : 'a M.t -> 'a box 150 | val ( ~@ ) : 'a M.t -> 'a box 151 | end 152 | 153 | (** The module [!T], the [RPC] [MONAD] transformer, defines the minimal set 154 | of types and functions needed for the [!GenClient] and [!GenServer] modules 155 | to generate clients and servers. These allow to provide different syncronous 156 | and asynctronous engines for the client and server implementations. 157 | *) 158 | module T : RPCTRANSFORMER 159 | 160 | (** [!ErrM] defines monad to use for the implementation and combination 161 | of RPC functions *) 162 | module ErrM : sig 163 | val return : 'a -> ('a, 'b) T.resultb 164 | val return_err : 'b -> ('a, 'b) T.resultb 165 | 166 | val checked_bind 167 | : ('a, 'b) T.resultb 168 | -> ('a -> ('c, 'd) T.resultb) 169 | -> ('b -> ('c, 'd) T.resultb) 170 | -> ('c, 'd) T.resultb 171 | 172 | val bind : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 173 | val ( >>= ) : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 174 | end 175 | 176 | (** This module generates Client modules from RPC declarations. 177 | 178 | The [implementation] of the module as a whole is unused. However, the 179 | namespace comes from the interface description, and hence calling 180 | [implement] is important. 181 | 182 | The result of declaring a function of type 'a (where for example 'a might 183 | be [(int -> string -> (bool, err) result)]), is a function that takes an rpc 184 | function, which might send the RPC across the network, and returns a 185 | function of type 'a, in this case [(int -> string -> (bool, err) result)]. 186 | 187 | Our functions return a [Result.t] type, which contains 188 | the result of the Rpc, which might be an error message indicating 189 | a problem happening on the remote end. *) 190 | module GenClient () : sig 191 | include 192 | RPC 193 | with type implementation = client_implementation 194 | and type 'a res = T.rpcfn -> 'a 195 | and type ('a, 'b) comp = ('a, 'b) T.resultb 196 | 197 | (** This is irreversible, once used the client will fail in case of Rpc 198 | failure ([M.fail]) instead of returning the error 199 | ([M.return (Error ...)]). *) 200 | val make_strict : unit -> unit 201 | end 202 | 203 | (** This module generates a server that dispatches RPC calls to their 204 | implementations. 205 | 206 | Given an {!Rpc.call}, it calls the implementation of that RPC method and performs 207 | the marshalling and unmarshalling. It is up to the user of this library to 208 | connect this rpc function to a real server that responds to client requests. 209 | 210 | The implementations of each RPC method should be specified by passing it to 211 | the corresponding function in the generated module. 212 | 213 | Then the server itself can be obtained by passing the [implementation] 214 | to {!server}. *) 215 | module GenServer () : sig 216 | include 217 | RPC 218 | with type implementation = server_implementation 219 | and type 'a res = 'a -> unit 220 | and type ('a, 'b) comp = ('a, 'b) T.resultb 221 | end 222 | 223 | val server : server_implementation -> T.rpcfn 224 | val combine : server_implementation list -> server_implementation 225 | end 226 | 227 | module ExnM : sig 228 | include MONAD 229 | 230 | val lift : ('a -> 'b) -> 'a -> 'b t 231 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 232 | val run : 'a t -> 'a 233 | end 234 | 235 | module IdM : sig 236 | include MONAD 237 | 238 | val lift : ('a -> 'b) -> 'a -> 'b t 239 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 240 | val run : 'a t -> 'a 241 | end 242 | 243 | module DefaultError : sig 244 | type t = InternalError of string 245 | 246 | exception InternalErrorExn of string 247 | 248 | val internalerror : (string, t) Rpc.Types.tag 249 | val t : t Rpc.Types.variant 250 | val def : t Rpc.Types.def 251 | val err : t Error.t 252 | end 253 | 254 | module Exn : sig 255 | type rpcfn = Rpc.call -> Rpc.response 256 | type client_implementation 257 | 258 | (** This module generates exception-raising Client modules from RPC 259 | declarations. See the {!GenClient} module for a description of 260 | the common entries. *) 261 | module GenClient (R : sig 262 | val rpc : rpcfn 263 | end) : sig 264 | include 265 | RPC 266 | with type implementation = client_implementation 267 | and type 'a res = 'a 268 | (* Our functions never return the error parameter, hence the following 269 | type declaration drops the `b parameter. Instead, the exception declared 270 | in the Error.t passed in the `returning` function below will be raised. *) 271 | and type ('a, 'b) comp = 'a 272 | end 273 | 274 | type server_implementation 275 | 276 | val server : server_implementation -> rpcfn 277 | val combine : server_implementation list -> server_implementation 278 | 279 | (** Generates a server, like {!GenServer}, but for an implementation that 280 | raises exceptions instead of returning a [result]. *) 281 | module GenServer () : sig 282 | include 283 | RPC 284 | with type implementation = server_implementation 285 | and type 'a res = 'a -> unit 286 | and type ('a, 'b) comp = 'a 287 | end 288 | end 289 | -------------------------------------------------------------------------------- /src/lib/internals.ml: -------------------------------------------------------------------------------- 1 | (** Encodes a string using the given translation function that maps a character 2 | to a string that is its encoded version, if that character needs encoding. *) 3 | let encode translate s = 4 | let n = String.length s in 5 | let need_encoding = 6 | let b = ref false in 7 | let i = ref 0 in 8 | while (not !b) && !i < n do 9 | b := translate s.[!i] <> None; 10 | incr i 11 | done; 12 | !b 13 | in 14 | if need_encoding 15 | then ( 16 | let buf = Buffer.create 0 in 17 | let m = ref 0 in 18 | for i = 0 to n - 1 do 19 | match translate s.[i] with 20 | | None -> () 21 | | Some n -> 22 | Buffer.add_substring buf s !m (i - !m); 23 | Buffer.add_string buf n; 24 | m := i + 1 25 | done; 26 | Buffer.add_substring buf s !m (n - !m); 27 | Buffer.contents buf) 28 | else s 29 | -------------------------------------------------------------------------------- /src/lib/jsonrpc.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006-2009 Citrix Systems Inc. 3 | * Copyright (c) 2006-2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Rpc 19 | 20 | module Yojson_private = struct 21 | include Yojson.Safe 22 | 23 | let from_string ?(strict = true) ?buf ?fname ?lnum s = 24 | let open Yojson in 25 | try 26 | let lexbuf = Lexing.from_string s in 27 | let v = init_lexer ?buf ?fname ?lnum () in 28 | if strict then from_lexbuf v lexbuf else from_lexbuf v ~stream:true lexbuf 29 | with 30 | | End_of_input -> json_error "Blank input data" 31 | end 32 | 33 | module Y = Yojson_private 34 | module U = Yojson.Basic.Util 35 | 36 | type version = 37 | | V1 38 | | V2 39 | 40 | let rec rpc_to_json t = 41 | match t with 42 | | Int i -> `Intlit (Int64.to_string i) 43 | | Int32 i -> `Int (Int32.to_int i) 44 | | Bool b -> `Bool b 45 | | Float r -> `Float r 46 | | String s -> `String s 47 | | DateTime d -> `String d 48 | | Base64 b -> `String b 49 | | Null -> `Null 50 | | Enum a -> `List (Rpcmarshal.tailrec_map rpc_to_json a) 51 | | Dict a -> `Assoc (Rpcmarshal.tailrec_map (fun (k, v) -> k, rpc_to_json v) a) 52 | 53 | 54 | exception JsonToRpcError of Y.t 55 | 56 | let rec json_to_rpc t = 57 | match t with 58 | | `Intlit i -> Int (Int64.of_string i) 59 | | `Int i -> Int (Int64.of_int i) 60 | | `Bool b -> Bool b 61 | | `Float r -> Float r 62 | | `String s -> (* TODO: check if it is a DateTime *) String s 63 | (* | DateTime d -> `String d *) 64 | (* | Base64 b -> `String b *) 65 | | `Null -> Null 66 | | `List a -> Enum (Rpcmarshal.tailrec_map json_to_rpc a) 67 | | `Assoc a -> Dict (Rpcmarshal.tailrec_map (fun (k, v) -> k, json_to_rpc v) a) 68 | | unsupported -> raise (JsonToRpcError unsupported) 69 | 70 | 71 | let to_fct t f = rpc_to_json t |> Y.to_string |> f 72 | let to_buffer t buf = to_fct t (fun s -> Buffer.add_string buf s) 73 | let to_string t = rpc_to_json t |> Y.to_string 74 | 75 | let to_a ~empty ~append t = 76 | let buf = empty () in 77 | to_fct t (fun s -> append buf s); 78 | buf 79 | 80 | 81 | let new_id = 82 | let count = ref 0L in 83 | fun () -> 84 | count := Int64.add 1L !count; 85 | !count 86 | 87 | 88 | let string_of_call ?(version = V1) call = 89 | let json = 90 | match version with 91 | | V1 -> [ "method", String call.name; "params", Enum call.params ] 92 | | V2 -> 93 | let params = 94 | match call.params with 95 | | [ Dict x ] -> Dict x 96 | | _ -> Enum call.params 97 | in 98 | [ "jsonrpc", String "2.0"; "method", String call.name; "params", params ] 99 | in 100 | let json = 101 | if not call.is_notification then json @ [ "id", Int (new_id ()) ] else json 102 | in 103 | to_string (Dict json) 104 | 105 | 106 | let json_of_response ?(id = Int 0L) version response = 107 | if response.Rpc.success 108 | then ( 109 | match version with 110 | | V1 -> Dict [ "result", response.Rpc.contents; "error", Null; "id", id ] 111 | | V2 -> Dict [ "jsonrpc", String "2.0"; "result", response.Rpc.contents; "id", id ]) 112 | else ( 113 | match version with 114 | | V1 -> Dict [ "result", Null; "error", response.Rpc.contents; "id", id ] 115 | | V2 -> Dict [ "jsonrpc", String "2.0"; "error", response.Rpc.contents; "id", id ]) 116 | 117 | 118 | let json_of_error_object ?(data = None) code message = 119 | let data_json = 120 | match data with 121 | | Some d -> [ "data", d ] 122 | | None -> [] 123 | in 124 | Dict ([ "code", Int code; "message", String message ] @ data_json) 125 | 126 | 127 | let string_of_response ?(id = Int 0L) ?(version = V1) response = 128 | let json = json_of_response ~id version response in 129 | to_string json 130 | 131 | 132 | let a_of_response ?(id = Int 0L) ?(version = V1) ~empty ~append response = 133 | let json = json_of_response ~id version response in 134 | to_a ~empty ~append json 135 | 136 | 137 | let of_string ?(strict = true) s = s |> Y.from_string ~strict |> json_to_rpc 138 | 139 | let of_a ~next_char b = 140 | let buf = Buffer.create 2048 in 141 | let rec acc () = 142 | match next_char b with 143 | | Some c -> 144 | Buffer.add_char buf c; 145 | acc () 146 | | None -> () 147 | in 148 | acc (); 149 | Buffer.contents buf |> of_string 150 | 151 | 152 | let get' name dict = 153 | try Some (List.assoc name dict) with 154 | | Not_found -> None 155 | 156 | 157 | exception Malformed_method_request of string 158 | exception Malformed_method_response of string 159 | exception Missing_field of string 160 | 161 | let get name dict = 162 | match get' name dict with 163 | | None -> 164 | if Rpc.get_debug () then Printf.eprintf "%s was not found in the dictionary\n" name; 165 | raise (Missing_field name) 166 | | Some v -> v 167 | 168 | 169 | let version_id_and_call_of_string_option str = 170 | try 171 | match of_string str with 172 | | Dict d -> 173 | let name = 174 | match get "method" d with 175 | | String s -> s 176 | | _ -> raise (Malformed_method_request "Invalid field 'method' in request body") 177 | in 178 | let version = 179 | match get' "jsonrpc" d with 180 | | None -> V1 181 | | Some (String "2.0") -> V2 182 | | _ -> raise (Malformed_method_request "Invalid field 'jsonrpc' in request body") 183 | in 184 | let params = 185 | match version with 186 | | V1 -> 187 | (match get "params" d with 188 | | Enum l -> l 189 | | _ -> raise (Malformed_method_request "Invalid field 'params' in request body")) 190 | | V2 -> 191 | (match get' "params" d with 192 | | None | Some Null -> [] 193 | | Some (Enum l) -> l 194 | | Some (Dict l) -> [ Dict l ] 195 | | _ -> raise (Malformed_method_request "Invalid field 'params' in request body")) 196 | in 197 | let id = 198 | match get' "id" d with 199 | | None | Some Null -> None (* is a notification *) 200 | | Some (Int a) -> Some (Int a) 201 | | Some (String a) -> Some (String a) 202 | | Some _ -> raise (Malformed_method_request "Invalid field 'id' in request body") 203 | in 204 | let c = call name params in 205 | version, id, { c with is_notification = id == None } 206 | | _ -> raise (Malformed_method_request "Invalid request body") 207 | with 208 | | Missing_field field -> 209 | raise (Malformed_method_request (Printf.sprintf "Required field %s is missing" field)) 210 | | JsonToRpcError json -> 211 | raise 212 | (Malformed_method_request (Printf.sprintf "Unable to parse %s" (Y.to_string json))) 213 | 214 | 215 | let version_id_and_call_of_string s = 216 | let version, id_, call = version_id_and_call_of_string_option s in 217 | match id_ with 218 | | Some id -> version, id, call 219 | | None -> raise (Malformed_method_request "Invalid field 'id' in request body") 220 | 221 | 222 | let call_of_string str = 223 | let _, _, call = version_id_and_call_of_string str in 224 | call 225 | 226 | 227 | (* This functions parses the json and tries to extract a valid jsonrpc response 228 | * (See http://www.jsonrpc.org/ for the exact specs). *) 229 | let get_response extractor str = 230 | try 231 | match extractor str with 232 | | Dict d -> 233 | let _ = 234 | match get "id" d with 235 | | Int _ as x -> x 236 | | String _ as y -> y 237 | | _ -> raise (Malformed_method_response "id") 238 | in 239 | (match get' "jsonrpc" d with 240 | | None -> 241 | let result = get "result" d in 242 | let error = get "error" d in 243 | (match result, error with 244 | | v, Null -> success v 245 | | Null, v -> failure v 246 | | x, y -> 247 | raise 248 | (Malformed_method_response 249 | (Printf.sprintf 250 | "" 251 | (Rpc.to_string x) 252 | (Rpc.to_string y)))) 253 | | Some (String "2.0") -> 254 | let result = get' "result" d in 255 | let error = get' "error" d in 256 | (match result, error with 257 | | Some v, None -> success v 258 | | None, Some v -> 259 | (match v with 260 | | Dict err -> 261 | let (_ : int64) = 262 | match get "code" err with 263 | | Int i -> i 264 | | _ -> raise (Malformed_method_response "Error code") 265 | in 266 | let _ = 267 | match get "message" err with 268 | | String s -> s 269 | | _ -> raise (Malformed_method_response "Error message") 270 | in 271 | failure v 272 | | _ -> raise (Malformed_method_response "Error object")) 273 | | Some x, Some y -> 274 | raise 275 | (Malformed_method_response 276 | (Printf.sprintf 277 | "" 278 | (Rpc.to_string x) 279 | (Rpc.to_string y))) 280 | | None, None -> 281 | raise 282 | (Malformed_method_response 283 | (Printf.sprintf "neither nor was found"))) 284 | | _ -> raise (Malformed_method_response "jsonrpc")) 285 | | rpc -> 286 | raise 287 | (Malformed_method_response 288 | (Printf.sprintf "" (to_string rpc))) 289 | with 290 | | Missing_field field -> 291 | raise (Malformed_method_response (Printf.sprintf "<%s was not found>" field)) 292 | | JsonToRpcError json -> 293 | raise 294 | (Malformed_method_response 295 | (Printf.sprintf "" (Y.to_string json))) 296 | 297 | 298 | let response_of_string ?(strict = true) str = get_response (of_string ~strict) str 299 | 300 | let response_of_in_channel channel = 301 | let of_channel s = s |> Y.from_channel |> json_to_rpc in 302 | get_response of_channel channel 303 | -------------------------------------------------------------------------------- /src/lib/jsonrpc.mli: -------------------------------------------------------------------------------- 1 | type version = 2 | | V1 3 | | V2 4 | 5 | exception Malformed_method_request of string 6 | exception Malformed_method_response of string 7 | 8 | val new_id : unit -> int64 9 | val to_buffer : Rpc.t -> Buffer.t -> unit 10 | val to_string : Rpc.t -> string 11 | 12 | val to_a : empty:(unit -> 'a) -> append:('a -> string -> unit) -> Rpc.t -> 'a 13 | [@@ocaml.deprecated] 14 | 15 | val string_of_call : ?version:version -> Rpc.call -> string 16 | val string_of_response : ?id:Rpc.t -> ?version:version -> Rpc.response -> string 17 | val of_string : ?strict:bool -> string -> Rpc.t 18 | val of_a : next_char:('a -> char option) -> 'a -> Rpc.t [@@ocaml.deprecated] 19 | 20 | val a_of_response 21 | : ?id:Rpc.t 22 | -> ?version:version 23 | -> empty:(unit -> 'a) 24 | -> append:('a -> string -> unit) 25 | -> Rpc.response 26 | -> 'a 27 | [@@ocaml.deprecated] 28 | 29 | val json_of_response : ?id:Rpc.t -> version -> Rpc.response -> Rpc.t 30 | val json_of_error_object : ?data:Rpc.t option -> int64 -> string -> Rpc.t 31 | val get : string -> (string * 'a) list -> 'a 32 | val call_of_string : string -> Rpc.call 33 | val version_id_and_call_of_string : string -> version * Rpc.t * Rpc.call 34 | val version_id_and_call_of_string_option : string -> version * Rpc.t option * Rpc.call 35 | val response_of_string : ?strict:bool -> string -> Rpc.response 36 | val response_of_in_channel : in_channel -> Rpc.response 37 | -------------------------------------------------------------------------------- /src/lib/rpc.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006-2009 Citrix Systems Inc. 3 | * Copyright (c) 2006-2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let debug = ref false 19 | let set_debug x = debug := x 20 | let get_debug () = !debug 21 | 22 | type t = 23 | | Int of int64 24 | | Int32 of int32 25 | | Bool of bool 26 | | Float of float 27 | | String of string 28 | | DateTime of string 29 | | Enum of t list 30 | | Dict of (string * t) list 31 | | Base64 of string 32 | | Null 33 | 34 | module Version = struct 35 | type t = int * int * int 36 | 37 | let compare (x, y, z) (x', y', z') = 38 | let cmp a b fn () = 39 | let c = compare a b in 40 | if c <> 0 then c else fn () 41 | in 42 | cmp x x' (cmp y y' (cmp z z' (fun () -> 0))) () 43 | end 44 | 45 | module Types = struct 46 | type _ basic = 47 | | Int : int basic 48 | | Int32 : int32 basic 49 | | Int64 : int64 basic 50 | | Bool : bool basic 51 | | Float : float basic 52 | | String : string basic 53 | | Char : char basic 54 | 55 | type _ typ = 56 | | Basic : 'a basic -> 'a typ 57 | | DateTime : string typ 58 | | Base64 : string typ 59 | | Array : 'a typ -> 'a array typ 60 | | List : 'a typ -> 'a list typ 61 | | Dict : 'a basic * 'b typ -> ('a * 'b) list typ 62 | | Unit : unit typ 63 | | Option : 'a typ -> 'a option typ 64 | | Tuple : 'a typ * 'b typ -> ('a * 'b) typ 65 | | Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ 66 | | Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ 67 | | Struct : 'a structure -> 'a typ 68 | | Variant : 'a variant -> 'a typ 69 | | Abstract : 'a abstract -> 'a typ 70 | 71 | (* A type definition has a name and description *) 72 | and 'a def = 73 | { name : string 74 | ; description : string list 75 | ; ty : 'a typ 76 | } 77 | 78 | and boxed_def = BoxedDef : 'a def -> boxed_def 79 | 80 | and ('a, 's) field = 81 | { fname : string 82 | ; fdescription : string list 83 | ; fversion : Version.t option 84 | ; field : 'a typ 85 | ; fdefault : 'a option 86 | ; fget : 's -> 'a 87 | ; (* Lenses *) 88 | fset : 'a -> 's -> 's 89 | } 90 | 91 | and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field 92 | 93 | and field_getter = 94 | { field_get : 'a. string -> 'a typ -> ('a, Rresult.R.msg) Result.t } 95 | 96 | and 'a structure = 97 | { sname : string 98 | ; fields : 'a boxed_field list 99 | ; version : Version.t option 100 | ; constructor : field_getter -> ('a, Rresult.R.msg) Result.t 101 | } 102 | 103 | and ('a, 's) tag = 104 | { tname : string 105 | ; tdescription : string list 106 | ; tversion : Version.t option 107 | ; tcontents : 'a typ 108 | ; tpreview : 's -> 'a option 109 | ; treview : 'a -> 's 110 | } 111 | 112 | and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag 113 | 114 | and tag_getter = { tget : 'a. 'a typ -> ('a, Rresult.R.msg) Result.t } 115 | 116 | and 'a variant = 117 | { vname : string 118 | ; variants : 'a boxed_tag list 119 | ; vdefault : 'a option 120 | ; vversion : Version.t option 121 | ; vconstructor : string -> tag_getter -> ('a, Rresult.R.msg) Result.t 122 | } 123 | 124 | and 'a abstract = 125 | { aname : string 126 | ; test_data : 'a list 127 | ; rpc_of : 'a -> t 128 | ; of_rpc : t -> ('a, Rresult.R.msg) Result.t 129 | } 130 | 131 | let int = { name = "int"; ty = Basic Int; description = [ "Native integer" ] } 132 | let int32 = { name = "int32"; ty = Basic Int32; description = [ "32-bit integer" ] } 133 | let int64 = { name = "int64"; ty = Basic Int64; description = [ "64-bit integer" ] } 134 | let bool = { name = "bool"; ty = Basic Bool; description = [ "Boolean" ] } 135 | 136 | let float = 137 | { name = "float"; ty = Basic Float; description = [ "Floating-point number" ] } 138 | 139 | 140 | let string = { name = "string"; ty = Basic String; description = [ "String" ] } 141 | let char = { name = "char"; ty = Basic Char; description = [ "Char" ] } 142 | let unit = { name = "unit"; ty = Unit; description = [ "Unit" ] } 143 | 144 | let default_types = 145 | [ BoxedDef int 146 | ; BoxedDef int32 147 | ; BoxedDef int64 148 | ; BoxedDef bool 149 | ; BoxedDef float 150 | ; BoxedDef string 151 | ; BoxedDef char 152 | ; BoxedDef unit 153 | ] 154 | end 155 | 156 | exception Runtime_error of string * t 157 | exception Runtime_exception of string * string 158 | 159 | let map_strings sep fn l = String.concat sep (List.map fn l) 160 | 161 | let rec to_string t = 162 | let open Printf in 163 | match t with 164 | | Int i -> sprintf "I(%Li)" i 165 | | Int32 i -> sprintf "I32(%li)" i 166 | | Bool b -> sprintf "B(%b)" b 167 | | Float f -> sprintf "F(%g)" f 168 | | String s -> sprintf "S(%s)" s 169 | | DateTime s -> sprintf "D(%s)" s 170 | | Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts) 171 | | Dict ts -> 172 | sprintf "{%s}" (map_strings ";" (fun (s, t) -> sprintf "%s:%s" s (to_string t)) ts) 173 | | Base64 s -> sprintf "B64(%s)" s 174 | | Null -> "N" 175 | 176 | 177 | let rpc_of_t x = x 178 | let rpc_of_int64 i = Int i 179 | let rpc_of_int32 i = Int (Int64.of_int32 i) 180 | let rpc_of_int i = Int (Int64.of_int i) 181 | let rpc_of_bool b = Bool b 182 | let rpc_of_float f = Float f 183 | let rpc_of_string s = String s 184 | let rpc_of_dateTime s = DateTime s 185 | let rpc_of_base64 s = Base64 s 186 | let rpc_of_unit () = Null 187 | let rpc_of_char x = Int (Int64.of_int (Char.code x)) 188 | 189 | let int64_of_rpc = function 190 | | Int i -> i 191 | | String s -> Int64.of_string s 192 | | x -> failwith (Printf.sprintf "Expected int64, got '%s'" (to_string x)) 193 | 194 | 195 | let int32_of_rpc = function 196 | | Int i -> Int64.to_int32 i 197 | | String s -> Int32.of_string s 198 | | x -> failwith (Printf.sprintf "Expected int32, got '%s'" (to_string x)) 199 | 200 | 201 | let int_of_rpc = function 202 | | Int i -> Int64.to_int i 203 | | String s -> int_of_string s 204 | | x -> failwith (Printf.sprintf "Expected int, got '%s'" (to_string x)) 205 | 206 | 207 | let bool_of_rpc = function 208 | | Bool b -> b 209 | | x -> failwith (Printf.sprintf "Expected bool, got '%s'" (to_string x)) 210 | 211 | 212 | let float_of_rpc = function 213 | | Float f -> f 214 | | Int i -> Int64.to_float i 215 | | Int32 i -> Int32.to_float i 216 | | String s -> float_of_string s 217 | | x -> failwith (Printf.sprintf "Expected float, got '%s'" (to_string x)) 218 | 219 | 220 | let string_of_rpc = function 221 | | String s -> s 222 | | x -> failwith (Printf.sprintf "Expected string, got '%s'" (to_string x)) 223 | 224 | 225 | let dateTime_of_rpc = function 226 | | DateTime s -> s 227 | | x -> failwith (Printf.sprintf "Expected DateTime, got '%s'" (to_string x)) 228 | 229 | 230 | let base64_of_rpc = function 231 | | Base64 s -> Base64.decode_exn s 232 | | x -> failwith (Printf.sprintf "Expected base64, got '%s'" (to_string x)) 233 | 234 | 235 | let unit_of_rpc = function 236 | | Null -> () 237 | | x -> failwith (Printf.sprintf "Expected unit, got '%s'" (to_string x)) 238 | 239 | 240 | let char_of_rpc x = 241 | let x = int_of_rpc x in 242 | if x < 0 || x > 255 243 | then failwith (Printf.sprintf "Char out of range (%d)" x) 244 | else Char.chr x 245 | 246 | 247 | let t_of_rpc t = t 248 | 249 | let lowerfn = function 250 | | String s -> String (String.lowercase_ascii s) 251 | | Enum (String s :: ss) -> Enum (String (String.lowercase_ascii s) :: ss) 252 | | x -> x 253 | 254 | 255 | module ResultUnmarshallers = struct 256 | open Rresult 257 | 258 | let int64_of_rpc = function 259 | | Int i -> R.ok i 260 | | String s -> 261 | (try R.ok (Int64.of_string s) with 262 | | _ -> R.error_msg (Printf.sprintf "Expected int64, got string '%s'" s)) 263 | | x -> R.error_msg (Printf.sprintf "Expected int64, got '%s'" (to_string x)) 264 | 265 | 266 | let int32_of_rpc = function 267 | | Int i -> R.ok (Int64.to_int32 i) 268 | | String s -> 269 | (try R.ok (Int32.of_string s) with 270 | | _ -> R.error_msg (Printf.sprintf "Expected int32, got string '%s'" s)) 271 | | x -> R.error_msg (Printf.sprintf "Expected int32, got '%s'" (to_string x)) 272 | 273 | 274 | let int_of_rpc = function 275 | | Int i -> R.ok (Int64.to_int i) 276 | | String s -> 277 | (try R.ok (int_of_string s) with 278 | | _ -> R.error_msg (Printf.sprintf "Expected int, got string '%s'" s)) 279 | | x -> R.error_msg (Printf.sprintf "Expected int, got '%s'" (to_string x)) 280 | 281 | 282 | let bool_of_rpc = function 283 | | Bool b -> R.ok b 284 | | x -> R.error_msg (Printf.sprintf "Expected bool, got '%s'" (to_string x)) 285 | 286 | 287 | let float_of_rpc = function 288 | | Float f -> R.ok f 289 | | Int i -> R.ok (Int64.to_float i) 290 | | Int32 i -> R.ok (Int32.to_float i) 291 | | String s -> 292 | (try R.ok (float_of_string s) with 293 | | _ -> R.error_msg (Printf.sprintf "Expected float, got string '%s'" s)) 294 | | x -> R.error_msg (Printf.sprintf "Expected float, got '%s'" (to_string x)) 295 | 296 | 297 | let string_of_rpc = function 298 | | String s -> R.ok s 299 | | x -> R.error_msg (Printf.sprintf "Expected string, got '%s'" (to_string x)) 300 | 301 | 302 | let dateTime_of_rpc = function 303 | | DateTime s -> R.ok s 304 | | x -> R.error_msg (Printf.sprintf "Expected DateTime, got '%s'" (to_string x)) 305 | 306 | 307 | let base64_of_rpc = function 308 | | Base64 s -> R.ok s 309 | | x -> R.error_msg (Printf.sprintf "Expected base64, got '%s'" (to_string x)) 310 | 311 | 312 | let unit_of_rpc = function 313 | | Null -> R.ok () 314 | | x -> R.error_msg (Printf.sprintf "Expected unit, got '%s'" (to_string x)) 315 | 316 | 317 | let char_of_rpc x = 318 | Rresult.R.bind (int_of_rpc x) (fun x -> 319 | if x < 0 || x > 255 320 | then R.error_msg (Printf.sprintf "Char out of range (%d)" x) 321 | else R.ok (Char.chr x)) 322 | 323 | 324 | let t_of_rpc t = R.ok t 325 | end 326 | 327 | let struct_extend rpc default_rpc = 328 | match rpc, default_rpc with 329 | | Dict real, Dict default_fields -> 330 | Dict 331 | (List.fold_left 332 | (fun real (f, default) -> 333 | if List.mem_assoc f real then real else (f, default) :: real) 334 | real 335 | default_fields) 336 | | _, _ -> rpc 337 | 338 | 339 | type callback = string list -> t -> unit 340 | 341 | type call = 342 | { name : string 343 | ; params : t list 344 | ; is_notification : bool 345 | } 346 | 347 | let call name params = { name; params; is_notification = false } 348 | let notification name params = { name; params; is_notification = true } 349 | 350 | let string_of_call call = 351 | Printf.sprintf 352 | "-> %s(%s)" 353 | call.name 354 | (String.concat "," (List.map to_string call.params)) 355 | 356 | 357 | type response = 358 | { success : bool 359 | ; contents : t 360 | ; is_notification : bool 361 | } 362 | 363 | let string_of_response response = 364 | Printf.sprintf 365 | "<- %s(%s)" 366 | (if response.success then "success" else "failure") 367 | (to_string response.contents) 368 | 369 | 370 | (* is_notification is to be set as true only if the call was a notification *) 371 | 372 | let success v = { success = true; contents = v; is_notification = false } 373 | let failure v = { success = false; contents = v; is_notification = false } 374 | -------------------------------------------------------------------------------- /src/lib/rpc.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006-2009 Citrix Systems Inc. 3 | * Copyright (c) 2006-2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** {2 Value} *) 19 | 20 | type t = 21 | | Int of int64 22 | | Int32 of int32 23 | | Bool of bool 24 | | Float of float 25 | | String of string 26 | | DateTime of string 27 | | Enum of t list 28 | | Dict of (string * t) list 29 | | Base64 of string 30 | | Null 31 | 32 | val to_string : t -> string 33 | 34 | module Version : sig 35 | type t = int * int * int 36 | 37 | val compare : t -> t -> int 38 | end 39 | 40 | (** {2 Type declarations} *) 41 | module Types : sig 42 | type _ basic = 43 | | Int : int basic 44 | | Int32 : int32 basic 45 | | Int64 : int64 basic 46 | | Bool : bool basic 47 | | Float : float basic 48 | | String : string basic 49 | | Char : char basic 50 | 51 | type _ typ = 52 | | Basic : 'a basic -> 'a typ 53 | | DateTime : string typ 54 | | Base64 : string typ 55 | | Array : 'a typ -> 'a array typ 56 | | List : 'a typ -> 'a list typ 57 | | Dict : 'a basic * 'b typ -> ('a * 'b) list typ 58 | | Unit : unit typ 59 | | Option : 'a typ -> 'a option typ 60 | | Tuple : 'a typ * 'b typ -> ('a * 'b) typ 61 | | Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ 62 | | Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ 63 | | Struct : 'a structure -> 'a typ 64 | | Variant : 'a variant -> 'a typ 65 | | Abstract : 'a abstract -> 'a typ 66 | 67 | and 'a def = 68 | { name : string 69 | ; description : string list 70 | ; ty : 'a typ 71 | } 72 | 73 | and boxed_def = BoxedDef : 'a def -> boxed_def 74 | 75 | and ('a, 's) field = 76 | { fname : string 77 | ; fdescription : string list 78 | ; fversion : Version.t option 79 | ; field : 'a typ 80 | ; fdefault : 'a option 81 | ; fget : 's -> 'a 82 | ; fset : 'a -> 's -> 's 83 | } 84 | 85 | and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field 86 | 87 | and field_getter = 88 | { field_get : 'a. string -> 'a typ -> ('a, Rresult.R.msg) Result.t } 89 | 90 | and 'a structure = 91 | { sname : string 92 | ; fields : 'a boxed_field list 93 | ; version : Version.t option 94 | ; constructor : field_getter -> ('a, Rresult.R.msg) Result.t 95 | } 96 | 97 | and ('a, 's) tag = 98 | { tname : string 99 | ; tdescription : string list 100 | ; tversion : Version.t option 101 | ; tcontents : 'a typ 102 | ; tpreview : 's -> 'a option 103 | ; (* Prism *) 104 | treview : 'a -> 's 105 | } 106 | 107 | and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag 108 | 109 | and tag_getter = { tget : 'a. 'a typ -> ('a, Rresult.R.msg) Result.t } 110 | 111 | and 'a variant = 112 | { vname : string 113 | ; variants : 'a boxed_tag list 114 | ; vdefault : 'a option 115 | ; vversion : Version.t option 116 | ; vconstructor : string -> tag_getter -> ('a, Rresult.R.msg) Result.t 117 | } 118 | 119 | and 'a abstract = 120 | { aname : string 121 | ; test_data : 'a list 122 | ; rpc_of : 'a -> t 123 | ; of_rpc : t -> ('a, Rresult.R.msg) Result.t 124 | } 125 | 126 | val int : int def 127 | val int32 : int32 def 128 | val int64 : int64 def 129 | val bool : bool def 130 | val float : float def 131 | val string : string def 132 | val char : char def 133 | val unit : unit def 134 | val default_types : boxed_def list 135 | end 136 | 137 | (** {2 Basic constructors} *) 138 | 139 | val rpc_of_int64 : int64 -> t 140 | val rpc_of_int32 : int32 -> t 141 | val rpc_of_int : int -> t 142 | val rpc_of_bool : bool -> t 143 | val rpc_of_float : float -> t 144 | val rpc_of_string : string -> t 145 | val rpc_of_dateTime : string -> t 146 | val rpc_of_base64 : string -> t 147 | val rpc_of_t : t -> t 148 | val rpc_of_unit : unit -> t 149 | val rpc_of_char : char -> t 150 | val int64_of_rpc : t -> int64 151 | val int32_of_rpc : t -> int32 152 | val int_of_rpc : t -> int 153 | val bool_of_rpc : t -> bool 154 | val float_of_rpc : t -> float 155 | val string_of_rpc : t -> string 156 | val dateTime_of_rpc : t -> string 157 | val base64_of_rpc : t -> string 158 | val t_of_rpc : t -> t 159 | val char_of_rpc : t -> char 160 | val unit_of_rpc : t -> unit 161 | 162 | module ResultUnmarshallers : sig 163 | val int64_of_rpc : t -> (int64, Rresult.R.msg) Result.t 164 | val int32_of_rpc : t -> (int32, Rresult.R.msg) Result.t 165 | val int_of_rpc : t -> (int, Rresult.R.msg) Result.t 166 | val bool_of_rpc : t -> (bool, Rresult.R.msg) Result.t 167 | val float_of_rpc : t -> (float, Rresult.R.msg) Result.t 168 | val string_of_rpc : t -> (string, Rresult.R.msg) Result.t 169 | val dateTime_of_rpc : t -> (string, Rresult.R.msg) Result.t 170 | val base64_of_rpc : t -> (string, Rresult.R.msg) Result.t 171 | val t_of_rpc : t -> (t, Rresult.R.msg) Result.t 172 | val unit_of_rpc : t -> (unit, Rresult.R.msg) Result.t 173 | val char_of_rpc : t -> (char, Rresult.R.msg) Result.t 174 | end 175 | 176 | (** {2 Calls} *) 177 | 178 | type callback = string list -> t -> unit 179 | 180 | type call = 181 | { name : string 182 | ; params : t list 183 | ; is_notification : bool 184 | } 185 | 186 | val call : string -> t list -> call 187 | val notification : string -> t list -> call 188 | val string_of_call : call -> string 189 | 190 | (** {2 Responses} *) 191 | 192 | type response = 193 | { success : bool 194 | ; contents : t 195 | ; is_notification : bool 196 | } 197 | 198 | val string_of_response : response -> string 199 | val success : t -> response 200 | val failure : t -> response 201 | 202 | (** {2 Run-time errors} *) 203 | 204 | exception Runtime_error of string * t 205 | exception Runtime_exception of string * string 206 | 207 | (** {2 Debug options} *) 208 | val set_debug : bool -> unit 209 | 210 | val get_debug : unit -> bool 211 | 212 | (** Helper *) 213 | val lowerfn : t -> t 214 | 215 | (** [struct_extend rpc1 rpc2] first checks that [rpc1] and [rpc2] are both 216 | * dictionaries. If this is the case then [struct_extend] will create a new 217 | * [Rpc.t] which contains all key-value pairs from [rpc1], as well as all 218 | * key-value pairs from [rpc2] for which the key does not exist in [rpc1]. *) 219 | val struct_extend : t -> t -> t 220 | -------------------------------------------------------------------------------- /src/lib/rpc_client.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006-2009 Citrix Systems Inc. 3 | * Copyright (c) 2006-2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | type content_type = 19 | [ `XML 20 | | `JSON 21 | ] 22 | 23 | val string_of_content_type : content_type -> string 24 | val content_type_of_string : string -> content_type 25 | 26 | val do_rpc 27 | : content_type:content_type 28 | -> host:string 29 | -> port:int 30 | -> path:string 31 | -> Rpc.call 32 | -> Rpc.response 33 | 34 | val do_rpc_unix 35 | : content_type:content_type 36 | -> filename:string 37 | -> path:string 38 | -> Rpc.call 39 | -> Rpc.response 40 | -------------------------------------------------------------------------------- /src/lib/rpc_empty_module.ml: -------------------------------------------------------------------------------- 1 | (* THe clang toolchain doesn't like archives with no elements, 2 | * see https://github.com/mirage/ocaml-rpc/issues/44 3 | *) 4 | -------------------------------------------------------------------------------- /src/lib/rpc_genfake.ml: -------------------------------------------------------------------------------- 1 | (* Generate typed values *) 2 | 3 | open Rpc.Types 4 | 5 | type err = [ `Msg of string ] 6 | 7 | let badstuff msg = failwith (Printf.sprintf "Failed to construct the record: %s" msg) 8 | 9 | module SeenType = struct 10 | type t = T : _ typ -> t 11 | let compare a b = if a == b then 0 else Stdlib.compare a b 12 | end 13 | 14 | module Seen = Set.Make(SeenType) 15 | 16 | let rec gentest : type a. Seen.t -> a typ -> a Seq.t = 17 | fun seen t -> 18 | let seen_t = SeenType.T t in 19 | if Seen.mem seen_t seen then Seq.empty 20 | else 21 | let gentest t = gentest (Seen.add seen_t seen) t in 22 | match t with 23 | | Basic Int -> [ 0; 1; max_int; -1; 1000000 ] |> List.to_seq 24 | | Basic Int32 -> [ 0l; 1l; Int32.max_int; -1l; 999999l ] |> List.to_seq 25 | | Basic Int64 -> [ 0L; 1L; Int64.max_int; -1L; 999999999999L ] |> List.to_seq 26 | | Basic Bool -> [ true; false ] |> List.to_seq 27 | | Basic Float -> [ 0.0; max_float; min_float; -1.0 ] |> List.to_seq 28 | | Basic String -> 29 | [ "Test string" 30 | ; "" 31 | ; "ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ \ 32 | ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ" 33 | ; "\000foo" 34 | ] |> List.to_seq 35 | | Basic Char -> [ '\000'; 'a'; 'z'; '\255' ] |> List.to_seq 36 | | DateTime -> [ "19700101T00:00:00Z" ] |> List.to_seq 37 | | Base64 -> [ "SGVsbG8sIHdvcmxkIQ==" (* "Hello, world!" *) ] |> List.to_seq 38 | | Array typ -> [ gentest typ |> Array.of_seq; [||] ] |> List.to_seq 39 | | List typ -> [ gentest typ |> List.of_seq; [] ] |> List.to_seq 40 | | Dict (basic, typ) -> 41 | let keys = gentest (Basic basic) in 42 | let vs = Seq.cycle (gentest typ) in 43 | let x = Seq.map2 (fun k v -> k, v) keys vs |> List.of_seq in 44 | Seq.return x 45 | | Unit -> Seq.return () 46 | | Option t -> 47 | let vs = gentest t in 48 | Seq.(append (return None) @@ map (fun x -> Some x) vs) 49 | | Tuple (t1, t2) -> 50 | let v1s = gentest t1 in 51 | let v2s = gentest t2 in 52 | Seq.product v1s v2s 53 | | Tuple3 (t1, t2, t3) -> 54 | let v1s = gentest t1 in 55 | let v2s = gentest t2 in 56 | let v3s = gentest t3 in 57 | Seq.(product (product v1s v2s) v3s |> map (fun ((x,y),z) -> x,y,z)) 58 | | Tuple4 (t1, t2, t3, t4) -> 59 | let v1s = gentest t1 in 60 | let v2s = gentest t2 in 61 | let v3s = gentest t3 in 62 | let v4s = gentest t4 in 63 | Seq.(product (product v1s v2s) (product v3s v4s) |> map (fun ((x,y),(z,t)) -> x,y,z,t)) 64 | | Struct { constructor; _ } -> 65 | let gen _ = 66 | let field_get : type a. string -> a typ -> (a, Rresult.R.msg) Result.t = 67 | fun _ ty -> 68 | let vs = gentest ty |> Array.of_seq in 69 | Result.Ok (vs.(Random.int (Array.length vs))) 70 | in 71 | (match constructor { field_get } with 72 | | Result.Ok x -> x 73 | | Result.Error (`Msg y) -> badstuff y) 74 | in 75 | Seq.ints 0 |> Seq.take 10 |> Seq.map gen 76 | | Variant { variants; _ } -> 77 | variants |> List.to_seq |> Seq.map 78 | (function 79 | | Rpc.Types.BoxedTag v -> 80 | let contents = gentest v.tcontents |> Array.of_seq in 81 | let content = contents.(Random.int (Array.length contents)) in 82 | v.treview content) 83 | | Abstract { test_data; _ } -> test_data |> List.to_seq 84 | 85 | let rec genall: type a. maxcomb:int -> Seen.t -> int -> string -> a typ -> a Seq.t = 86 | fun ~maxcomb seen depth strhint t -> 87 | let thin d result = 88 | if d < 0 then Seq.take 1 result else Seq.take maxcomb result 89 | in 90 | let seen_t = SeenType.T t in 91 | if Seen.mem seen_t seen then Seq.empty 92 | else 93 | let genall depth strhint t = genall ~maxcomb (Seen.add seen_t seen) depth strhint t in 94 | match t with 95 | | Basic Int -> Seq.return 0 96 | | Basic Int32 -> Seq.return 0l 97 | | Basic Int64 -> Seq.return 0L 98 | | Basic Bool -> thin depth (List.to_seq [ true; false ]) 99 | | Basic Float -> Seq.return 0.0 100 | | Basic String -> Seq.return strhint 101 | | Basic Char -> Seq.return 'a' 102 | | DateTime -> Seq.return "19700101T00:00:00Z" 103 | | Base64 -> Seq.return "SGVsbG8sIHdvcmxkIQ==" (* "Hello, world!" *) 104 | | Array typ -> thin depth ([ genall (depth - 1) strhint typ |> Array.of_seq; [||] ] |> List.to_seq) 105 | | List typ -> thin depth ([ genall (depth - 1) strhint typ |> List.of_seq; [] ] |> List.to_seq) 106 | | Dict (basic, typ) -> 107 | let keys = genall (depth - 1) strhint (Basic basic) in 108 | let vs = genall (depth - 1) strhint typ in 109 | Seq.product keys vs |> Seq.map (fun x -> [x]) |> thin depth 110 | | Unit -> Seq.return () 111 | | Option t -> 112 | let vs = genall (depth - 1) strhint t in 113 | thin depth Seq.(append (map (fun x -> Some x) vs) @@ return None ) 114 | | Tuple (t1, t2) -> 115 | let v1s = genall (depth - 1) strhint t1 in 116 | let v2s = genall (depth - 1) strhint t2 in 117 | Seq.product v1s v2s |> thin depth 118 | | Tuple3 (t1, t2, t3) -> 119 | let v1s = genall (depth - 1) strhint t1 in 120 | let v2s = genall (depth - 1) strhint t2 in 121 | let v3s = genall (depth - 1) strhint t3 in 122 | Seq.(product (product v1s v2s) v3s |> map (fun ((x,y),z) -> x,y,z)) 123 | | Tuple4 (t1, t2, t3, t4) -> 124 | let v1s = genall (depth - 1) strhint t1 in 125 | let v2s = genall (depth - 1) strhint t2 in 126 | let v3s = genall (depth - 1) strhint t3 in 127 | let v4s = genall (depth - 1) strhint t4 in 128 | Seq.(product (product v1s v2s) (product v3s v4s) |> map (fun ((x,y),(z,t)) -> x,y,z,t)) 129 | | Struct { constructor; fields; _ } -> 130 | let fields_maxes = 131 | fields 132 | |> List.to_seq 133 | |> 134 | Seq.map 135 | (function 136 | | BoxedField f -> 137 | let n = Seq.length (genall (depth - 1) strhint f.field) in 138 | f.fname, n) 139 | in 140 | let all_combinations = 141 | Seq.fold_left 142 | (fun acc (f, max) -> 143 | Seq.ints 1 |> Seq.take max |> Seq.flat_map @@ fun i -> 144 | Seq.map (fun dict -> (f, i - 1) :: dict) acc 145 | ) 146 | (Seq.return [] ) 147 | fields_maxes 148 | in 149 | Seq.map 150 | (fun combination -> 151 | let field_get : type a. string -> a typ -> (a, Rresult.R.msg) Result.t = 152 | fun fname ty -> 153 | let n = List.assoc fname combination in 154 | let vs = genall (depth - 1) fname ty |> Array.of_seq in 155 | Result.Ok (vs.(n)) 156 | in 157 | match constructor { field_get } with 158 | | Result.Ok x -> x 159 | | Result.Error (`Msg y) -> badstuff y) 160 | all_combinations 161 | |> thin depth 162 | | Variant { variants; _ } -> 163 | variants 164 | |> List.to_seq 165 | |> Seq.flat_map 166 | (function 167 | | Rpc.Types.BoxedTag v -> 168 | let contents = genall (depth - 1) strhint v.tcontents in 169 | Seq.map (fun content -> v.treview content) contents) 170 | |> thin depth 171 | | Abstract { test_data; _ } -> test_data |> List.to_seq 172 | 173 | 174 | (* don't use this on recursive types! *) 175 | 176 | let rec gen_nice : type a. a typ -> string -> a = 177 | fun ty hint -> 178 | let narg n = Printf.sprintf "%s_%d" hint n in 179 | match ty with 180 | | Basic Int -> 0 181 | | Basic Int32 -> 0l 182 | | Basic Int64 -> 0L 183 | | Basic Bool -> true 184 | | Basic Float -> 0.0 185 | | Basic String -> hint 186 | | Basic Char -> 'a' 187 | | DateTime -> "19700101T00:00:00Z" 188 | | Base64 -> "SGVsbG8sIHdvcmxkIQ==" (* "Hello, world!" *) 189 | | Array typ -> [| gen_nice typ (narg 1); gen_nice typ (narg 2) |] 190 | | List (Tuple (Basic String, typ)) -> 191 | [ "field_1", gen_nice typ "value_1"; "field_2", gen_nice typ "value_2" ] 192 | | List typ -> [ gen_nice typ (narg 1); gen_nice typ (narg 2) ] 193 | | Dict (String, typ) -> 194 | [ "field_1", gen_nice typ "value_1"; "field_2", gen_nice typ "value_2" ] 195 | | Dict (basic, typ) -> 196 | [ gen_nice (Basic basic) "field_1", gen_nice typ (narg 1) 197 | ; gen_nice (Basic basic) "field_2", gen_nice typ (narg 2) 198 | ] 199 | | Unit -> () 200 | | Option ty -> Some (gen_nice ty (Printf.sprintf "optional_%s" hint)) 201 | | Tuple (x, y) -> gen_nice x (narg 1), gen_nice y (narg 2) 202 | | Tuple3 (x, y, z) -> gen_nice x (narg 1), gen_nice y (narg 2), gen_nice z (narg 3) 203 | | Tuple4 (x, y, z, a) -> 204 | gen_nice x (narg 1), gen_nice y (narg 2), gen_nice z (narg 3), gen_nice a (narg 4) 205 | | Struct { constructor; _ } -> 206 | let field_get : type a. string -> a typ -> (a, Rresult.R.msg) Result.t = 207 | fun name ty -> Result.Ok (gen_nice ty name) 208 | in 209 | (match constructor { field_get } with 210 | | Result.Ok x -> x 211 | | Result.Error (`Msg y) -> badstuff y) 212 | | Variant { variants; _ } -> 213 | List.hd variants 214 | |> (function 215 | | Rpc.Types.BoxedTag v -> 216 | let content = gen_nice v.tcontents v.tname in 217 | v.treview content) 218 | | Abstract { test_data; _ } -> List.hd test_data 219 | 220 | (** don't use this on recursive types! *) 221 | let gentest t = gentest Seen.empty t |> List.of_seq 222 | let genall ?(maxcomb=Sys.max_array_length) depth strhint t = genall ~maxcomb Seen.empty depth strhint t |> List.of_seq 223 | -------------------------------------------------------------------------------- /src/lib/rpclib.ml: -------------------------------------------------------------------------------- 1 | module Rpclib = Xmlrpc 2 | -------------------------------------------------------------------------------- /src/lib/rpcmarshal.ml: -------------------------------------------------------------------------------- 1 | (* Basic type definitions *) 2 | open Rpc.Types 3 | 4 | type err = [ `Msg of string ] 5 | 6 | let tailrec_map f l = List.rev_map f l |> List.rev 7 | 8 | let rec unmarshal : type a. a typ -> Rpc.t -> (a, err) Result.t = 9 | fun t v -> 10 | let open Rpc in 11 | let open Result in 12 | let open Rresult.R in 13 | let open Rpc.ResultUnmarshallers in 14 | let list_helper typ l = 15 | List.fold_left 16 | (fun acc v -> 17 | match acc, unmarshal typ v with 18 | | Ok a, Ok v -> Ok (v :: a) 19 | | _, Error (`Msg s) -> 20 | Error 21 | (Rresult.R.msg 22 | (Printf.sprintf 23 | "Failed to unmarshal array: %s (when unmarshalling: %s)" 24 | s 25 | (Rpc.to_string v))) 26 | | x, _ -> x) 27 | (Ok []) 28 | l 29 | >>| List.rev 30 | in 31 | match t with 32 | | Basic Int -> int_of_rpc v 33 | | Basic Int32 -> int32_of_rpc v 34 | | Basic Int64 -> int64_of_rpc v 35 | | Basic Bool -> bool_of_rpc v 36 | | Basic Float -> float_of_rpc v 37 | | Basic String -> string_of_rpc v 38 | | Basic Char -> int_of_rpc v >>| Char.chr 39 | | DateTime -> dateTime_of_rpc v 40 | | Base64 -> base64_of_rpc v 41 | | Array typ -> 42 | (match v with 43 | | Enum xs -> list_helper typ xs >>| Array.of_list 44 | | _ -> Rresult.R.error_msg "Expecting Array") 45 | | List (Tuple (Basic String, typ)) -> 46 | (match v with 47 | | Dict xs -> 48 | let keys = tailrec_map fst xs in 49 | let vs = tailrec_map snd xs in 50 | list_helper typ vs >>= fun vs -> return (List.combine keys vs) 51 | | _ -> Rresult.R.error_msg "Unhandled") 52 | | Dict (basic, typ) -> 53 | (match v with 54 | | Dict xs -> 55 | (match basic with 56 | | String -> 57 | let keys = tailrec_map fst xs in 58 | let vs = tailrec_map snd xs in 59 | list_helper typ vs >>= fun vs -> return (List.combine keys vs) 60 | | _ -> Rresult.R.error_msg "Expecting something other than a Dict type") 61 | | _ -> Rresult.R.error_msg "Unhandled") 62 | | List typ -> 63 | (match v with 64 | | Enum xs -> list_helper typ xs 65 | | _ -> Rresult.R.error_msg "Expecting array") 66 | | Unit -> unit_of_rpc v 67 | | Option t -> 68 | (match v with 69 | | Enum [ x ] -> unmarshal t x >>= fun x -> return (Some x) 70 | | Enum [] -> return None 71 | | y -> 72 | Rresult.R.error_msg 73 | (Printf.sprintf "Expecting an Enum value, got '%s'" (Rpc.to_string y))) 74 | | Tuple (t1, t2) -> 75 | (match v, t2 with 76 | | Rpc.Enum list, Tuple (_, _) -> 77 | unmarshal t1 (List.hd list) 78 | >>= fun v1 -> unmarshal t2 (Rpc.Enum (List.tl list)) >>= fun v2 -> Ok (v1, v2) 79 | | Rpc.Enum [ x; y ], _ -> 80 | unmarshal t1 x >>= fun v1 -> unmarshal t2 y >>= fun v2 -> Ok (v1, v2) 81 | | Rpc.Enum _, _ -> Rresult.R.error_msg "Too many items in a tuple!" 82 | | _, _ -> error_msg "Expecting Rpc.Enum when unmarshalling a tuple") 83 | | Tuple3 (t1, t2, t3) -> 84 | (match v with 85 | | Rpc.Enum [ x; y; z ] -> 86 | unmarshal t1 x 87 | >>= fun v1 -> 88 | unmarshal t2 y >>= fun v2 -> unmarshal t3 z >>= fun v3 -> Ok (v1, v2, v3) 89 | | Rpc.Enum _ -> 90 | Rresult.R.error_msg "Expecting precisely 3 items when unmarshalling a Tuple3" 91 | | _ -> error_msg "Expecting Rpc.Enum when unmarshalling a tuple3") 92 | | Tuple4 (t1, t2, t3, t4) -> 93 | (match v with 94 | | Rpc.Enum [ x; y; z; a ] -> 95 | unmarshal t1 x 96 | >>= fun v1 -> 97 | unmarshal t2 y 98 | >>= fun v2 -> 99 | unmarshal t3 z >>= fun v3 -> unmarshal t4 a >>= fun v4 -> Ok (v1, v2, v3, v4) 100 | | Rpc.Enum _ -> 101 | Rresult.R.error_msg 102 | "Expecting precisely 4 items in an Enum when unmarshalling a Tuple4" 103 | | _ -> error_msg "Expecting Rpc.Enum when unmarshalling a tuple4") 104 | | Struct { constructor; sname; _ } -> 105 | (match v with 106 | | Rpc.Dict keys' -> 107 | let keys = List.map (fun (s, v) -> String.lowercase_ascii s, v) keys' in 108 | constructor 109 | { field_get = 110 | (let x : type a. string -> a typ -> (a, Rresult.R.msg) Result.t = 111 | fun s ty -> 112 | let s = String.lowercase_ascii s in 113 | match ty with 114 | | Option x -> 115 | (try List.assoc s keys |> unmarshal x >>= fun o -> return (Some o) with 116 | | _ -> return None) 117 | | y -> 118 | (try List.assoc s keys |> unmarshal y with 119 | | Not_found -> 120 | error_msg 121 | (Printf.sprintf 122 | "No value found for key: '%s' when unmarshalling '%s'" 123 | s 124 | sname)) 125 | in 126 | x) 127 | } 128 | | _ -> error_msg (Printf.sprintf "Expecting Rpc.Dict when unmarshalling a '%s'" sname)) 129 | | Variant { vconstructor; _ } -> 130 | (match v with 131 | | Rpc.String name -> ok (name, Rpc.Null) 132 | | Rpc.Enum [ Rpc.String name; contents ] -> ok (name, contents) 133 | | _ -> error_msg "Expecting String or Enum when unmarshalling a variant") 134 | >>= fun (name, contents) -> 135 | let constr = { tget = (fun typ -> unmarshal typ contents) } in 136 | vconstructor name constr 137 | | Abstract { of_rpc; _ } -> of_rpc v 138 | 139 | 140 | let rec marshal : type a. a typ -> a -> Rpc.t = 141 | fun t v -> 142 | let open Rpc in 143 | let rpc_of_basic : type a. a basic -> a -> Rpc.t = 144 | fun t v -> 145 | match t with 146 | | Int -> rpc_of_int v 147 | | Int32 -> rpc_of_int32 v 148 | | Int64 -> rpc_of_int64 v 149 | | Bool -> rpc_of_bool v 150 | | Float -> rpc_of_float v 151 | | String -> rpc_of_string v 152 | | Char -> rpc_of_int (Char.code v) 153 | in 154 | match t with 155 | | Basic t -> rpc_of_basic t v 156 | | DateTime -> rpc_of_dateTime v 157 | | Base64 -> rpc_of_base64 v 158 | | Array typ -> Enum (tailrec_map (marshal typ) (Array.to_list v)) 159 | | List (Tuple (Basic String, typ)) -> 160 | Dict (tailrec_map (fun (x, y) -> x, marshal typ y) v) 161 | | List typ -> Enum (tailrec_map (marshal typ) v) 162 | | Dict (String, typ) -> Rpc.Dict (tailrec_map (fun (k, v) -> k, marshal typ v) v) 163 | | Dict (basic, typ) -> 164 | Rpc.Enum 165 | (tailrec_map (fun (k, v) -> Rpc.Enum [ rpc_of_basic basic k; marshal typ v ]) v) 166 | | Unit -> rpc_of_unit v 167 | | Option ty -> 168 | Rpc.Enum 169 | (match v with 170 | | Some x -> [ marshal ty x ] 171 | | None -> []) 172 | | Tuple (x, (Tuple (_, _) as y)) -> 173 | (match marshal y (snd v) with 174 | | Rpc.Enum xs -> Rpc.Enum (marshal x (fst v) :: xs) 175 | | _ -> failwith "Marshalling a tuple should always give an Enum") 176 | | Tuple (x, y) -> Rpc.Enum [ marshal x (fst v); marshal y (snd v) ] 177 | | Tuple3 (x, y, z) -> 178 | let vx, vy, vz = v in 179 | Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz ] 180 | | Tuple4 (x, y, z, a) -> 181 | let vx, vy, vz, va = v in 182 | Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz; marshal a va ] 183 | | Struct { fields; _ } -> 184 | let fields = 185 | List.fold_left 186 | (fun acc f -> 187 | match f with 188 | | BoxedField f -> 189 | let value = marshal f.field (f.fget v) in 190 | (match f.field, value with 191 | | Option _, Rpc.Enum [] -> acc 192 | | Option _, Rpc.Enum [ x ] -> (f.fname, x) :: acc 193 | | _, _ -> (f.fname, value) :: acc)) 194 | [] 195 | fields 196 | in 197 | Rpc.Dict fields 198 | | Variant { variants; _ } -> 199 | List.fold_left 200 | (fun acc t -> 201 | match t with 202 | | BoxedTag t -> 203 | (match t.tpreview v with 204 | | Some x -> 205 | (match marshal t.tcontents x with 206 | | Rpc.Null -> Rpc.String t.tname 207 | | y -> Rpc.Enum [ Rpc.String t.tname; y ]) 208 | | None -> acc)) 209 | Rpc.Null 210 | variants 211 | | Abstract { rpc_of; _ } -> rpc_of v 212 | 213 | 214 | let ocaml_of_basic : type a. a basic -> string = function 215 | | Int64 -> "int64" 216 | | Int32 -> "int32" 217 | | Int -> "int" 218 | | String -> "string" 219 | | Float -> "float" 220 | | Bool -> "bool" 221 | | Char -> "char" 222 | 223 | 224 | let rec ocaml_of_t : type a. a typ -> string = function 225 | | Basic b -> ocaml_of_basic b 226 | | DateTime -> "string" 227 | | Base64 -> "base64" 228 | | Array t -> ocaml_of_t t ^ " list" 229 | | List t -> ocaml_of_t t ^ " list" 230 | | Dict (b, t) -> Printf.sprintf "(%s * %s) list" (ocaml_of_basic b) (ocaml_of_t t) 231 | | Unit -> "unit" 232 | | Option t -> ocaml_of_t t ^ " option" 233 | | Tuple (a, b) -> Printf.sprintf "(%s * %s)" (ocaml_of_t a) (ocaml_of_t b) 234 | | Tuple3 (a, b, c) -> 235 | Printf.sprintf "(%s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b) (ocaml_of_t c) 236 | | Tuple4 (a, b, c, d) -> 237 | Printf.sprintf 238 | "(%s * %s * %s * %s)" 239 | (ocaml_of_t a) 240 | (ocaml_of_t b) 241 | (ocaml_of_t c) 242 | (ocaml_of_t d) 243 | | Struct { fields; _ } -> 244 | let fields = 245 | List.map 246 | (function 247 | | BoxedField f -> Printf.sprintf "%s: %s;" f.fname (ocaml_of_t f.field)) 248 | fields 249 | in 250 | Printf.sprintf "{ %s }" (String.concat " " fields) 251 | | Variant { variants; _ } -> 252 | let tags = 253 | List.map 254 | (function 255 | | BoxedTag t -> 256 | Printf.sprintf 257 | "| %s (%s) (** %s *)" 258 | t.tname 259 | (ocaml_of_t t.tcontents) 260 | (String.concat " " t.tdescription)) 261 | variants 262 | in 263 | String.concat " " tags 264 | | Abstract _ -> "" 265 | -------------------------------------------------------------------------------- /src/lib/xmlrpc.mli: -------------------------------------------------------------------------------- 1 | val encode : string -> string 2 | val to_string : ?strict:bool -> Rpc.t -> string 3 | 4 | val to_a 5 | : ?strict:bool 6 | -> empty:(unit -> 'a) 7 | -> append:('a -> string -> unit) 8 | -> Rpc.t 9 | -> 'a 10 | [@@ocaml.deprecated] 11 | 12 | val string_of_call : ?strict:bool -> Rpc.call -> string 13 | val string_of_response : ?strict:bool -> Rpc.response -> string 14 | 15 | val a_of_response 16 | : ?strict:bool 17 | -> empty:(unit -> 'a) 18 | -> append:('a -> string -> unit) 19 | -> Rpc.response 20 | -> 'a 21 | [@@ocaml.deprecated] 22 | 23 | exception Parse_error of string * string * Xmlm.input 24 | 25 | (** The parsing functions make it possible to specify the routine used to 26 | decode base64 values. The default is to use [Base64.decode_exn] which 27 | strictly interprets the standard. A different function will be required if 28 | the XMLRPC server inserts line breaks into the base64 encoding (as per 29 | RFC2045). *) 30 | 31 | val pretty_string_of_error : string -> string -> Xmlm.input -> string 32 | val parse_error : string -> string -> Xmlm.input -> unit 33 | val of_string 34 | : ?callback:(string list -> Rpc.t -> unit) 35 | -> ?base64_decoder:(string -> string) 36 | -> string -> Rpc.t 37 | 38 | val of_a 39 | : ?callback:(string list -> Rpc.t -> unit) 40 | -> ?base64_decoder:(string -> string) 41 | -> next_char:('b -> char option) 42 | -> 'b 43 | -> Rpc.t 44 | [@@ocaml.deprecated] 45 | 46 | val call_of_string 47 | : ?callback:(string list -> Rpc.t -> unit) 48 | -> ?base64_decoder:(string -> string) 49 | -> string -> Rpc.call 50 | 51 | val response_of_fault 52 | : ?callback:(string list -> Rpc.t -> unit) 53 | -> ?base64_decoder:(string -> string) 54 | -> Xmlm.input 55 | -> Rpc.response 56 | 57 | val response_of_success 58 | : ?callback:(string list -> Rpc.t -> unit) 59 | -> ?base64_decoder:(string -> string) 60 | -> Xmlm.input 61 | -> Rpc.response 62 | 63 | val response_of_input 64 | : ?callback:(string list -> Rpc.t -> unit) 65 | -> ?base64_decoder:(string -> string) 66 | -> Xmlm.input 67 | -> Rpc.response 68 | 69 | val response_of_string 70 | : ?callback:(string list -> Rpc.t -> unit) 71 | -> ?base64_decoder:(string -> string) 72 | -> string 73 | -> Rpc.response 74 | 75 | val response_of_in_channel 76 | : ?callback:(string list -> Rpc.t -> unit) 77 | -> ?base64_decoder:(string -> string) 78 | -> in_channel 79 | -> Rpc.response 80 | -------------------------------------------------------------------------------- /src/lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name rpclib_lwt) 3 | (public_name rpclib-lwt) 4 | (modules rpc_lwt) 5 | (libraries lwt rpclib.core) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /src/lwt/rpc_lwt.ml: -------------------------------------------------------------------------------- 1 | module LwtIdl = Idl.Make (Lwt) 2 | include LwtIdl 3 | -------------------------------------------------------------------------------- /src/lwt/rpc_lwt.mli: -------------------------------------------------------------------------------- 1 | type client_implementation 2 | type server_implementation 3 | 4 | module T : sig 5 | type 'a box 6 | type ('a, 'b) resultb = ('a, 'b) Result.t box 7 | type rpcfn = Rpc.call -> Rpc.response Lwt.t 8 | 9 | val lift : ('a -> 'b Lwt.t) -> 'a -> 'b box 10 | val bind : 'a box -> ('a -> 'b Lwt.t) -> 'b box 11 | val return : 'a -> 'a box 12 | val get : 'a box -> 'a Lwt.t 13 | val ( !@ ) : 'a box -> 'a Lwt.t 14 | val put : 'a Lwt.t -> 'a box 15 | val ( ~@ ) : 'a Lwt.t -> 'a box 16 | end 17 | 18 | module ErrM : sig 19 | val return : 'a -> ('a, 'b) T.resultb 20 | val return_err : 'b -> ('a, 'b) T.resultb 21 | 22 | val checked_bind 23 | : ('a, 'b) T.resultb 24 | -> ('a -> ('c, 'd) T.resultb) 25 | -> ('b -> ('c, 'd) T.resultb) 26 | -> ('c, 'd) T.resultb 27 | 28 | val bind : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 29 | val ( >>= ) : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 30 | end 31 | 32 | (** Client generator similar to {!Idl.GenClient} that uses [Lwt]. *) 33 | module GenClient () : sig 34 | include 35 | Idl.RPC 36 | with type implementation = client_implementation 37 | and type 'a res = T.rpcfn -> 'a 38 | and type ('a, 'b) comp = ('a, 'b) T.resultb 39 | end 40 | 41 | (** Server generator similar to {!Idl.GenServer} that uses [Lwt]. *) 42 | module GenServer () : sig 43 | include 44 | Idl.RPC 45 | with type implementation = server_implementation 46 | and type 'a res = 'a -> unit 47 | and type ('a, 'b) comp = ('a, 'b) T.resultb 48 | end 49 | 50 | val server : server_implementation -> T.rpcfn 51 | val combine : server_implementation list -> server_implementation 52 | -------------------------------------------------------------------------------- /tests/async/client_server_test.ml: -------------------------------------------------------------------------------- 1 | (** This test verifies that the client and server functions generated by the 2 | IDL interoperate correctly *) 3 | 4 | let with_ok f = function 5 | | Ok r -> f r 6 | | Error _ -> Alcotest.fail "RPC call failed" 7 | 8 | 9 | let test_call_async () = 10 | let open Async in 11 | let server = 12 | let module Server = Test_common.Test_interface.Interface (Rpc_async.GenServer ()) in 13 | let open Rpc_async in 14 | Server.add (fun a b -> ErrM.return (a + b)); 15 | Server.sub (fun a b -> ErrM.return (a - b)); 16 | Server.mul (fun a b -> ErrM.return (a * b)); 17 | Server.div (fun a b -> ErrM.return (a / b)); 18 | Server.ping (fun () -> ErrM.return "OK"); 19 | Rpc_async.server Server.implementation 20 | in 21 | let rpc = server in 22 | let module Client = Test_common.Test_interface.Interface (Rpc_async.GenClient ()) in 23 | let run () = 24 | let open Rpc_async in 25 | (* TODO: Add this to the Transformer itself *) 26 | let ( >>>= ) x f = x |> T.get >>= f in 27 | Client.add rpc 1 3 28 | >>>= with_ok (fun n -> Alcotest.(check int) "add" 4 n |> return) 29 | >>= fun () -> 30 | Client.sub rpc 1 3 31 | >>>= with_ok (fun n -> Alcotest.(check int) "sub" (-2) n |> return) 32 | >>= fun () -> 33 | Client.mul rpc 2 3 34 | >>>= with_ok (fun n -> Alcotest.(check int) "mul" 6 n |> return) 35 | >>= fun () -> 36 | Client.div rpc 8 2 >>>= with_ok (fun n -> Alcotest.(check int) "div" 4 n |> return) 37 | >>= fun () -> 38 | Client.ping rpc () >>>= with_ok (fun n -> Alcotest.(check string) "ping" "OK" n |> return) 39 | in 40 | Thread_safe.block_on_async_exn run 41 | 42 | 43 | let tests = [ "test_call_async", `Quick, test_call_async ] 44 | -------------------------------------------------------------------------------- /tests/async/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name suite) 3 | (libraries rpclib rpclib-async alcotest test_common)) 4 | 5 | (rule 6 | (alias runtest) 7 | (package rpclib-async) 8 | (deps 9 | (:s suite.exe)) 10 | (action 11 | (run %{s}))) 12 | -------------------------------------------------------------------------------- /tests/async/suite.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.run "rpclib-async suite" [ "Client_server_test", Client_server_test.tests ] 3 | -------------------------------------------------------------------------------- /tests/common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_common) 3 | (libraries rpclib.core)) 4 | -------------------------------------------------------------------------------- /tests/common/test_interface.ml: -------------------------------------------------------------------------------- 1 | module Interface (R : Idl.RPC) = struct 2 | open R 3 | 4 | let int_p = Idl.Param.mk Rpc.Types.int 5 | let string_p = Idl.Param.mk Rpc.Types.string 6 | 7 | let int_p_named_1 = 8 | Idl.Param.mk ~name:"int1" ~description:[ "first int param" ] Rpc.Types.int 9 | 10 | 11 | let int_p_named_2 = 12 | Idl.Param.mk ~name:"int2" ~description:[ "second int param" ] Rpc.Types.int 13 | 14 | 15 | let int_p_result = Idl.Param.mk ~name:"int" ~description:[ "int result" ] Rpc.Types.int 16 | 17 | let add = 18 | R.declare 19 | "add" 20 | [ "Add two numbers" ] 21 | (int_p @-> int_p @-> returning int_p Idl.DefaultError.err) 22 | 23 | 24 | let sub = 25 | R.declare 26 | "sub" 27 | [ "Subtract two numbers" ] 28 | (int_p_named_1 @-> int_p @-> returning int_p Idl.DefaultError.err) 29 | 30 | 31 | let mul = 32 | R.declare 33 | "mul" 34 | [ "Multiply two numbers" ] 35 | (int_p_named_1 @-> int_p_named_2 @-> returning int_p Idl.DefaultError.err) 36 | 37 | 38 | let div = 39 | R.declare 40 | "div" 41 | [ "Divide two numbers" ] 42 | (int_p_named_1 @-> int_p_named_2 @-> returning int_p_result Idl.DefaultError.err) 43 | 44 | let ping = 45 | R.declare 46 | "ping" 47 | [ "Check if service is alive (no params)" ] 48 | (noargs (returning string_p Idl.DefaultError.err)) 49 | 50 | let implementation = 51 | implement 52 | { Idl.Interface.name = "Calc" 53 | ; namespace = Some "Calc" 54 | ; description = [ "interface" ] 55 | ; version = 1, 0, 0 56 | } 57 | end 58 | -------------------------------------------------------------------------------- /tests/lib/client_server_test.ml: -------------------------------------------------------------------------------- 1 | (** This test verifies that the client and server functions generated by the 2 | IDL interoperate correctly *) 3 | open Idl.Exn 4 | 5 | let test_call_core () = 6 | let server = 7 | let module Server = Test_common.Test_interface.Interface (GenServer ()) in 8 | Server.add (fun a b -> a + b); 9 | Server.sub (fun a b -> a - b); 10 | Server.mul (fun a b -> a * b); 11 | Server.div (fun a b -> a / b); 12 | Server.ping (fun () -> "OK"); 13 | server Server.implementation 14 | in 15 | let module Client = 16 | Test_common.Test_interface.Interface (GenClient (struct 17 | let rpc = server 18 | end)) 19 | in 20 | Alcotest.(check int) "add" 4 (Client.add 1 3); 21 | Alcotest.(check int) "sub" 2 (Client.sub 3 1); 22 | Alcotest.(check int) "mul" 6 (Client.mul 2 3); 23 | Alcotest.(check int) "div" 4 (Client.div 8 2); 24 | Alcotest.(check string) "ping" "OK" (Client.ping ()) 25 | 26 | 27 | let tests = [ "test_call_core", `Quick, test_call_core ] 28 | -------------------------------------------------------------------------------- /tests/lib/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name suite) 3 | (libraries rpclib.core rpclib.json rpclib.xml alcotest test_common)) 4 | 5 | (rule 6 | (alias runtest) 7 | (package rpclib) 8 | (deps 9 | (:s suite.exe)) 10 | (action 11 | (run %{s}))) 12 | -------------------------------------------------------------------------------- /tests/lib/encoding.ml: -------------------------------------------------------------------------------- 1 | let run () = 2 | let t = "4" in 3 | let r = Rpc.rpc_of_string t in 4 | Printf.printf "r = %s\n%!" (Rpc.to_string r); 5 | let t' = Rpc.string_of_rpc r in 6 | Printf.printf "t = t : %b'\n%!" (t = t'); 7 | assert (t = t') 8 | 9 | 10 | let run_not_strict () = 11 | let test = Rpc.Dict [ "foo", Rpc.String "&"; "bar", Rpc.Int (Int64.of_int 3) ] in 12 | let str = Xmlrpc.to_string ~strict:false test in 13 | assert ( 14 | str 15 | = "foo&bar3" 16 | ) 17 | 18 | 19 | let run_strict () = 20 | let test = Rpc.Dict [ "foo", Rpc.String "&"; "bar", Rpc.Int (Int64.of_int 3) ] in 21 | let str = Xmlrpc.to_string ~strict:true test in 22 | assert ( 23 | str 24 | = "foo&bar3" 25 | ) 26 | 27 | 28 | let tests = 29 | [ "test", `Quick, run 30 | ; "test not strict", `Quick, run_not_strict 31 | ; "test strict", `Quick, run_strict 32 | ] 33 | -------------------------------------------------------------------------------- /tests/lib/json.ml: -------------------------------------------------------------------------------- 1 | let invalid_json = "\n { foo\"a\":\"b\" }\n" 2 | let valid_json = "\n { \"a\":\"b\" }\n" 3 | let valid_json_with_junk = "\n { \"a\":\"b\" }Some junk\n" 4 | 5 | let v1 = 6 | "{\n\ 7 | \ \"method\": \"session.login_with_password\",\n\ 8 | \t\"params\": [\"user\", \"password\"],\n\ 9 | \t\"id\": 0\n\ 10 | }" 11 | 12 | 13 | let v1_null_id = 14 | "{\n\ 15 | \ \"method\": \"session.login_with_password\",\n\ 16 | \t\"params\": [\"user\", \"password\"],\n\ 17 | \t\"id\": null\n\ 18 | }" 19 | 20 | 21 | let v1_string_id = 22 | "{\n\ 23 | \t\"method\": \"session.login_with_password\",\n\ 24 | \t\"params\": [\"user\", \"password\"],\n\ 25 | \t\"id\": \"0\"\n\ 26 | }" 27 | 28 | 29 | let v1_bad_id = 30 | "{\n\ 31 | \t\"method\": \"session.login_with_password\",\n\ 32 | \t\"params\": [\"user\", \"password\"],\n\ 33 | \t\"id\": [3]\n\ 34 | }" 35 | 36 | 37 | let v1_no_params = "{\n\t\"method\": \"session.login_with_password\",\n\t\"id\": \"0\"\n}" 38 | 39 | let v1_no_id = 40 | "{\n\ 41 | \t\"method\": \"session.login_with_password\",\n\ 42 | \t\"params\": [\"user\", \"password\"]\n\ 43 | }" 44 | 45 | 46 | let v2 = 47 | "{\n\ 48 | \t\"method\": \"session.login_with_password\",\n\ 49 | \t\"params\": [\"user\", \"password\"],\n\ 50 | \t\"id\": 0,\n\ 51 | \t\"jsonrpc\": \"2.0\"\n\ 52 | }" 53 | 54 | 55 | let v2_no_params = 56 | "{\n\ 57 | \t\"method\": \"session.login_with_password\",\n\ 58 | \t\"id\": 0,\n\ 59 | \t\"jsonrpc\": \"2.0\"\n\ 60 | }" 61 | 62 | 63 | let v2_null_id = 64 | "{\n\ 65 | \t\"method\": \"session.login_with_password\",\n\ 66 | \ \"params\": [\"user\", \"password\"],\n\ 67 | \ \"id\": null,\n\ 68 | \t\"jsonrpc\": \"2.0\"\n\ 69 | }" 70 | 71 | 72 | let v2_no_method = 73 | "{\n\t\"params\": [\"user\", \"password\"],\n\t\"id\": 0,\n\t\"jsonrpc\": \"2.0\"\n}" 74 | 75 | 76 | let v2_string_id = 77 | "{\n\ 78 | \t\"method\": \"session.login_with_password\",\n\ 79 | \t\"params\": [\"user\", \"password\"],\n\ 80 | \t\"id\": \"0\",\n\ 81 | \t\"jsonrpc\": \"2.0\"\n\ 82 | }" 83 | 84 | 85 | let v2_bad_id = 86 | "{\n\ 87 | \t\"method\": \"session.login_with_password\",\n\ 88 | \t\"params\": [\"user\", \"password\"],\n\ 89 | \t\"id\": \"0\",\n\ 90 | \t\"jsonrpc\": [2]\n\ 91 | }" 92 | 93 | 94 | let v2_bad_jsonrpc = 95 | "{\n\ 96 | \t\"method\": \"session.login_with_password\",\n\ 97 | \t\"params\": [\"user\", \"password\"],\n\ 98 | \t\"id\": 0,\n\ 99 | \t\"jsonrpc\": \"1.0\"\n\ 100 | }" 101 | 102 | 103 | let v2_mixed = 104 | "{\n\ 105 | \ \"jsonrpc\": \"2.0\",\n\ 106 | \ \"result\": \"OpaqueRef:0d01bcdd-9b33-a0d8-1870-d4fb80af354e\",\n\ 107 | \ \"error\": null,\n\ 108 | \ \"id\": 0\n\ 109 | }" 110 | 111 | 112 | let v2_success = 113 | "{\n\ 114 | \ \"jsonrpc\": \"2.0\",\n\ 115 | \ \"result\": \"OpaqueRef:0d01bcdd-9b33-a0d8-1870-d4fb80af354e\",\n\ 116 | \ \"id\": 0\n\ 117 | }" 118 | 119 | 120 | let v2_success_with_junk = 121 | "{\n\ 122 | \ \"jsonrpc\": \"2.0\",\n\ 123 | \ \"result\": \"OpaqueRef:0d01bcdd-9b33-a0d8-1870-d4fb80af354e\",\n\ 124 | \ \"id\": 0\n\ 125 | }{!&some junk for test" 126 | 127 | 128 | let v2_failure_bad_error = 129 | "{\n\ 130 | \ \"jsonrpc\": \"2.0\",\n\ 131 | \ \"error\": [ \"SESSION_AUTHENTICATION_FAILED\", \"root\", \"Authentication \ 132 | failure\" ],\n\ 133 | \ \"id\": 0\n\ 134 | }" 135 | 136 | 137 | let v2_failure = 138 | "{\n\ 139 | \ \"jsonrpc\": \"2.0\",\n\ 140 | \ \"error\": { \"code\": 1, \"message\": \"foo\", \"data\": \"bar\" },\n\ 141 | \ \"id\": 0\n\ 142 | }" 143 | 144 | 145 | let v2_failure_no_data = 146 | "{\n\ 147 | \ \"jsonrpc\": \"2.0\",\n\ 148 | \ \"error\": { \"code\": 1, \"message\": \"foo\" },\n\ 149 | \ \"id\": 0\n\ 150 | }" 151 | 152 | 153 | let v2_failure_bad_code = 154 | "{\n\ 155 | \ \"jsonrpc\": \"2.0\",\n\ 156 | \ \"error\": { \"code\": \"a\", \"message\": \"foo\" },\n\ 157 | \ \"id\": 0\n\ 158 | }" 159 | 160 | 161 | let v2_failure_bad_message = 162 | "{\n\ 163 | \ \"jsonrpc\": \"2.0\",\n\ 164 | \ \"error\": { \"code\": 1, \"message\": 2 },\n\ 165 | \ \"id\": 0\n\ 166 | }" 167 | 168 | 169 | let tests_json = 170 | [ "invalid_json", invalid_json, false 171 | ; "valid_json", valid_json, true 172 | ; "valid_json_with_junk", valid_json_with_junk, false 173 | ] 174 | 175 | 176 | let tests_json_plus = [ "valid_json_with_junk", valid_json_with_junk, true ] 177 | 178 | let tests_call = 179 | [ "v1", v1, true 180 | ; "v1_null_id", v1_null_id, false 181 | ; (*stricter than the specs*) 182 | "v1_string_id", v1_string_id, true 183 | ; "v1_bad_id", v1_bad_id, false 184 | ; (*stricter than the specs*) 185 | "v1_no_id", v1_no_id, false 186 | ; "v1_no_params", v1_no_params, false 187 | ; "v2", v2, true 188 | ; "v2_no_params", v2_no_params, true 189 | ; "v2_null_id", v2_null_id, false 190 | ; (*stricter than the specs*) 191 | "v2_no_method", v2_no_method, false 192 | ; "v2_string_id", v2_string_id, true 193 | ; "v2_bad_id", v2_bad_id, false 194 | ; "v2_bad_jsonrpc", v2_bad_jsonrpc, false 195 | ] 196 | 197 | 198 | let tests_response = 199 | [ "v2_success", v2_success, true 200 | ; "v2_success_with_junk", v2_success_with_junk, false 201 | ; "v2_failure", v2_failure, false 202 | ; "v2_mixed", v2_mixed, false 203 | ; "v2_failure_bad_error", v2_failure_bad_error, false 204 | ; "v2_failure_no_data", v2_failure_no_data, true 205 | ; "v2_failure_bad_code", v2_failure_bad_code, false 206 | ; "v2_failure_bad_message", v2_failure_bad_message, false 207 | ] 208 | 209 | 210 | let tests_response_plus = [ "v2_success_with_junk", v2_success_with_junk, true ] 211 | 212 | let invoke parse_func (test_name, json, pass) = 213 | let run () = parse_func json |> ignore in 214 | if pass 215 | then Alcotest.(check unit) test_name () (run ()) 216 | else ( 217 | try 218 | run (); 219 | Alcotest.failf "test %s did not fail" test_name 220 | with 221 | | e -> 222 | Printf.printf "test %s failed as expected: %s\n" test_name (Printexc.to_string e)) 223 | 224 | 225 | let test tcs unmarshal () = List.iter (invoke unmarshal) tcs 226 | 227 | let tests = 228 | [ "Jsonrpc.of_string", `Quick, test tests_json Jsonrpc.of_string 229 | ; ( "Jsonrpc.of_string ~strict:false" 230 | , `Quick 231 | , test tests_json_plus (Jsonrpc.of_string ~strict:false) ) 232 | ; "Jsonrpc.call_of_string", `Quick, test tests_call Jsonrpc.call_of_string 233 | ; "Jsonrpc.response_of_string", `Quick, test tests_response Jsonrpc.response_of_string 234 | ; ( "Jsonrpc.response_of_string ~strict:false" 235 | , `Quick 236 | , test tests_response_plus (Jsonrpc.response_of_string ~strict:false) ) 237 | ] 238 | -------------------------------------------------------------------------------- /tests/lib/suite.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.run 3 | "suite" 4 | [ "Client_server_test", Client_server_test.tests 5 | ; "Json", Json.tests 6 | ; "Xml_xapi", Xml_xapi.tests 7 | ; "Encoding", Encoding.tests 8 | ] 9 | -------------------------------------------------------------------------------- /tests/lib/xml_xapi.ml: -------------------------------------------------------------------------------- 1 | let array_call = 2 | "\n\ 3 | \ event.register\n\ 4 | \ \n\ 5 | \ \n\ 6 | \ OpaqueRef:8ecbbb2a-a905-d422-1153-fadc00639b12\n\ 7 | \ \n\ 8 | \ \n\ 9 | \ \n\ 10 | \ \n\ 11 | \ \n\ 12 | \ pbd\n\ 13 | \ \n\ 14 | \ \n\ 15 | \ \n\ 16 | \ \n\ 17 | \ \n\ 18 | \n" 19 | 20 | 21 | let simple_call = 22 | "\n\ 23 | \ session.login_with_password\n\ 24 | \ \n\ 25 | \ \n\ 26 | \ \n\ 27 | \ \n\ 28 | \ \n\ 29 | \ \n\ 30 | \ \n\ 31 | \ \n\ 32 | \ 1.4\n\ 33 | \ \n\ 34 | \ \n\ 35 | \n" 36 | 37 | 38 | let error = 39 | "\n\ 40 | \n\ 41 | \n\ 42 | \n\ 43 | faultCode\n\ 44 | 143\n\ 45 | \n\ 46 | \n\ 47 | faultString\n\ 48 | Failed to parse the request\n\ 49 | \n\ 50 | \n\ 51 | \n\ 52 | \n" 53 | 54 | 55 | let sm = 56 | "\n\ 57 | \n\ 58 | \n\ 59 | \n\ 60 | \n\ 61 | \n\ 62 | required_api_version\n\ 63 | 1.0\n\ 64 | \n\ 65 | \n\ 66 | vendor\n\ 67 | Citrix Systems Inc\n\ 68 | \n\ 69 | \n\ 70 | name\n\ 71 | Local EXT3 VHD\n\ 72 | \n\ 73 | \n\ 74 | copyright\n\ 75 | (C) 2008 Citrix Systems Inc\n\ 76 | \n\ 77 | \n\ 78 | capabilities\n\ 79 | \n\ 80 | SR_PROBE\n\ 81 | SR_UPDATE\n\ 82 | VDI_CREATE\n\ 83 | VDI_DELETE\n\ 84 | VDI_ATTACH\n\ 85 | VDI_DETACH\n\ 86 | VDI_UPDATE\n\ 87 | VDI_CLONE\n\ 88 | VDI_SNAPSHOT\n\ 89 | VDI_RESIZE\n\ 90 | VDI_RESIZE_ONLINE\n\ 91 | \n\ 92 | \n\ 93 | \n\ 94 | driver_version\n\ 95 | 1.0\n\ 96 | \n\ 97 | \n\ 98 | configuration\n\ 99 | \n\ 100 | \n\ 101 | \n\ 102 | description\n\ 103 | local device path (required) (e.g. /dev/sda3)\n\ 104 | \n\ 105 | \n\ 106 | key\n\ 107 | device\n\ 108 | \n\ 109 | \n\ 110 | \n\ 111 | \n\ 112 | \n\ 113 | description\n\ 114 | SR plugin which represents disks as VHD files stored on a local EXT3 \ 115 | filesystem, created inside an LVM volume\n\ 116 | \n\ 117 | \n\ 118 | \n\ 119 | \n\ 120 | \n" 121 | 122 | 123 | let base64 = 124 | "\n\ 125 | \ \n\ 126 | \n\ 127 | \n\ 128 | SGVsbG8sIHdvcmxkIQ==\n\ 129 | \n\ 130 | \n\ 131 | \n\n" 132 | 133 | 134 | let base64_call = 135 | "\n\ 136 | \ send_file\n\ 137 | \ \n\ 138 | \ \n\ 139 | \ \n\ 140 | \ SGVsbG8sIHdvcmxkIQ== \n\ 141 | \ \n\ 142 | \ \n\ 143 | \n" 144 | 145 | 146 | let empty = "" 147 | 148 | let run () = 149 | Printf.printf "Parsing SM XML ... %!"; 150 | let _ = Xmlrpc.response_of_string sm in 151 | Printf.printf "OK\nParsing empty tags ... %!"; 152 | let _ = Xmlrpc.of_string empty in 153 | Printf.printf "OK\nParsing error ... %!"; 154 | let _ = Xmlrpc.response_of_string error in 155 | Printf.printf "OK\nParsing simple call ... %!"; 156 | let _ = Xmlrpc.call_of_string simple_call in 157 | Printf.printf "OK\nParsing array call ... %!"; 158 | let _ = Xmlrpc.call_of_string array_call in 159 | Printf.printf "OK\n%!"; 160 | let b64 = Xmlrpc.response_of_string base64 in 161 | Printf.printf "Base64 response: %s\n" (Rpc.to_string b64.contents); 162 | assert (b64.contents = Rpc.Base64 "Hello, world!"); 163 | let b64_req = Xmlrpc.call_of_string base64_call in 164 | Printf.printf "Base64 request: %s\n" (Rpc.string_of_call b64_req); 165 | assert (List.hd b64_req.params = Rpc.Base64 "Hello, world!") 166 | 167 | 168 | let tests = [ "Xapi XML tests", `Quick, run ] 169 | -------------------------------------------------------------------------------- /tests/lwt/client_server_test.ml: -------------------------------------------------------------------------------- 1 | (** This test verifies that the client and server functions generated by the 2 | IDL interoperate correctly *) 3 | 4 | let with_ok f = function 5 | | Ok r -> f r 6 | | Error _ -> Alcotest.fail "RPC call failed" 7 | 8 | 9 | let test_call_lwt _switch () = 10 | let open Lwt.Infix in 11 | let server = 12 | let module Server = Test_common.Test_interface.Interface (Rpc_lwt.GenServer ()) in 13 | let open Rpc_lwt in 14 | Server.add (fun a b -> ErrM.return (a + b)); 15 | Server.sub (fun a b -> ErrM.return (a - b)); 16 | Server.mul (fun a b -> ErrM.return (a * b)); 17 | Server.div (fun a b -> ErrM.return (a / b)); 18 | Server.ping (fun () -> ErrM.return "OK"); 19 | Rpc_lwt.server Server.implementation 20 | in 21 | let rpc call = server call in 22 | let module Client = Test_common.Test_interface.Interface (Rpc_lwt.GenClient ()) in 23 | let t = 24 | let open Rpc_lwt in 25 | (* TODO: Add this to the Transformer itself *) 26 | let ( >>>= ) x f = x |> T.get >>= f in 27 | Client.add rpc 1 3 28 | >>>= with_ok (fun n -> Alcotest.(check int) "add" 4 n |> Lwt.return) 29 | >>= fun () -> 30 | Client.sub rpc 1 3 31 | >>>= with_ok (fun n -> Alcotest.(check int) "sub" (-2) n |> Lwt.return) 32 | >>= fun () -> 33 | Client.mul rpc 2 3 34 | >>>= with_ok (fun n -> Alcotest.(check int) "mul" 6 n |> Lwt.return) 35 | >>= fun () -> 36 | Client.div rpc 8 2 37 | >>>= with_ok (fun n -> Alcotest.(check int) "div" 4 n |> Lwt.return) 38 | >>= fun () -> 39 | Client.ping rpc () 40 | >>>= with_ok (fun n -> Alcotest.(check string) "ping" "OK" n |> Lwt.return) 41 | in 42 | t 43 | 44 | 45 | let tests = [ Alcotest_lwt.test_case "test_call_lwt" `Quick test_call_lwt ] 46 | -------------------------------------------------------------------------------- /tests/lwt/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name suite) 3 | (libraries rpclib rpclib-lwt alcotest alcotest-lwt test_common)) 4 | 5 | (rule 6 | (alias runtest) 7 | (package rpclib-lwt) 8 | (deps 9 | (:s suite.exe)) 10 | (action 11 | (run %{s}))) 12 | -------------------------------------------------------------------------------- /tests/lwt/suite.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Lwt_main.run 3 | @@ Alcotest_lwt.run 4 | "rpclib-lwt suite" 5 | [ "Client_server_test", Client_server_test.tests ] 6 | -------------------------------------------------------------------------------- /tests/ppx/all_types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | type t = 16 | | Foo of int 17 | | Bar of (int * float) 18 | [@@deriving rpc] 19 | 20 | module M = struct 21 | type m = t [@@deriving rpc] 22 | end 23 | 24 | type 'a x = 25 | { foo : M.m 26 | ; bar : string 27 | ; gna : float list 28 | ; f1 : (int option * bool list * float list list) option 29 | ; f2 : (string * string list) array 30 | ; f3 : int32 31 | ; f4 : int64 32 | ; f5 : int [@key "type"] 33 | ; f6 : (unit * char) list 34 | ; f7 : 'a list [@key "let"] 35 | ; progress : int array 36 | } 37 | [@@deriving rpc] 38 | 39 | module Testable = struct 40 | let x = Testable.from_rpc_of_t (rpc_of_x M.rpc_of_m) 41 | let call = Testable.from_to_string Rpc.string_of_call 42 | let response = Testable.from_to_string Rpc.string_of_response 43 | end 44 | 45 | let run () = 46 | let x = 47 | { foo = Foo 3 48 | ; bar = "ha ha" 49 | ; gna = [ 1.; 2.; 3.; 4.; Unix.gettimeofday () ] 50 | ; f2 = [| "hi", [ "hi" ]; "hou", [ "hou"; "hou" ]; "foo", [ "b"; "a"; "r" ] |] 51 | ; f1 = Some (None, [ true ], [ [ 1. ]; [ 2.; 3. ] ]) 52 | ; f3 = Int32.max_int 53 | ; f4 = Int64.max_int 54 | ; f5 = max_int 55 | ; f6 = [ (), 'a'; (), 'b'; (), 'c'; (), 'd'; (), 'e' ] 56 | ; f7 = [ Foo 1; Foo 2; Foo 3 ] 57 | ; progress = [| 0; 1; 2; 3; 4; 5 |] 58 | } 59 | in 60 | (* Testing basic marshalling/unmarshalling *) 61 | let rpc = rpc_of_x M.rpc_of_m x in 62 | let rpc_xml = Xmlrpc.to_string rpc in 63 | let rpc_json = Jsonrpc.to_string rpc in 64 | Printf.printf "\n==rpc_xml==\n%s\n" rpc_xml; 65 | Printf.printf "\n==json==\n%s\n" rpc_json; 66 | let callback fields value = 67 | match fields, value with 68 | | [ "progress" ], Rpc.Int i -> Printf.printf "Progress: %Ld\n" i 69 | | _ -> () 70 | in 71 | let x_of_rpc = x_of_rpc M.m_of_rpc in 72 | let x_xml = x_of_rpc (Xmlrpc.of_string ~callback rpc_xml) in 73 | let x_json = x_of_rpc (Jsonrpc.of_string rpc_json) in 74 | Alcotest.(check Testable.x) "Sanity check x=x_xml" x x_xml; 75 | Alcotest.(check Testable.x) "Sanity check x=x_json" x x_json; 76 | (* Testing calls and responses *) 77 | let call = Rpc.call "foo" [ rpc ] in 78 | let success = Rpc.success rpc in 79 | let failure = Rpc.failure rpc in 80 | let c_xml_str = Xmlrpc.string_of_call call in 81 | let s_xml_str = Xmlrpc.string_of_response success in 82 | let f_xml_str = Xmlrpc.string_of_response failure in 83 | let c_json_str = Jsonrpc.string_of_call call in 84 | let s_json_str = Jsonrpc.string_of_response success in 85 | let f_json_str = Jsonrpc.string_of_response failure in 86 | Printf.printf "\n==call==\n %s\n%s\n" c_xml_str c_json_str; 87 | Printf.printf "\n==success==\n %s\n%s\n" s_xml_str s_json_str; 88 | Printf.printf "\n==failure==\n %s\n%s\n" f_xml_str f_json_str; 89 | let c_xml = Xmlrpc.call_of_string c_xml_str in 90 | let s_xml = Xmlrpc.response_of_string s_xml_str in 91 | let f_xml = Xmlrpc.response_of_string f_xml_str in 92 | let c1 = x_of_rpc (List.hd call.Rpc.params) in 93 | let c2 = x_of_rpc (List.hd c_xml.Rpc.params) in 94 | let s1 = x_of_rpc success.Rpc.contents in 95 | let s2 = x_of_rpc s_xml.Rpc.contents in 96 | let f1 = x_of_rpc failure.Rpc.contents in 97 | let f2 = x_of_rpc f_xml.Rpc.contents in 98 | Alcotest.(check Testable.x) "Sanity check c1=c2" c1 c2; 99 | Alcotest.(check Testable.x) "Sanity check s1=s2" s1 s2; 100 | Alcotest.(check Testable.x) "Sanity check f1=f2" f1 f2; 101 | let c_json = Jsonrpc.call_of_string c_json_str in 102 | let s_json = Jsonrpc.response_of_string s_json_str in 103 | let f_json = Jsonrpc.response_of_string f_json_str in 104 | Alcotest.(check Testable.call) "Sanity check call=c_json" call c_json; 105 | Alcotest.(check Testable.response) "Sanity check success=s_json" success s_json; 106 | Alcotest.(check Testable.response) "Sanity check failure=f_json" failure f_json 107 | 108 | 109 | let tests = [ "test", `Quick, run ] 110 | -------------------------------------------------------------------------------- /tests/ppx/dict.ml: -------------------------------------------------------------------------------- 1 | type key = string [@@deriving rpc] 2 | type t = (key * float) list [@@deriving rpc] 3 | 4 | let run () = 5 | let t = [ "foo", 3.; "bar", 4. ] in 6 | let r = rpc_of_t t in 7 | Printf.printf "r = %s\n%!" (Rpc.to_string r); 8 | let t' = t_of_rpc r in 9 | Printf.printf "t = t' : %b\n%!" (t = t'); 10 | Alcotest.(check (list (pair string Testable.float))) 11 | "dict same after marshal->unmarshal" 12 | t 13 | t' 14 | 15 | 16 | let tests = [ "main test", `Quick, run ] 17 | -------------------------------------------------------------------------------- /tests/ppx/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name suite) 3 | (flags :standard -warn-error +a -w -27-33-39) 4 | (libraries alcotest result rpclib rpclib.core rpclib.json rresult) 5 | (preprocess 6 | (pps ppx_deriving_rpc))) 7 | 8 | (rule 9 | (alias runtest) 10 | (deps 11 | (:s suite.exe)) 12 | (package ppx_deriving_rpc) 13 | (action 14 | (run %{s}))) 15 | -------------------------------------------------------------------------------- /tests/ppx/option.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { foo : int option 3 | ; bar : int list option 4 | ; gni : int list 5 | ; gna : int * int option 6 | } 7 | [@@deriving rpc] 8 | 9 | let run () = 10 | let t1 = { foo = None; bar = None; gni = []; gna = 1, None } in 11 | let t2 = { foo = None; bar = Some []; gni = [ 1 ]; gna = 1, None } in 12 | let r1 = rpc_of_t t1 in 13 | let r2 = rpc_of_t t2 in 14 | Printf.printf "r1 = %s\nr2 = %s\n" (Rpc.to_string r1) (Rpc.to_string r2); 15 | let t1' = t_of_rpc r1 in 16 | let t2' = t_of_rpc r2 in 17 | Alcotest.check (Testable.from_rpc_of_t rpc_of_t) "t1 = t1'" t1 t1'; 18 | Alcotest.check (Testable.from_rpc_of_t rpc_of_t) "t2 = t2'" t2 t2' 19 | 20 | 21 | let tests = [ "test", `Quick, run ] 22 | -------------------------------------------------------------------------------- /tests/ppx/phantom.ml: -------------------------------------------------------------------------------- 1 | module P : sig 2 | type 'a t 3 | 4 | val rpc_of_t : ('a -> Rpc.t) -> 'a t -> Rpc.t 5 | val t_of_rpc : (Rpc.t -> 'a) -> Rpc.t -> 'a t 6 | val to_string : 'a t -> string 7 | val of_string : string -> 'a t 8 | end = struct 9 | type 'a t = string [@@deriving rpc] 10 | 11 | let to_string x = x 12 | let of_string x = x 13 | end 14 | 15 | module Q = struct 16 | include P 17 | 18 | let rpc_of_t _ x = Rpc.rpc_of_string (to_string x) 19 | let t_of_rpc _ x = of_string (Rpc.string_of_rpc x) 20 | end 21 | 22 | type x = [ `foo ] Q.t [@@deriving rpc] 23 | type y = [ `bar ] Q.t [@@deriving rpc] 24 | 25 | let run () = 26 | let p : [ `p ] P.t = P.of_string "foo" in 27 | let q : [ `q ] P.t = P.of_string "foo" in 28 | let x : x = P.of_string "foo" in 29 | let y : y = P.of_string "foo" in 30 | let p_rpc = Q.rpc_of_t () p in 31 | let q_rpc = Q.rpc_of_t () q in 32 | let x_rpc = rpc_of_x x in 33 | let y_rpc = rpc_of_y y in 34 | let (_ : [ `p ] P.t) = Q.t_of_rpc () p_rpc in 35 | let (_ : [ `q ] P.t) = Q.t_of_rpc () q_rpc in 36 | let (_ : x) = x_of_rpc x_rpc in 37 | let (_ : y) = y_of_rpc y_rpc in 38 | Printf.printf "p=%s\n" (Xmlrpc.to_string p_rpc); 39 | Printf.printf "q=%s\n" (Xmlrpc.to_string q_rpc); 40 | Printf.printf "x=%s\n" (Xmlrpc.to_string x_rpc); 41 | Printf.printf "y=%s\n" (Xmlrpc.to_string y_rpc) 42 | 43 | 44 | let tests = [ "test", `Quick, run ] 45 | -------------------------------------------------------------------------------- /tests/ppx/suite.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.run 3 | "ppx_deriving_rpc suite" 4 | [ "All_types", All_types.tests 5 | ; "Test_deriving_rpc", Test_deriving_rpc.tests 6 | ; "Test_deriving_rpcty", Test_deriving_rpcty.tests 7 | ; "Dict", Dict.tests 8 | ; "Option", Option.tests 9 | ; "Phantom", Phantom.tests 10 | ; "Variants", Variants.tests 11 | ] 12 | -------------------------------------------------------------------------------- /tests/ppx/testable.ml: -------------------------------------------------------------------------------- 1 | (** Creates a [testable] from the given pretty-printer using the polymorphic 2 | equality function *) 3 | let from_to_string pp = Alcotest.testable (Fmt.of_to_string pp) ( = ) 4 | 5 | (** Creates a [testable] using OCaml's polymorphic equality and [Rpc.t] -> 6 | [string] conversion for formatting *) 7 | let from_rpc_of_t rpc_of = from_to_string (fun t -> rpc_of t |> Rpc.to_string) 8 | 9 | (** Creates a [testable] using OCaml's polymorphic equality and [Rpc.t] -> 10 | [string] conversion for formatting *) 11 | let from_rpcty ty = from_rpc_of_t (Rpcmarshal.marshal ty) 12 | 13 | let generic () = from_to_string (fun _ -> "no pretty-printer") 14 | let rpc = from_to_string Rpc.to_string 15 | 16 | let unmarshal_err : Rpcmarshal.err Alcotest.testable = 17 | from_to_string (function `Msg x -> x) 18 | 19 | 20 | (** Testable for the results returned by Rpcmarshal.unmarshal *) 21 | let unmarshal_res ty = Alcotest.result (from_rpcty ty) unmarshal_err 22 | 23 | (** float testable using machine epsilon for the precision *) 24 | let float = Alcotest.float 2E-52 25 | -------------------------------------------------------------------------------- /tests/ppx/variants.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | [ `foo 3 | | `bar of int * string 4 | ] 5 | [@@deriving rpc] 6 | 7 | let run () = 8 | let t1 = `foo in 9 | let t2 = `bar (3, "bar") in 10 | let r1 = rpc_of_t t1 in 11 | let r2 = rpc_of_t t2 in 12 | Printf.printf "r1 = %s\nr2 = %s\n%!" (Rpc.to_string r1) (Rpc.to_string r2); 13 | let t1' = t_of_rpc r1 in 14 | let t2' = t_of_rpc r2 in 15 | Alcotest.check (Testable.from_rpc_of_t rpc_of_t) "t1 =t1'" t1 t1'; 16 | Alcotest.check (Testable.from_rpc_of_t rpc_of_t) "t2 =t2'" t2 t2'; 17 | let test3 = Rpc.String "FOO" in 18 | ignore (t_of_rpc test3); 19 | Printf.printf "Case insensitive test: OK\n!" 20 | 21 | 22 | let tests = [ "test", `Quick, run ] 23 | -------------------------------------------------------------------------------- /tests/rpc/client_async_new.ml: -------------------------------------------------------------------------------- 1 | type return_record = 2 | { result : string 3 | ; metadata : (int * int) list 4 | ; extras : string option 5 | } 6 | [@@deriving rpcty] 7 | 8 | type variant_t = 9 | | Foo of string list 10 | | Bar 11 | | Baz of float 12 | [@@deriving rpcty] 13 | 14 | module API (R : Idl.RPC) = struct 15 | open R 16 | open Idl 17 | 18 | let description = 19 | let open Idl.Interface in 20 | { name = "Test server" 21 | ; namespace = None 22 | ; description = [ "Test interface" ] 23 | ; version = 1, 0, 0 24 | } 25 | 26 | 27 | let implementation = implement description 28 | 29 | (* Construct a bunch of arguments to use in our RPCs *) 30 | let arg1 = Param.mk ~name:"arg1" Rpc.Types.string 31 | let argx = Param.mk ~name:"x" Rpc.Types.int 32 | 33 | let argopt = 34 | Param.mk 35 | ~name:"opt" 36 | Rpc.Types.{ name = "string opt"; description = []; ty = Option (Basic String) } 37 | 38 | 39 | let argv = Param.mk ~name:"v" variant_t 40 | let argi = Param.mk ~name:"i" Rpc.Types.int64 41 | let argu = Param.mk ~name:"return_u" Rpc.Types.unit 42 | let return = Param.mk ~name:"return" return_record 43 | 44 | (* We'll use the default error type *) 45 | let e = Idl.DefaultError.err 46 | 47 | (* Construct 3 RPC definitions *) 48 | let rpc1 = declare "rpc1" [ "Test RPC 1" ] (arg1 @-> argx @-> returning return e) 49 | let rpc2 = declare "rpc2" [ "Test RPC 2" ] (argopt @-> argv @-> returning argu e) 50 | let rpc3 = declare "rpc3" [ "Test RPC 3" ] (argi @-> returning argi e) 51 | end 52 | 53 | module ImplM = struct 54 | open Rpc_async.ErrM 55 | 56 | let rpc1 arg1 x = 57 | if x = 5 58 | then return_err (Idl.DefaultError.InternalError "Boo") 59 | else ( 60 | Printf.printf "rpc1: %s %d\n" arg1 x; 61 | return { result = "OK!"; metadata = [ 1, 2; 3, 4 ]; extras = Some "bar" }) 62 | 63 | 64 | let rpc2 opt v = 65 | (match opt with 66 | | Some s -> Printf.printf "Got an optional string: %s\n" s 67 | | None -> ()); 68 | (match v with 69 | | Foo ss -> Printf.printf "Foo: [%s]\n" (String.concat ";" ss) 70 | | Bar -> Printf.printf "Bar\n" 71 | | Baz f -> Printf.printf "Baz: %f\n" f); 72 | return () 73 | 74 | 75 | let rpc3 i = 76 | Printf.printf "%Ld\n" i; 77 | return (Int64.add i 1L) 78 | end 79 | 80 | let rpc rpc_fn call = 81 | let open Async.Deferred in 82 | let call_string = Jsonrpc.string_of_call call in 83 | Printf.printf "rpc function: call_string='%s'\n" call_string; 84 | let call = Jsonrpc.call_of_string call_string in 85 | rpc_fn call 86 | >>= fun response -> 87 | let response_str = Jsonrpc.string_of_response response in 88 | Printf.printf "rpc function: response_string = '%s'\n" response_str; 89 | Async.Deferred.return (Jsonrpc.response_of_string response_str) 90 | 91 | 92 | module Server = API (Rpc_async.GenServer ()) 93 | module Client = API (Rpc_async.GenClient ()) 94 | 95 | let main () = 96 | let open Rpc_async in 97 | Server.rpc1 ImplM.rpc1; 98 | Server.rpc2 ImplM.rpc2; 99 | Server.rpc3 ImplM.rpc3; 100 | let funcs = Server.implementation in 101 | let rpc r = rpc (Rpc_async.server funcs) r in 102 | let body = 103 | let open ErrM in 104 | Client.rpc1 rpc "test argument" 2 105 | >>= fun result -> 106 | Printf.printf 107 | "result.result='%s', metadata=[%s]\n" 108 | result.result 109 | (String.concat 110 | ";" 111 | (List.map (fun (a, b) -> Printf.sprintf "(%d,%d)" a b) result.metadata)) 112 | |> return 113 | >>= fun () -> 114 | checked_bind 115 | (Client.rpc1 rpc "test argument" 5) 116 | (fun result -> 117 | Printf.printf 118 | "result.result='%s', metadata=[%s]\n" 119 | result.result 120 | (String.concat 121 | ";" 122 | (List.map (fun (a, b) -> Printf.sprintf "(%d,%d)" a b) result.metadata)) 123 | |> return) 124 | (fun err -> 125 | Printf.printf 126 | "Error: %s\n" 127 | (match err with 128 | | Idl.DefaultError.InternalError s -> s) 129 | |> return) 130 | >>= fun () -> 131 | Client.rpc2 rpc None (Foo [ "hello"; "there" ]) 132 | >>= fun _ -> 133 | Client.rpc2 rpc (Some "Optional") (Foo [ "hello"; "there" ]) 134 | >>= fun _ -> 135 | Client.rpc3 rpc 999999999999999999L >>= fun i -> Printf.printf "%Ld\n" i |> return 136 | in 137 | T.get body 138 | 139 | 140 | let run () = 141 | let open Async in 142 | ignore (main ()); 143 | Thread_safe.block_on_async_exn (fun () -> main () >>= fun _ -> return ()) 144 | 145 | 146 | let tests = [ "basic Async client-server test", `Quick, run ] 147 | -------------------------------------------------------------------------------- /tests/rpc/client_lwt_new.ml: -------------------------------------------------------------------------------- 1 | type return_record = 2 | { result : string 3 | ; metadata : (int * int) list 4 | ; extras : string option 5 | } 6 | [@@deriving rpcty] 7 | 8 | type variant_t = 9 | | Foo of string list 10 | | Bar 11 | | Baz of float 12 | [@@deriving rpcty] 13 | 14 | module type ABSMOD = sig 15 | type t 16 | 17 | val of_string : string -> t 18 | val string_of : t -> string 19 | val init : t 20 | end 21 | 22 | module AbstractMod : ABSMOD = struct 23 | type t = string 24 | 25 | let of_string t = t 26 | let string_of t = t 27 | let init = "hello" 28 | end 29 | 30 | module API (R : Idl.RPC) = struct 31 | open R 32 | open Idl 33 | 34 | let description = 35 | let open Idl.Interface in 36 | { name = "Test server" 37 | ; namespace = None 38 | ; description = [ "Test interface" ] 39 | ; version = 1, 0, 0 40 | } 41 | 42 | 43 | let abstr = 44 | let open Rpc.Types in 45 | { name = "abstr" 46 | ; ty = 47 | Abstract 48 | { aname = "abstr" 49 | ; test_data = [ AbstractMod.init ] 50 | ; rpc_of = (fun t -> Rpc.String (AbstractMod.string_of t)) 51 | ; of_rpc = 52 | (function 53 | | Rpc.String s -> Ok (AbstractMod.of_string s) 54 | | _ -> Error (`Msg "bad")) 55 | } 56 | ; description = [ "Abstract" ] 57 | } 58 | 59 | 60 | let implementation = implement description 61 | 62 | (* Construct a bunch of arguments to use in our RPCs *) 63 | let arg1 = Param.mk ~name:"arg1" Rpc.Types.string 64 | let argx = Param.mk ~name:"x" Rpc.Types.int 65 | 66 | let argopt = 67 | Param.mk 68 | ~name:"opt" 69 | Rpc.Types.{ name = "string opt"; description = []; ty = Option (Basic String) } 70 | 71 | 72 | let argv = Param.mk ~name:"v" variant_t 73 | let argi = Param.mk ~name:"i" Rpc.Types.int64 74 | let argu = Param.mk ~name:"return_u" Rpc.Types.unit 75 | let return = Param.mk ~name:"return" return_record 76 | let abs = Param.mk ~name:"abs" abstr 77 | let argu_noname = Param.mk Rpc.Types.unit 78 | 79 | (* We'll use the default error type *) 80 | let e = Idl.DefaultError.err 81 | 82 | (* Construct 3 RPC definitions *) 83 | let rpc1 = declare "rpc1" [ "Test RPC 1" ] (arg1 @-> argx @-> returning return e) 84 | let rpc2 = declare "rpc2" [ "Test RPC 2" ] (argopt @-> argv @-> returning argu e) 85 | let rpc3 = declare "rpc3" [ "Test RPC 3" ] (argi @-> returning argi e) 86 | let rpc4 = declare "rpc4" [ "Test RPC 4" ] (abs @-> returning arg1 e) 87 | let rpc5 = declare "rpc5" [ "Test RPC 5" ] (argopt @-> argu_noname @-> returning arg1 e) 88 | end 89 | 90 | module ImplM = struct 91 | open Rpc_lwt.ErrM 92 | 93 | let rpc1 arg1 x = 94 | if x = 5 95 | then return_err (Idl.DefaultError.InternalError "Boo") 96 | else ( 97 | Printf.printf "rpc1: %s %d\n" arg1 x; 98 | return { result = "OK!"; metadata = [ 1, 2; 3, 4 ]; extras = Some "bar" }) 99 | 100 | 101 | let rpc2 opt v = 102 | (match opt with 103 | | Some s -> Printf.printf "Got an optional string: %s\n" s 104 | | None -> ()); 105 | (match v with 106 | | Foo ss -> Printf.printf "Foo: [%s]\n" (String.concat ";" ss) 107 | | Bar -> Printf.printf "Bar\n" 108 | | Baz f -> Printf.printf "Baz: %f\n" f); 109 | return () 110 | 111 | 112 | let rpc3 i = 113 | Printf.printf "%Ld\n" i; 114 | return (Int64.add i 1L) 115 | 116 | 117 | let rpc4 abs = return (Printf.sprintf "Abs: %s\n" (AbstractMod.string_of abs)) 118 | let rpc5 _str_opt () = return "good" 119 | end 120 | 121 | let rpc rpc_fn call = 122 | let open Lwt in 123 | let call_string = Jsonrpc.string_of_call call in 124 | Printf.printf "rpc function: call_string='%s'\n" call_string; 125 | let call = Jsonrpc.call_of_string call_string in 126 | rpc_fn call 127 | >>= fun response -> 128 | let response_str = Jsonrpc.string_of_response response in 129 | Printf.printf "rpc function: response_string = '%s'\n" response_str; 130 | Lwt.return (Jsonrpc.response_of_string response_str) 131 | 132 | 133 | module Server = API (Rpc_lwt.GenServer ()) 134 | module Client = API (Rpc_lwt.GenClient ()) 135 | 136 | let main () = 137 | let open Rpc_lwt in 138 | Server.rpc1 ImplM.rpc1; 139 | Server.rpc2 ImplM.rpc2; 140 | Server.rpc3 ImplM.rpc3; 141 | Server.rpc4 ImplM.rpc4; 142 | Server.rpc5 ImplM.rpc5; 143 | let funcs = Server.implementation in 144 | let rpc r = rpc (Rpc_lwt.server funcs) r in 145 | let body = 146 | let open ErrM in 147 | Client.rpc1 rpc "test argument" 2 148 | >>= fun result -> 149 | Printf.printf 150 | "result.result='%s', metadata=[%s]\n" 151 | result.result 152 | (String.concat 153 | ";" 154 | (List.map (fun (a, b) -> Printf.sprintf "(%d,%d)" a b) result.metadata)) 155 | |> return 156 | >>= fun () -> 157 | checked_bind 158 | (Client.rpc1 rpc "test argument" 5) 159 | (fun result -> 160 | Printf.printf 161 | "result.result='%s', metadata=[%s]\n" 162 | result.result 163 | (String.concat 164 | ";" 165 | (List.map (fun (a, b) -> Printf.sprintf "(%d,%d)" a b) result.metadata)) 166 | |> return) 167 | (fun err -> 168 | Printf.printf 169 | "Error: %s\n" 170 | (match err with 171 | | Idl.DefaultError.InternalError s -> s) 172 | |> return) 173 | >>= fun () -> 174 | Client.rpc2 rpc None (Foo [ "hello"; "there" ]) 175 | >>= fun _ -> 176 | Client.rpc2 rpc (Some "Optional") (Foo [ "hello"; "there" ]) 177 | >>= fun _ -> 178 | Client.rpc3 rpc 999999999999999999L 179 | >>= fun i -> 180 | Client.rpc4 rpc AbstractMod.init 181 | >>= fun s -> 182 | return (Printf.printf "%Ld,%s\n" i s) 183 | >>= fun () -> Client.rpc5 rpc None () >>= fun s -> return (Printf.printf "%s" s) 184 | in 185 | T.get body 186 | 187 | 188 | let run _switch () = Lwt.Infix.(main () >>= fun _ -> Lwt.return_unit) 189 | let tests = [ Alcotest_lwt.test_case "basic Lwt client-server test" `Quick run ] 190 | -------------------------------------------------------------------------------- /tests/rpc/client_new.ml: -------------------------------------------------------------------------------- 1 | type return_record = 2 | { result : string 3 | ; metadata : (int * int) list 4 | ; extras : string option 5 | } 6 | [@@deriving rpcty] 7 | 8 | type variant_t = 9 | | Foo of string list 10 | | Bar 11 | | Baz of float 12 | [@@deriving rpcty] 13 | 14 | module IDL = Idl.Make (Idl.IdM) 15 | 16 | module type ABSMOD = sig 17 | type t 18 | 19 | val of_string : string -> t 20 | val string_of : t -> string 21 | val init : t 22 | end 23 | 24 | module AbstractMod : ABSMOD = struct 25 | type t = string 26 | 27 | let of_string t = t 28 | let string_of t = t 29 | let init = "hello" 30 | end 31 | 32 | module API (R : Idl.RPC) = struct 33 | open R 34 | open Idl 35 | 36 | let description = 37 | let open Idl.Interface in 38 | { name = "Test server" 39 | ; namespace = None 40 | ; description = [ "Test interface" ] 41 | ; version = 1, 0, 0 42 | } 43 | 44 | 45 | let abstr = 46 | let open Rpc.Types in 47 | { name = "abstr" 48 | ; ty = 49 | Abstract 50 | { aname = "abstr" 51 | ; test_data = [ AbstractMod.init ] 52 | ; rpc_of = (fun t -> Rpc.String (AbstractMod.string_of t)) 53 | ; of_rpc = 54 | (function 55 | | Rpc.String s -> Ok (AbstractMod.of_string s) 56 | | _ -> Error (`Msg "bad")) 57 | } 58 | ; description = [ "Abstract" ] 59 | } 60 | 61 | 62 | let implementation = implement description 63 | 64 | (* Construct a bunch of arguments to use in our RPCs *) 65 | let arg1 = Param.mk ~name:"arg1" Rpc.Types.string 66 | let argx = Param.mk ~name:"x" Rpc.Types.int 67 | 68 | let argopt = 69 | Param.mk 70 | ~name:"opt" 71 | Rpc.Types.{ name = "string opt"; description = []; ty = Option (Basic String) } 72 | 73 | 74 | let argv = Param.mk ~name:"v" variant_t 75 | let argi = Param.mk ~name:"i" Rpc.Types.int64 76 | let argu = Param.mk ~name:"return_u" Rpc.Types.unit 77 | let return = Param.mk ~name:"return" return_record 78 | let abs = Param.mk ~name:"abs" abstr 79 | let argu_noname = Param.mk Rpc.Types.unit 80 | 81 | (* We'll use the default error type *) 82 | let e = Idl.DefaultError.err 83 | 84 | (* Construct 3 RPC definitions *) 85 | let rpc1 = declare "rpc1" [ "Test RPC 1" ] (arg1 @-> argx @-> returning return e) 86 | let rpc2 = declare "rpc2" [ "Test RPC 2" ] (argopt @-> argv @-> returning argu e) 87 | let rpc3 = declare "rpc3" [ "Test RPC 3" ] (argi @-> returning argi e) 88 | let rpc4 = declare "rpc4" [ "Test RPC 4" ] (abs @-> returning arg1 e) 89 | let rpc5 = declare "rpc5" [ "Test RPC 5" ] (argopt @-> argu_noname @-> returning arg1 e) 90 | end 91 | 92 | module ImplM = struct 93 | open IDL.ErrM 94 | 95 | let rpc1 arg1 x = 96 | if x = 5 97 | then return_err (Idl.DefaultError.InternalError "Boo") 98 | else ( 99 | Printf.printf "rpc1: %s %d\n" arg1 x; 100 | return { result = "OK!"; metadata = [ 1, 2; 3, 4 ]; extras = Some "bar" }) 101 | 102 | 103 | let rpc2 opt v = 104 | (match opt with 105 | | Some s -> Printf.printf "Got an optional string: %s\n" s 106 | | None -> ()); 107 | (match v with 108 | | Foo ss -> Printf.printf "Foo: [%s]\n" (String.concat ";" ss) 109 | | Bar -> Printf.printf "Bar\n" 110 | | Baz f -> Printf.printf "Baz: %f\n" f); 111 | return () 112 | 113 | 114 | let rpc3 i = 115 | Printf.printf "%Ld\n" i; 116 | return (Int64.add i 1L) 117 | 118 | 119 | let rpc4 abs = return (Printf.sprintf "Abs: %s\n" (AbstractMod.string_of abs)) 120 | let rpc5 _str_opt () = return "good" 121 | end 122 | 123 | let rpc rpc_fn call = 124 | let call_string = Jsonrpc.string_of_call call in 125 | Printf.printf "rpc function: call_string='%s'\n" call_string; 126 | let call = Jsonrpc.call_of_string call_string in 127 | let response = rpc_fn call |> Idl.IdM.run in 128 | let response_str = Jsonrpc.string_of_response response in 129 | Printf.printf "rpc function: response_string = '%s'\n" response_str; 130 | Idl.IdM.return (Jsonrpc.response_of_string response_str) 131 | 132 | 133 | module Server = API (IDL.GenServer ()) 134 | module Client = API (IDL.GenClient ()) 135 | 136 | let main () = 137 | Server.rpc1 ImplM.rpc1; 138 | Server.rpc2 ImplM.rpc2; 139 | Server.rpc3 ImplM.rpc3; 140 | Server.rpc4 ImplM.rpc4; 141 | Server.rpc5 ImplM.rpc5; 142 | let funcs = Server.implementation in 143 | let rpc r = rpc (IDL.server funcs) r in 144 | let body = 145 | let open IDL.ErrM in 146 | Client.rpc1 rpc "test argument" 2 147 | >>= fun result -> 148 | Printf.printf 149 | "result.result='%s', metadata=[%s]\n" 150 | result.result 151 | (String.concat 152 | ";" 153 | (List.map (fun (a, b) -> Printf.sprintf "(%d,%d)" a b) result.metadata)) 154 | |> return 155 | >>= fun () -> 156 | checked_bind 157 | (Client.rpc1 rpc "test argument" 5) 158 | (fun result -> 159 | Printf.printf 160 | "result.result='%s', metadata=[%s]\n" 161 | result.result 162 | (String.concat 163 | ";" 164 | (List.map (fun (a, b) -> Printf.sprintf "(%d,%d)" a b) result.metadata)) 165 | |> return) 166 | (fun err -> 167 | Printf.printf 168 | "Error: %s\n" 169 | (match err with 170 | | Idl.DefaultError.InternalError s -> s) 171 | |> return) 172 | >>= fun () -> 173 | Client.rpc2 rpc None (Foo [ "hello"; "there" ]) 174 | >>= fun _ -> 175 | Client.rpc2 rpc (Some "Optional") (Foo [ "hello"; "there" ]) 176 | >>= fun _ -> 177 | Client.rpc3 rpc 999999999999999999L 178 | >>= fun i -> 179 | Client.rpc4 rpc AbstractMod.init 180 | >>= fun s -> 181 | return (Printf.printf "%Ld,%s\n" i s) 182 | >>= fun () -> Client.rpc5 rpc None () >>= fun s -> return (Printf.printf "%s" s) 183 | in 184 | IDL.T.get body 185 | 186 | 187 | let run () = 188 | match Idl.IdM.run (main ()) with 189 | | Ok () -> () 190 | | Error _ -> failwith "Failed" 191 | 192 | 193 | let tests = [ Alcotest.test_case "basic Lwt client-server test" `Quick run ] 194 | -------------------------------------------------------------------------------- /tests/rpc/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name suite) 3 | (libraries alcotest rpclib rpclib.json threads) 4 | (modules :standard \ suite_async client_async_new suite_lwt client_lwt_new) 5 | (preprocess 6 | (pps ppx_deriving_rpc))) 7 | 8 | (executable 9 | (name suite_async) 10 | (libraries alcotest async rpclib rpclib-async rpclib.json threads) 11 | (modules suite_async client_async_new) 12 | (preprocess 13 | (pps ppx_deriving_rpc))) 14 | 15 | (executable 16 | (name suite_lwt) 17 | (libraries alcotest alcotest-lwt lwt.unix rpclib rpclib-lwt rpclib.json 18 | threads) 19 | (modules suite_lwt client_lwt_new) 20 | (preprocess 21 | (pps ppx_deriving_rpc))) 22 | 23 | (rule 24 | (alias runtest) 25 | (package ppx_deriving_rpc) 26 | (deps 27 | (:s suite.exe) 28 | (source_tree .)) 29 | (action 30 | (run %{s}))) 31 | 32 | (rule 33 | (alias runtest) 34 | (package rpclib-async) 35 | (deps 36 | (:s suite_async.exe) 37 | (source_tree .)) 38 | (action 39 | (run %{s}))) 40 | 41 | (rule 42 | (alias runtest) 43 | (package rpclib-lwt) 44 | (deps 45 | (:s suite_lwt.exe) 46 | (source_tree .)) 47 | (action 48 | (run %{s}))) 49 | -------------------------------------------------------------------------------- /tests/rpc/python/calc_impl/Calc.add: -------------------------------------------------------------------------------- 1 | calc.py -------------------------------------------------------------------------------- /tests/rpc/python/calc_impl/Calc.land: -------------------------------------------------------------------------------- 1 | calc.py -------------------------------------------------------------------------------- /tests/rpc/python/calc_impl/Calc.noop: -------------------------------------------------------------------------------- 1 | calc.py -------------------------------------------------------------------------------- /tests/rpc/python/calc_impl/calc.py: -------------------------------------------------------------------------------- 1 | """ 2 | Test for the generated Python commadline code. 3 | Currently it just calls the only function in the interface called "add". 4 | """ 5 | 6 | import os 7 | import sys 8 | 9 | import bindings 10 | 11 | 12 | class CalcImplementation(object): 13 | """ 14 | Implementation of the test interface "Calc" in test_pythongen.ml 15 | """ 16 | 17 | def __init__(self): 18 | pass 19 | 20 | def add(self, int1, int2): 21 | """Add two numbers""" 22 | return int1 + int2 23 | 24 | def land(self, bool1, bool2): 25 | """Logical and""" 26 | return bool1 and bool2 27 | 28 | def noop(self, bool1): 29 | """Do nothing""" 30 | pass 31 | 32 | 33 | def _call_calc_command(): 34 | """Parse the arguments and call the required command""" 35 | cmd = bindings.Calc_commandline(CalcImplementation()) 36 | base = os.path.basename(sys.argv[0]) 37 | if base == "Calc.add": 38 | cmd.add() 39 | elif base == "Calc.land": 40 | cmd.land() 41 | elif base == "Calc.noop": 42 | cmd.noop() 43 | else: 44 | raise bindings.Unimplemented(base) 45 | 46 | 47 | if __name__ == "__main__": 48 | _call_calc_command() 49 | -------------------------------------------------------------------------------- /tests/rpc/python/calc_test/Calc.add: -------------------------------------------------------------------------------- 1 | calc.py -------------------------------------------------------------------------------- /tests/rpc/python/calc_test/Calc.land: -------------------------------------------------------------------------------- 1 | calc.py -------------------------------------------------------------------------------- /tests/rpc/python/calc_test/Calc.noop: -------------------------------------------------------------------------------- 1 | calc.py -------------------------------------------------------------------------------- /tests/rpc/python/calc_test/calc.py: -------------------------------------------------------------------------------- 1 | """ 2 | Test for the generated Python commadline code. 3 | Currently it just calls the only function in the interface called "add". 4 | """ 5 | 6 | import os 7 | import sys 8 | 9 | import bindings 10 | 11 | 12 | def _call_calc_command(): 13 | """Parse the arguments and call the required command""" 14 | cmd = bindings.Calc_commandline(bindings.Calc_test()) 15 | base = os.path.basename(sys.argv[0]) 16 | if base == "Calc.add": 17 | cmd.add() 18 | elif base == "Calc.land": 19 | cmd.land() 20 | elif base == "Calc.noop": 21 | cmd.noop() 22 | else: 23 | raise bindings.Unimplemented(base) 24 | 25 | 26 | if __name__ == "__main__": 27 | _call_calc_command() 28 | -------------------------------------------------------------------------------- /tests/rpc/python/exn_test.py: -------------------------------------------------------------------------------- 1 | """ 2 | Tests that the exceptions are correctly generated. 3 | """ 4 | 5 | import bindings 6 | 7 | if __name__ == "__main__": 8 | try: 9 | raise bindings.Error1("test") 10 | except bindings.Error1 as exn: 11 | pass 12 | try: 13 | raise bindings.Error2((4, True)) 14 | except bindings.Error2 as exn: 15 | pass 16 | try: 17 | raise bindings.Error3((4, True, "error")) 18 | except bindings.Error3 as exn: 19 | pass 20 | try: 21 | raise bindings.Error2(("4", "True")) 22 | except bindings.TypeError: 23 | pass 24 | except _: 25 | raise Exception("Should have raised TypeError") 26 | -------------------------------------------------------------------------------- /tests/rpc/suite.ml: -------------------------------------------------------------------------------- 1 | let detect_pylint () = 2 | if (abs @@ Sys.command "which pylint") + (abs @@ Sys.command "which pycodestyle") > 0 then 3 | (print_endline "Warning: pylint or pycodestyle not found... Skipping python linting tests!"; 4 | false) 5 | else true 6 | 7 | let () = 8 | Alcotest.run 9 | "rpc tests" 10 | @@ [ "Client_new", Client_new.tests ] 11 | @ if detect_pylint () then [ "Test_pythongen", Test_pythongen.tests ] else [] 12 | -------------------------------------------------------------------------------- /tests/rpc/suite_async.ml: -------------------------------------------------------------------------------- 1 | let () = Alcotest.run "rpc tests" [ "Client_async_new", Client_async_new.tests ] 2 | -------------------------------------------------------------------------------- /tests/rpc/suite_lwt.ml: -------------------------------------------------------------------------------- 1 | ;; 2 | Lwt_main.run @@ Alcotest_lwt.run "rpc lwt test" [ "Client_lwt_new", Client_lwt_new.tests ] 3 | -------------------------------------------------------------------------------- /tests/rpc/test_pythongen.ml: -------------------------------------------------------------------------------- 1 | module Interface (R : Idl.RPC) = struct 2 | open R 3 | 4 | type exns = 5 | | Error1 of string (** error 1 *) 6 | | Error2 of (int * bool) (** error 2 *) 7 | | Error3 of (int * bool * string) (** error 3 *) 8 | [@@deriving rpcty] 9 | 10 | exception Calc_error of exns 11 | 12 | let errors = 13 | let open Idl.Error in 14 | { def = exns 15 | ; raiser = (fun e -> Calc_error e) 16 | ; matcher = 17 | (function 18 | | Calc_error e -> Some e 19 | | _ -> None) 20 | } 21 | 22 | 23 | let int_p_named_1 = 24 | Idl.Param.mk ~name:"int1" ~description:[ "first int param" ] Rpc.Types.int 25 | 26 | 27 | let int_p_named_2 = 28 | Idl.Param.mk ~name:"int2" ~description:[ "second int param" ] Rpc.Types.int 29 | 30 | 31 | let int_p_result = Idl.Param.mk ~name:"int" ~description:[ "int result" ] Rpc.Types.int 32 | 33 | let add = 34 | R.declare 35 | "add" 36 | [ "Add two numbers" ] 37 | (int_p_named_1 @-> int_p_named_2 @-> returning int_p_result Idl.DefaultError.err) 38 | 39 | 40 | let bool_p_named_1 = 41 | Idl.Param.mk ~name:"bool1" ~description:[ "first bool param" ] Rpc.Types.bool 42 | 43 | 44 | let bool_p_named_2 = 45 | Idl.Param.mk ~name:"bool2" ~description:[ "second bool param" ] Rpc.Types.bool 46 | 47 | 48 | let bool_p_result = Idl.Param.mk ~description:[ "bool result" ] Rpc.Types.bool 49 | 50 | let _land = 51 | R.declare 52 | "land" 53 | [ "Logical and" ] 54 | (bool_p_named_1 @-> bool_p_named_2 @-> returning bool_p_result errors) 55 | 56 | 57 | let unit_p = Idl.Param.mk Rpc.Types.unit 58 | let noop = R.declare "noop" [ "Do nothing" ] (bool_p_named_1 @-> returning unit_p errors) 59 | 60 | let implementation = 61 | implement 62 | { Idl.Interface.name = "Calc" 63 | ; namespace = Some "Calc" 64 | ; description = [ "interface" ] 65 | ; version = 1, 0, 0 66 | } 67 | end 68 | 69 | module IfCode = Interface (Codegen.Gen ()) 70 | module UnitVInterface (R : Idl.RPC) = struct 71 | open R 72 | 73 | type unit_variant = 74 | | Empty 75 | | Hollow 76 | | Vacant 77 | | Void 78 | [@@deriving rpcty] 79 | 80 | let unit_variant_p = Idl.Param.mk ~name:"unit_variant" unit_variant 81 | let int_p = Idl.Param.mk Rpc.Types.int 82 | 83 | let discard_v = 84 | R.declare 85 | "discard_v" 86 | [ "constant function taking a unit variant and discards it by returning an integer" 87 | ] 88 | (unit_variant_p @-> returning int_p Idl.DefaultError.err) 89 | 90 | let implementation = 91 | implement 92 | { Idl.Interface.name = "UnitVInterface" 93 | ; namespace = Some "UnitVInterface" 94 | ; description = 95 | [ "Unit variant interface which does absolutely nothing. Only used to test \ 96 | whether the pythongen code can handle variants with zero argument \ 97 | constructors." 98 | ] 99 | ; version = 1, 0, 0 100 | } 101 | end 102 | 103 | module UnitVCode : sig 104 | val implementation : unit -> Codegen.Interface.t 105 | end = 106 | UnitVInterface (Codegen.Gen ()) 107 | 108 | let unitv_interface = 109 | Codegen.Interfaces.create 110 | ~name:"unitv" 111 | ~title:"Unit Variant" 112 | ~description:[ "Interface for Unit variant" ] 113 | ~interfaces:[ UnitVCode.implementation () ] 114 | 115 | let interfaces = 116 | Codegen.Interfaces.create 117 | ~name:"test_interface" 118 | ~title:"Test Interface" 119 | ~description:[ {|Test Interface for integer arithmetic|} ] 120 | ~interfaces:[ IfCode.implementation () ] 121 | 122 | 123 | let gen_python_bindings file = 124 | let oc = open_out file in 125 | output_string oc (Pythongen.of_interfaces interfaces |> Pythongen.string_of_ts); 126 | close_out oc 127 | 128 | 129 | let run_cmd msg cmd = 130 | print_endline cmd; 131 | Alcotest.(check int) msg 0 (Sys.command cmd) 132 | 133 | 134 | let run_linters file = 135 | run_cmd 136 | "pylint should exit with 0" 137 | ("pylint \ 138 | --disable=line-too-long,too-few-public-methods,unused-argument,no-self-use,invalid-name,broad-except,protected-access,redefined-builtin,useless-object-inheritance,super-with-arguments,consider-using-f-string " 139 | ^ file); 140 | run_cmd "pycodestyle should exit with 0" ("pycodestyle --ignore=W504,E501 " ^ file) 141 | 142 | 143 | let lint_bindings () = 144 | let file = "python/bindings.py" in 145 | gen_python_bindings file; 146 | run_linters file 147 | 148 | 149 | let run ?input cmd = 150 | print_endline cmd; 151 | let inp, out = Unix.open_process cmd in 152 | (match input with 153 | | Some input -> output_string out input 154 | | None -> ()); 155 | close_out out; 156 | let l = input_line inp in 157 | close_in inp; 158 | l |> String.trim 159 | 160 | 161 | let test_commandline () = 162 | gen_python_bindings "python/calc_impl/bindings.py"; 163 | let run ?input cmd = run ?input ("python python/calc_impl/" ^ cmd) in 164 | let n = run "Calc.add 4 5" in 165 | Alcotest.(check string) "Calc.add with parameters passed on the command line" "9" n; 166 | let n = run ~input:{|{"int1":3,"int2":2}|} "Calc.add --json" in 167 | Alcotest.(check string) "Calc.add with parameters passed to stdin as JSON" "5" n; 168 | let b = run "Calc.land false true" in 169 | Alcotest.(check string) "Calc.land with parameters passed on the command line" "false" b; 170 | let b = run ~input:{|{"bool1":true,"bool2":true}|} "Calc.land --json" in 171 | Alcotest.(check string) "Calc.land with parameters passed to stdin as JSON" "true" b; 172 | let b = run "Calc.noop false" in 173 | Alcotest.(check string) "Calc.noop with parameters passed on the command line" "null" b; 174 | let b = run ~input:{|{"bool1":true}|} "Calc.noop --json" in 175 | Alcotest.(check string) "Calc.noop with parameters passed to stdin as JSON" "null" b 176 | 177 | 178 | let check_test_class () = 179 | gen_python_bindings "python/calc_test/bindings.py"; 180 | let run ?input cmd = run ?input ("python python/calc_test/" ^ cmd) in 181 | run "Calc.add 4 5" |> ignore; 182 | run ~input:{|{"int1":3,"int2":2}|} "Calc.add --json" |> ignore; 183 | run "Calc.land false true" |> ignore; 184 | run ~input:{|{"bool1":true,"bool2":true}|} "Calc.land --json" |> ignore; 185 | run "Calc.noop false" |> ignore; 186 | run ~input:{|{"bool1":true}|} "Calc.noop --json" |> ignore 187 | 188 | 189 | let check_exceptions () = 190 | gen_python_bindings "python/bindings.py"; 191 | run_cmd "Exceptions should be correctly generated" "python python/exn_test.py" 192 | 193 | let check_unit_variants () = 194 | Pythongen.of_interfaces interfaces |> Pythongen.string_of_ts |> ignore 195 | 196 | let tests = 197 | [ ( "Check generated test interface bindings with pylint & pycodestyle" 198 | , `Slow 199 | , lint_bindings ) 200 | ; "Check generated commandline bindings", `Slow, test_commandline 201 | ; "Check generated test class with commandline bindings", `Slow, check_test_class 202 | ; "Check generated exceptions", `Slow, check_exceptions 203 | ; "Check python generation on variants with zero-arg constructors", `Quick, check_unit_variants 204 | ] 205 | --------------------------------------------------------------------------------