├── .dockerignore ├── .github └── workflows │ └── changelog-check.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── Dockerfile ├── LICENSE.md ├── README.md ├── dune-project ├── examples ├── client.ml ├── common.ml ├── dune ├── mirage │ ├── _tags │ ├── config.ml │ └── unikernel.ml ├── server.ml └── tree.ml ├── irmin-rpc-mirage.opam ├── irmin-rpc-unix.opam ├── irmin-rpc.opam ├── src ├── irmin-rpc-mirage │ ├── dune │ ├── irmin_rpc_mirage.ml │ └── irmin_rpc_mirage.mli ├── irmin-rpc-unix │ ├── bin │ │ ├── dune │ │ └── main.ml │ ├── dune │ ├── irmin_rpc_unix.ml │ └── irmin_rpc_unix.mli └── irmin-rpc │ ├── client.ml │ ├── client.mli │ ├── client_intf.ml │ ├── codec.ml │ ├── codec.mli │ ├── codec_intf.ml │ ├── config.ml │ ├── config.mli │ ├── config_intf.ml │ ├── dune │ ├── irmin_api.capnp │ ├── irmin_rpc.ml │ ├── raw.ml │ ├── server.ml │ ├── server.mli │ ├── server_intf.ml │ ├── utils.ml │ └── utils.mli └── test ├── common.ml ├── dune ├── test.ml ├── test.mli ├── test_disconnected.ml ├── test_disconnected.mli ├── test_utils.ml └── test_utils.mli /.dockerignore: -------------------------------------------------------------------------------- 1 | _build 2 | Dockerfile 3 | -------------------------------------------------------------------------------- /.github/workflows/changelog-check.yml: -------------------------------------------------------------------------------- 1 | name: Changelog check 2 | 3 | on: 4 | pull_request: 5 | branches: [ master ] 6 | types: [ opened, synchronize, reopened, labeled, unlabeled ] 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v1 14 | 15 | - name: git diff 16 | if: ${{ !contains(github.event.pull_request.labels.*.name, 'no-changelog-needed') }} 17 | env: 18 | BASE_REF: ${{ github.event.pull_request.base.ref }} 19 | run: | 20 | ! git diff --exit-code origin/$BASE_REF -- CHANGES.md 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam 3 | tmp 4 | *~ 5 | \.\#* 6 | \#*# 7 | *.install 8 | *.native 9 | *.byte 10 | *.merlin 11 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.18.0 2 | break-infix = fit-or-vertical 3 | parse-docstrings = true 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Unreleased 2 | 3 | - API overhaul(#13, @zshipko + @CraigFe) 4 | - Added more logging (#13, @zshipko) 5 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # base 2 | FROM ocaml/opam:4.10 as base 3 | RUN sudo apt-get update 4 | RUN sudo apt-get install -y m4 libgmp-dev perl libev-dev capnproto libcapnp-dev pkg-config 5 | RUN git -C /home/opam/opam-repository pull 6 | RUN opam update 7 | 8 | RUN opam install conf-libev irmin-unix 9 | 10 | COPY . . 11 | RUN opam config exec -- opam pin add irmin-rpc . --locked 12 | RUN opam config exec -- opam pin add irmin-rpc-unix . --locked 13 | 14 | # irmin-rpc 15 | FROM debian 16 | EXPOSE 9090 17 | COPY --from=base /home/opam/.opam/4.10/bin/irmin-rpc . 18 | COPY --from=base /usr/lib/x86_64-linux-gnu/libgmp* /usr/lib/ 19 | COPY --from=base /usr/lib/x86_64-linux-gnu/libev* /usr/lib/ 20 | VOLUME /data 21 | ENTRYPOINT [ "/irmin-rpc" ] 22 | CMD [ "-a", "0.0.0.0", \ 23 | "-p", "9090", \ 24 | "-s", "git", \ 25 | "-c", "string", \ 26 | "--root", "/data", \ 27 | "-f", "address.txt", \ 28 | "-k", "key.pem" ] 29 | 30 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Zach Shipko 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## irmin-rpc — Cap'N'Proto RPC server for Irmin 2 | 3 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Fmirage%2Firmin-rpc%2Fmaster&logo=ocaml)](https://ci.ocamllabs.io/github/mirage/irmin-rpc) 4 | 5 | %%VERSION%% 6 | 7 | `irmin-rpc` is a Cap'N'Proto RPC server and client for Irmin. It allows for 8 | remote Irmin stores to be easily queried and modified using an API that is very 9 | similar to the native Irmin API. 10 | 11 | `irmin-rpc` is distributed under the ISC license. 12 | 13 | Homepage: https://github.com/mirage/irmin-rpc 14 | 15 | ## Installation 16 | 17 | `irmin-rpc` can be installed with `opam`: 18 | 19 | ```shell 20 | $ opam pin add irmin-rpc https://github.com/mirage/irmin-rpc.git 21 | $ opam install irmin-rpc 22 | ``` 23 | 24 | After that, you will most likely want to install `irmin-rpc-unix` (or 25 | `irmin-rpc-mirage`): 26 | 27 | ```shell 28 | $ opam pin add irmin-rpc-unix https://github.com/mirage/irmin-rpc.git 29 | $ opam install irmin-rpc-unix 30 | ``` 31 | 32 | This will also install a tool named `irmin-rpc` which can be used to run an RPC 33 | server from the command line! All that's needed to get an RPC server running is: 34 | 35 | ```shell 36 | $ irmin-rpc --root /path/to/irmin/store 37 | ``` 38 | 39 | ## Example server 40 | 41 | The example below will start a server on `127.0.0.1:9999` and run it until the 42 | process is killed. To run this example execute: 43 | 44 | ```shell 45 | $ dune exec examples/server.exe --secret-key ./key.pem 46 | ``` 47 | 48 | ```ocaml 49 | open Lwt.Infix 50 | 51 | module Store = Irmin_mem.KV(Irmin.Contents.String) 52 | module Rpc = Irmin_rpc_unix.Make(Store) 53 | 54 | let main = 55 | Store.Repo.v (Irmin_mem.config ()) >>= fun repo -> 56 | Rpc.Server.create ~secret_key:`Ephemeral (`TCP ("127.0.0.1", 9999)) repo >>= fun server -> 57 | Printf.printf "Serving on: %s\n" (Uri.to_string (Rpc.Server.uri server)); 58 | Rpc.Server.run server 59 | 60 | let () = Lwt_main.run main 61 | ``` 62 | 63 | ## Example client 64 | 65 | This example shows how to connect to the server using the provided client. To 66 | run this example execute: 67 | 68 | ```shell 69 | $ dune exec examples/client.exe 70 | ``` 71 | 72 | ```ocaml 73 | open Lwt.Infix 74 | 75 | module Store = Irmin_mem.KV(Irmin.Contents.String) 76 | module Rpc = Irmin_rpc_unix.Make(Store) 77 | 78 | (* This was printed when running the server example above *) 79 | let uri = "capnp://sha-256:YIhQi5oAx0XAUJc7XnbhbNooKDds0LV9zbtsepd3X6A@127.0.0.1:9999/WUNVqiE4hrUdV6GvTvnKq6yg-8xVvJmILcLlwPUVldo" 80 | 81 | let main = 82 | Rpc.Client.connect (Uri.of_string uri) >>= fun client -> 83 | Rpc.Client.set client ["abc"] "123" >>= fun _ -> 84 | Rpc.Client.get client ["abc"] >|= function 85 | | Ok res -> assert (res = "123"); print_endline res 86 | | Error _ -> print_endline "Error encountered" 87 | 88 | let () = Lwt_main.run main 89 | ``` 90 | 91 | ## Documentation 92 | 93 | The documentation and API reference is generated from the source interfaces. It 94 | can be consulted [online][doc] or via `odig doc irmin-rpc`. 95 | 96 | [doc]: https://mirage.github.io/irmin-rpc/doc 97 | 98 | ## Tests 99 | 100 | In the distribution, sample programs and tests are located in the [`test`](test) 101 | directory. They can be built and run with: 102 | 103 | dune runtest 104 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name irmin-rpc) 3 | (implicit_transitive_deps true) 4 | -------------------------------------------------------------------------------- /examples/client.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Common 3 | module Client = Rpc.Client 4 | 5 | let () = 6 | Logs.set_level (Some Logs.Info); 7 | Logs.set_reporter (Logs_fmt.reporter ()) 8 | 9 | (* This was printed when running the server example 10 | * Something like: "capnp://sha-256:QZVBfR2-8g6nfK7cRrD763Usn5Fg0j2muRXk62BhYKI@127.0.0.1:9998/yGlvMAKwxOw4B3lYe0g9XCuV4o5cp9BOQENvSvZNpjU" *) 11 | let uri = Sys.argv.(1) 12 | 13 | let info () = 14 | Client.Info.v ~author:"rpc-client-author" ~message:"rpc-client-message" 0L 15 | 16 | let ( let* ) = Lwt.bind 17 | 18 | let main = 19 | let* client = Uri.of_string uri |> Client.connect in 20 | let* repo = Client.repo client in 21 | let* master = Client.Store.master repo in 22 | let* x = Client.ping client in 23 | let () = Result.get_ok x in 24 | let* () = Client.Store.set ~info master [ "abc" ] "123" in 25 | let* res = Client.Store.get master [ "abc" ] in 26 | assert (res = "123"); 27 | print_endline res; 28 | let* tree = Client.Store.find_tree master [ "abc" ] in 29 | let* concrete = 30 | match tree with 31 | | Some c -> Client.Tree.concrete c >>= Lwt.return_some 32 | | None -> Lwt.return_none 33 | in 34 | assert (match concrete with Some (`Contents _) -> true | _ -> false); 35 | Lwt.return () 36 | 37 | let () = Lwt_main.run main 38 | -------------------------------------------------------------------------------- /examples/common.ml: -------------------------------------------------------------------------------- 1 | module Maker = 2 | Irmin_pack.Maker 3 | (struct 4 | let version = `V1 5 | end) 6 | (struct 7 | let stable_hash = 32 8 | 9 | let entries = 32 10 | end) 11 | 12 | module Store = 13 | Maker.Make (Irmin.Metadata.None) (Irmin.Contents.String) 14 | (Irmin.Path.String_list) 15 | (Irmin.Branch.String) 16 | (Irmin.Hash.BLAKE2B) 17 | module Rpc = 18 | Irmin_rpc_unix.Make 19 | (Store) 20 | (Irmin_rpc.Config.Remote.None (Store)) 21 | (Irmin_rpc.Config.Pack.Make (Store)) 22 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names client server tree) 3 | (libraries checkseum.c digestif.c irmin-unix irmin-rpc-unix lwt lwt.unix uri 4 | capnp-rpc-unix)) 5 | 6 | (alias 7 | (name runtest) 8 | (package irmin-rpc-unix) 9 | (deps client.exe server.exe)) 10 | -------------------------------------------------------------------------------- /examples/mirage/_tags: -------------------------------------------------------------------------------- 1 | true: package(digestif.ocaml checkseum.ocaml) 2 | -------------------------------------------------------------------------------- /examples/mirage/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | foreign 5 | ~packages:[ package "duration"; package "irmin-rpc-mirage" ] 6 | "Unikernel.Main" 7 | (random @-> mclock @-> pclock @-> time @-> stackv4 @-> job) 8 | 9 | let stack = static_ipv4_stack default_network 10 | 11 | let packages = [ package "digestif" ] 12 | 13 | let () = 14 | register ~packages "irmin-rpc" 15 | [ 16 | main 17 | $ default_random 18 | $ default_monotonic_clock 19 | $ default_posix_clock 20 | $ default_time 21 | $ stack; 22 | ] 23 | -------------------------------------------------------------------------------- /examples/mirage/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Store = Irmin_mem.KV (Irmin.Contents.String) 3 | 4 | module Main 5 | (Random : Mirage_random.S) 6 | (Mclock : Mirage_clock.MCLOCK) 7 | (Pclock : Mirage_clock.PCLOCK) 8 | (Time : Mirage_time.S) 9 | (Stack : Mirage_stack.V4) = 10 | struct 11 | module Rpc = 12 | Irmin_rpc_mirage.Make 13 | (Store) 14 | (Irmin_rpc.Config.Remote.None (Store)) 15 | (Random) 16 | (Mclock) 17 | (Pclock) 18 | (Time) 19 | (Stack) 20 | 21 | let start _random _mclock _pclock _time stack = 22 | let port = 8888 in 23 | let ipv4 = Stack.ipv4 stack in 24 | let addr = Stack.IPV4.get_ip ipv4 |> List.hd in 25 | let addr = Ipaddr.V4.to_string addr in 26 | Store.Repo.v (Irmin_mem.config ()) >>= fun repo -> 27 | Logs.info (fun f -> f "Running server: %s:%d" addr port); 28 | Rpc.Server.serve ~secret_key:`Ephemeral stack repo ~port ~addr 29 | end 30 | -------------------------------------------------------------------------------- /examples/server.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Common 3 | 4 | let () = 5 | Logs.set_level (Some Logs.Info); 6 | Logs.set_reporter (Logs_fmt.reporter ()) 7 | 8 | let main = 9 | let secure = 10 | if Array.length Sys.argv > 1 then not (Sys.argv.(1) = "insecure") else true 11 | in 12 | Store.Repo.v (Irmin_pack.config "db") >>= fun repo -> 13 | Rpc.Server.serve ~secret_key:`Ephemeral ~secure 14 | (`TCP ("127.0.0.1", 9999)) 15 | repo 16 | >>= fun server -> 17 | Lwt_io.printl (Uri.to_string (Rpc.Server.uri server)) >>= fun () -> 18 | fst (Lwt.wait ()) 19 | 20 | let () = Lwt_main.run main 21 | -------------------------------------------------------------------------------- /examples/tree.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | module Client = Rpc.Client 3 | 4 | let () = 5 | Logs.set_level (Some Logs.Info); 6 | Logs.set_reporter (Logs_fmt.reporter ()) 7 | 8 | (* This was printed when running the server example 9 | * Something like: "capnp://sha-256:QZVBfR2-8g6nfK7cRrD763Usn5Fg0j2muRXk62BhYKI@127.0.0.1:9998/yGlvMAKwxOw4B3lYe0g9XCuV4o5cp9BOQENvSvZNpjU" *) 10 | let uri = Sys.argv.(1) 11 | 12 | let info () = 13 | Client.Info.v ~author:"rpc-client-author" ~message:"rpc-client-message" 0L 14 | 15 | let ( let* ) = Lwt.bind 16 | 17 | let main = 18 | let* client = Uri.of_string uri |> Client.connect in 19 | let* repo = Client.repo client in 20 | let* master = Client.Store.master repo in 21 | let* tree = Client.Tree.empty repo in 22 | let* tree = Client.Tree.add tree [ "a" ] "1" in 23 | let* tree = Client.Tree.add tree [ "x"; "y"; "z" ] "999" in 24 | 25 | let* a = Client.Tree.find tree [ "a" ] in 26 | assert (Option.get a = "1"); 27 | let* xyz = Client.Tree.find tree [ "x"; "y"; "z" ] in 28 | assert (Option.get xyz = "999"); 29 | let* t = Client.Tree.find_tree tree [ "x"; "y" ] in 30 | let* z = Client.Tree.find (Option.get t) [ "z" ] in 31 | assert (Option.get z = "999"); 32 | 33 | let* tree = Client.Tree.remove tree [ "a" ] in 34 | 35 | let* () = Client.Store.set_tree master ~info [] tree in 36 | let* a = Client.Store.find master [ "a" ] in 37 | assert (Result.get_ok a = None); 38 | let* xyz = Client.Store.get master [ "x"; "y"; "z" ] in 39 | assert (xyz = "999"); 40 | Lwt.return () 41 | 42 | let () = Lwt_main.run main 43 | -------------------------------------------------------------------------------- /irmin-rpc-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Cap'n Proto RPC client/server for Irmin" 3 | maintainer: "Zach Shipko " 4 | authors: "Zach Shipko " 5 | license: "ISC" 6 | homepage: "https://github.com/mirage/irmin-rpc" 7 | doc: "https://mirage.github.io/irmin-rpc/doc" 8 | bug-reports: "https://github.com/mirage/irmin-rpc/issues" 9 | depends: [ 10 | "ocaml" {>= "4.08.0"} 11 | "dune" {>= "2.0.0"} 12 | "irmin-rpc" 13 | "irmin-mirage" {>= "dev"} 14 | "mirage-time" {>= "2.0.0"} 15 | "mirage-stack" {>= "2.0.0"} 16 | "dns-client" 17 | "capnp-rpc-mirage" {>= "0.9.0"} 18 | "capnp-rpc-lwt" {>= "0.9.0"} 19 | "capnp-rpc-net" {>= "0.9.0"} 20 | "irmin" {>= "dev"} 21 | "lwt" {>= "4.0.0"} 22 | "mirage-clock" {>= "3.0.0"} 23 | "mirage-random" {>= "2.0.0"} 24 | "uri" {>= "4.0.0"} 25 | ] 26 | build: [ 27 | ["dune" "subst"] {pinned} 28 | ["dune" "build" "-p" name "-j" jobs] 29 | ["dune" "runtest" "-p" name] {with-test} 30 | ] 31 | dev-repo: "git+ssh://github.com/mirage/irmin-rpc" 32 | 33 | 34 | pin-depends: [ 35 | [ 36 | "index.dev" 37 | "git+https://github.com/mirage/index#23e478e28662614abb4b01a7efb11532b08fb1c0" 38 | ] 39 | [ 40 | "ppx_irmin.dev" 41 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 42 | ] 43 | [ 44 | "irmin.dev" 45 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 46 | ] 47 | [ 48 | "irmin-git.dev" 49 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 50 | ] 51 | [ 52 | "irmin-fs.dev" 53 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 54 | ] 55 | [ 56 | "irmin-graphql.dev" 57 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 58 | ] 59 | [ 60 | "irmin-http.dev" 61 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 62 | ] 63 | [ 64 | "irmin-layers.dev" 65 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 66 | ] 67 | [ 68 | "irmin-pack.dev" 69 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 70 | ] 71 | [ 72 | "irmin-mirage.dev" 73 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 74 | ] 75 | ] 76 | -------------------------------------------------------------------------------- /irmin-rpc-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Cap'n Proto RPC client/server for Irmin" 3 | maintainer: "Zach Shipko " 4 | authors: "Zach Shipko " 5 | license: "ISC" 6 | homepage: "https://github.com/mirage/irmin-rpc" 7 | doc: "https://mirage.github.io/irmin-rpc/doc" 8 | bug-reports: "https://github.com/mirage/irmin-rpc/issues" 9 | depends: [ 10 | "ocaml" {>= "4.08.0"} 11 | "dune" {>= "2.0.0"} 12 | "capnp-rpc" 13 | "capnp-rpc-lwt" 14 | "capnp-rpc-unix" 15 | "capnp-rpc-net" 16 | "irmin" 17 | "irmin-rpc" 18 | "irmin-unix" {>= "dev"} 19 | "lwt" 20 | "sexplib0" 21 | "uri" 22 | "alcotest-lwt" {with-test & >= "1.0.0"} 23 | "checkseum" {>= "0.3.0"} 24 | "cmdliner" {>= "1.0.4"} 25 | "cohttp" {>= "2.0.0"} 26 | "digestif" {>= "0.9.0"} 27 | "git" {>= "3.0.0"} 28 | "git-unix" {>= "3.0.0"} 29 | "irmin-git" {>= "dev"} 30 | ] 31 | build: [ 32 | ["dune" "subst"] {pinned} 33 | ["dune" "build" "-p" name "-j" jobs] 34 | ["dune" "runtest" "-p" name] {with-test} 35 | ] 36 | dev-repo: "git+ssh://github.com/mirage/irmin-rpc" 37 | pin-depends: [ 38 | [ 39 | "index.dev" 40 | "git+https://github.com/mirage/index#23e478e28662614abb4b01a7efb11532b08fb1c0" 41 | ] 42 | [ 43 | "ppx_irmin.dev" 44 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 45 | ] 46 | [ 47 | "irmin.dev" 48 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 49 | ] 50 | [ 51 | "irmin-git.dev" 52 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 53 | ] 54 | [ 55 | "irmin-fs.dev" 56 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 57 | ] 58 | [ 59 | "irmin-graphql.dev" 60 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 61 | ] 62 | [ 63 | "irmin-http.dev" 64 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 65 | ] 66 | [ 67 | "irmin-layers.dev" 68 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 69 | ] 70 | [ 71 | "irmin-pack.dev" 72 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 73 | ] 74 | [ 75 | "irmin-unix.dev" 76 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 77 | ] 78 | ] 79 | -------------------------------------------------------------------------------- /irmin-rpc.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Cap'n Proto RPC client/server for Irmin" 3 | maintainer: "Zach Shipko " 4 | authors: "Zach Shipko " 5 | license: "ISC" 6 | homepage: "https://github.com/mirage/irmin-rpc" 7 | doc: "https://mirage.github.io/irmin-rpc/doc" 8 | bug-reports: "https://github.com/mirage/irmin-rpc/issues" 9 | depends: [ 10 | "ocaml" {>= "4.08.0"} 11 | "dune" {>= "2.0.0"} 12 | "capnp" 13 | "capnp-rpc" 14 | "capnp-rpc-lwt" 15 | "capnp-rpc-net" 16 | "cohttp" 17 | "fmt" 18 | "irmin" {>= "dev"} 19 | "lwt" 20 | "result" {>= "1.5"} 21 | "logs" {>= "0.7.0"} 22 | "repr" {>= "0.2.0"} 23 | "alcotest" {>= "1.0.0" & with-test} 24 | "alcotest-lwt" {>= "1.0.0" & with-test} 25 | ] 26 | build: [ 27 | ["dune" "subst"] {pinned} 28 | ["dune" "build" "-p" name "-j" jobs] 29 | ["dune" "runtest" "-p" name] {with-test} 30 | ] 31 | dev-repo: "git+ssh://github.com/mirage/irmin-rpc" 32 | pin-depends: [ 33 | [ 34 | "ppx_irmin.dev" 35 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 36 | ] 37 | [ 38 | "index.dev" 39 | "git+https://github.com/mirage/index#23e478e28662614abb4b01a7efb11532b08fb1c0" 40 | ] 41 | [ 42 | "irmin.dev" 43 | "git+https://github.com/mirage/irmin#8f20cadd955c21895214c5105daa239f61f06413" 44 | ] 45 | ] 46 | -------------------------------------------------------------------------------- /src/irmin-rpc-mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irmin_rpc_mirage) 3 | (public_name irmin-rpc-mirage) 4 | (libraries irmin irmin-rpc capnp-rpc-mirage capnp-rpc-net capnp-rpc-lwt 5 | irmin-mirage mirage-time dns-client dns-client.mirage mirage-random 6 | mirage-clock mirage-stack lwt uri)) 7 | -------------------------------------------------------------------------------- /src/irmin-rpc-mirage/irmin_rpc_mirage.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Make 4 | (Store : Irmin.S) 5 | (Remote : Irmin_rpc.Config.REMOTE 6 | with type t = Store.Private.Remote.endpoint) 7 | (Random : Mirage_random.S) 8 | (Mclock : Mirage_clock.MCLOCK) 9 | (Pclock : Mirage_clock.PCLOCK) 10 | (Time : Mirage_time.S) 11 | (Stack : Mirage_stack.V4V6) = 12 | struct 13 | module Capnp_rpc_mirage = 14 | Capnp_rpc_mirage.Make (Random) (Time) (Mclock) (Stack) 15 | module Dns = Capnp_rpc_mirage.Network.Dns 16 | 17 | module Server = struct 18 | module Rpc = 19 | Irmin_rpc.Make (Store) (Remote) (Irmin_rpc.Config.Pack.None (Store)) 20 | 21 | let serve ~secret_key ?switch ?serve_tls ?(port = 1111) stack ~addr repo = 22 | let dns = Dns.create stack in 23 | let net = Capnp_rpc_mirage.network ~dns stack in 24 | let public_address = `TCP (addr, port) in 25 | let config = 26 | Capnp_rpc_mirage.Vat_config.create ~public_address ~secret_key 27 | ?serve_tls (`TCP port) 28 | in 29 | let service_id = 30 | match serve_tls with 31 | | Some true | None -> 32 | Capnp_rpc_mirage.Vat_config.derived_id config "main" 33 | | Some false -> Capnp_rpc_net.Restorer.Id.public "" 34 | in 35 | let restore = 36 | Capnp_rpc_net.Restorer.single service_id (Rpc.Server.local repo) 37 | in 38 | Capnp_rpc_mirage.serve ?switch net config ~restore >|= fun vat -> 39 | Capnp_rpc_mirage.Vat.sturdy_uri vat service_id 40 | 41 | include Rpc.Server 42 | end 43 | 44 | module Client = struct 45 | include 46 | Irmin_rpc.Client.Make (Store) (Remote) 47 | (Irmin_rpc.Config.Pack.None (Store)) 48 | 49 | let connect stack uri = 50 | let dns = Dns.create stack in 51 | let net = Capnp_rpc_mirage.network ~dns stack in 52 | let client_vat = Capnp_rpc_mirage.client_only_vat net in 53 | let sr = Capnp_rpc_mirage.Vat.import_exn client_vat uri in 54 | Capnp_rpc_lwt.Sturdy_ref.connect_exn sr 55 | end 56 | end 57 | -------------------------------------------------------------------------------- /src/irmin-rpc-mirage/irmin_rpc_mirage.mli: -------------------------------------------------------------------------------- 1 | module Make 2 | (Store : Irmin.S) 3 | (Remote : Irmin_rpc.Config.REMOTE 4 | with type t = Store.Private.Remote.endpoint) 5 | (Random : Mirage_random.S) 6 | (Mclock : Mirage_clock.MCLOCK) 7 | (Pclock : Mirage_clock.PCLOCK) 8 | (Time : Mirage_time.S) 9 | (Stack : Mirage_stack.V4V6) : sig 10 | module Server : sig 11 | include 12 | Irmin_rpc.Server.S 13 | with type repo = Store.repo 14 | and type store = Store.t 15 | and type commit = Store.commit 16 | and type hash = Store.hash 17 | 18 | val serve : 19 | secret_key:[< `PEM of string | `Ephemeral ] -> 20 | ?switch:Lwt_switch.t -> 21 | ?serve_tls:bool -> 22 | ?port:int -> 23 | Stack.t -> 24 | addr:string -> 25 | repo -> 26 | Uri.t Lwt.t 27 | end 28 | 29 | module Client : sig 30 | include 31 | Irmin_rpc.Client.S 32 | with type branch = Store.branch 33 | and type key = Store.key 34 | and type step = Store.Key.step 35 | and type contents = Store.contents 36 | and type hash = Store.hash 37 | and module Key = Store.Key 38 | and module Hash = Store.Hash 39 | 40 | val connect : Stack.t -> Uri.t -> t Lwt.t 41 | end 42 | end 43 | -------------------------------------------------------------------------------- /src/irmin-rpc-unix/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name irmin-rpc) 4 | (package irmin-rpc-unix) 5 | (libraries cmdliner checkseum.c digestif.c irmin irmin-rpc-unix lwt lwt.unix 6 | git irmin-git irmin-unix capnp-rpc-unix uri)) 7 | -------------------------------------------------------------------------------- /src/irmin-rpc-unix/bin/main.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | open Lwt.Infix 3 | 4 | let () = 5 | Logs.set_level (Some Logs.Info); 6 | Logs.set_reporter (Logs_fmt.reporter ()) 7 | 8 | let config path = 9 | print_endline path; 10 | let head = Git.Reference.of_string "refs/heads/master" |> Result.get_ok in 11 | Irmin_git.config ~head path 12 | 13 | let run (Irmin_unix.Resolver.S ((module Store), store, _)) host port secret_key 14 | address_file insecure = 15 | let module Rpc = 16 | Irmin_rpc_unix.Make 17 | (Store) 18 | (Irmin_rpc.Config.Remote.None (Store)) 19 | (Irmin_rpc.Config.Pack.None (Store)) 20 | in 21 | let secret_key = 22 | match secret_key with Some key -> `File key | None -> `Ephemeral 23 | in 24 | let secure = not insecure in 25 | let p = 26 | store >>= fun store -> 27 | Rpc.Server.serve ~secure ~secret_key (`TCP (host, port)) (Store.repo store) 28 | >>= fun server -> 29 | let () = 30 | match address_file with 31 | | Some f -> 32 | let f = open_out f in 33 | output_string f (Uri.to_string (Rpc.Server.uri server)); 34 | close_out f 35 | | None -> 36 | Printf.printf "Serving on: %s\n%!" 37 | (Uri.to_string (Rpc.Server.uri server)) 38 | in 39 | fst (Lwt.wait ()) 40 | in 41 | Lwt_main.run p 42 | 43 | let host = 44 | let doc = "Server address" in 45 | Arg.( 46 | value & opt string "127.0.0.1" & info [ "a"; "address" ] ~docv:"HOST" ~doc) 47 | 48 | let port = 49 | let doc = "Port to listen on" in 50 | Arg.(value & opt int 9998 & info [ "p"; "port" ] ~docv:"PORT" ~doc) 51 | 52 | let secret_key = 53 | let doc = "Secret key" in 54 | Arg.( 55 | value 56 | & opt (some string) None 57 | & info [ "k"; "secret-key" ] ~docv:"FILENAME" ~doc) 58 | 59 | let address_file = 60 | let doc = "Write address to file" in 61 | Arg.( 62 | value 63 | & opt (some string) None 64 | & info [ "f"; "address-file" ] ~docv:"FILENAME" ~doc) 65 | 66 | let insecure = 67 | let doc = "Disable SSL and other security features" in 68 | Arg.(value & flag & info [ "insecure" ] ~doc) 69 | 70 | let main_t = 71 | Term.( 72 | const run 73 | $ Irmin_unix.Resolver.store 74 | $ host 75 | $ port 76 | $ secret_key 77 | $ address_file 78 | $ insecure) 79 | 80 | let () = Term.exit @@ Term.eval (main_t, Term.info "irmin-rpc") 81 | -------------------------------------------------------------------------------- /src/irmin-rpc-unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irmin_rpc_unix) 3 | (public_name irmin-rpc-unix) 4 | (libraries capnp-rpc capnp-rpc-lwt capnp-rpc-net capnp-rpc-unix irmin 5 | irmin-rpc irmin-unix lwt uri git-unix sexplib0 cohttp)) 6 | -------------------------------------------------------------------------------- /src/irmin-rpc-unix/irmin_rpc_unix.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Remote = struct 4 | module Git = struct 5 | type t = Mimic.ctx * Smart_git.Endpoint.t 6 | 7 | let encode (_, endpoint) = Fmt.to_to_string Smart_git.Endpoint.pp endpoint 8 | 9 | let decode str = 10 | Result.map (fun x -> (Mimic.empty, x)) @@ Smart_git.Endpoint.of_string str 11 | end 12 | end 13 | 14 | module Make 15 | (Store : Irmin.S) 16 | (Remote : Irmin_rpc.Config.REMOTE 17 | with type t = Store.Private.Remote.endpoint) 18 | (Pack : Irmin_rpc.Config.PACK with type repo = Store.repo) = 19 | struct 20 | module Server = struct 21 | module Api = Irmin_rpc.Server.Make (Store) (Remote) (Pack) 22 | 23 | type t = { uri : Uri.t } 24 | 25 | let uri { uri; _ } = uri 26 | 27 | let serve ?backlog ?switch ?secure:serve_tls ~secret_key addr repo = 28 | let config = 29 | Capnp_rpc_unix.Vat_config.create ?backlog ~secret_key ?serve_tls addr 30 | in 31 | let service_id = 32 | match serve_tls with 33 | | Some true | None -> Capnp_rpc_unix.Vat_config.derived_id config "main" 34 | | Some false -> Capnp_rpc_net.Restorer.Id.public "" 35 | in 36 | let restore = Capnp_rpc_net.Restorer.single service_id (Api.local repo) in 37 | Capnp_rpc_unix.serve ?switch ~restore config >|= fun vat -> 38 | { uri = Capnp_rpc_unix.Vat.sturdy_uri vat service_id } 39 | end 40 | 41 | module Client = struct 42 | include Irmin_rpc.Client.Make (Store) (Remote) (Pack) 43 | 44 | let connect uri = 45 | let client_vat = Capnp_rpc_unix.client_only_vat () in 46 | let sr = Capnp_rpc_unix.Vat.import_exn client_vat uri in 47 | Capnp_rpc_lwt.Sturdy_ref.connect_exn sr 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /src/irmin-rpc-unix/irmin_rpc_unix.mli: -------------------------------------------------------------------------------- 1 | module Remote : sig 2 | module Git : 3 | Irmin_rpc.Codec.SERIALISABLE with type t = Mimic.ctx * Smart_git.Endpoint.t 4 | end 5 | 6 | module Make 7 | (Store : Irmin.S) 8 | (Remote : Irmin_rpc.Config.REMOTE 9 | with type t = Store.Private.Remote.endpoint) 10 | (Pack : Irmin_rpc.Config.PACK with type repo = Store.repo) : sig 11 | module Server : sig 12 | type t 13 | 14 | val uri : t -> Uri.t 15 | 16 | val serve : 17 | ?backlog:int -> 18 | ?switch:Lwt_switch.t -> 19 | ?secure:bool -> 20 | secret_key:[< `File of string | `PEM of string | `Ephemeral ] -> 21 | Capnp_rpc_unix.Network.Location.t -> 22 | Store.repo -> 23 | t Lwt.t 24 | (** Initialise an Irmin RPC server hosted at the given network location 25 | serving data from the given repository. 26 | 27 | - Backlog is the maximal number of pending requests (passed to 28 | {!Unix.listen}). 29 | 30 | - If [secure] is true (default), the server performs a TLS handshake 31 | using the provided [secret_key]. Otherwise, the server will accept any 32 | unencrypted incoming connection. 33 | 34 | - Turning off the supplied Lwt switch will terminate the server 35 | asynchronously. *) 36 | end 37 | 38 | module Client : sig 39 | include 40 | Irmin_rpc.Client.S 41 | with type key = Store.key 42 | and type step = Store.Key.step 43 | and type hash = Store.hash 44 | and type branch = Store.branch 45 | and type contents = Store.contents 46 | 47 | val connect : Uri.t -> t Lwt.t 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /src/irmin-rpc/client.ml: -------------------------------------------------------------------------------- 1 | include Client_intf 2 | open Capnp_rpc_lwt 3 | open Utils 4 | open Lwt.Syntax 5 | open Lwt.Infix 6 | 7 | module type S = S 8 | 9 | module type MAKER = MAKER 10 | 11 | exception Error_message of string 12 | 13 | exception Remote_error of string 14 | 15 | let unwrap = function Ok x -> x | Error (`Msg m) -> raise (Error_message m) 16 | 17 | let ( let* ) = Lwt.bind 18 | 19 | module Make : MAKER = 20 | functor 21 | (Store : Irmin.S) 22 | (R : Config.REMOTE with type t = Store.Private.Remote.endpoint) 23 | (Pack : Config.PACK with type repo = Store.repo) 24 | -> 25 | struct 26 | module Codec = Codec.Make (Store) 27 | include Types 28 | module Key = Store.Key 29 | module Hash = Store.Hash 30 | module Info = Store.Info 31 | 32 | type t = Raw.Client.Irmin.t Capability.t 33 | 34 | type branch = Store.branch 35 | 36 | type key = Store.key 37 | 38 | type contents = Store.contents 39 | 40 | type hash = Store.hash 41 | 42 | type step = Store.Key.step 43 | 44 | type info = Store.info 45 | 46 | let remote = 47 | match R.v with 48 | | Some x -> x 49 | | None -> 50 | (module struct 51 | type t = Store.Private.Remote.endpoint 52 | 53 | let fail () = failwith "Remote API is not available" 54 | 55 | let decode _ = fail () 56 | 57 | let encode _ = fail () 58 | end) 59 | 60 | module Commit = struct 61 | type t = commit 62 | 63 | let check commit = 64 | let open Raw.Client.Commit.Check in 65 | Logs.info (fun l -> l "Commit.check"); 66 | let req = Capability.Request.create_no_args () in 67 | Capability.call_for_value commit method_id req >|= function 68 | | Ok res -> Results.bool_get res 69 | | _ -> false 70 | 71 | let of_hash repo hash : commit Lwt.t = 72 | let open Raw.Client.Repo.CommitOfHash in 73 | Logs.info (fun l -> 74 | l "Commit.of_hash: %a" (Irmin.Type.pp Store.Hash.t) hash); 75 | let req, p = Capability.Request.create Params.init_pointer in 76 | Params.hash_set p (Codec.Hash.encode hash); 77 | Lwt.return 78 | @@ Capability.call_for_caps repo method_id req 79 | Results.commit_get_pipelined 80 | 81 | let hash commit = 82 | let open Raw.Client.Commit.Hash in 83 | Logs.info (fun l -> l "Commit.hash"); 84 | let req = Capability.Request.create_no_args () in 85 | let+ res = Capability.call_for_value_exn commit method_id req in 86 | Results.hash_get res |> Codec.Hash.decode |> Result.get_ok 87 | 88 | let info commit = 89 | let open Raw.Client.Commit.Info in 90 | Logs.info (fun l -> l "Commit.info"); 91 | let req = Capability.Request.create_no_args () in 92 | let+ res = Capability.call_for_value_exn commit method_id req in 93 | Results.info_get res |> Codec.Info.decode 94 | 95 | let tree commit = 96 | let open Raw.Client.Commit.Tree in 97 | Logs.info (fun l -> l "Commit.tree"); 98 | let req = Capability.Request.create_no_args () in 99 | Capability.call_for_caps commit method_id req Results.tree_get_pipelined 100 | |> Lwt.return 101 | 102 | let parents commit = 103 | let open Raw.Client.Commit.Parents in 104 | Logs.info (fun l -> l "Commit.parents"); 105 | let req = Capability.Request.create_no_args () in 106 | let+ res = Capability.call_for_value_exn commit method_id req in 107 | Results.hashes_get_list res 108 | |> List.map (fun x -> Codec.Hash.decode x |> Result.get_ok) 109 | end 110 | 111 | module Remote = struct 112 | type t = remote 113 | 114 | type endpoint = R.t 115 | 116 | let clone t endpoint = 117 | let open Raw.Client.Remote.Clone in 118 | let (module Remote) = remote in 119 | Logs.info (fun l -> l "Remote.clone"); 120 | let req, p = Capability.Request.create Params.init_pointer in 121 | Params.endpoint_set p (Remote.encode endpoint); 122 | Capability.call_for_caps t method_id req Results.result_get_pipelined 123 | |> Lwt.return 124 | 125 | let pull t ~info endpoint = 126 | let open Raw.Client.Remote.Pull in 127 | let (module Remote) = remote in 128 | Logs.info (fun l -> l "Remote.pull"); 129 | let req, p = Capability.Request.create Params.init_pointer in 130 | Params.endpoint_set p (Remote.encode endpoint); 131 | let _ = Params.info_set_builder p (Codec.Info.encode @@ info ()) in 132 | Capability.call_for_caps t method_id req Results.result_get_pipelined 133 | |> Lwt.return 134 | 135 | let decode_push_result t = 136 | let open Raw.Reader.Remote.PushResult in 137 | match get t with 138 | | OkEmpty -> Lwt.return @@ Ok `Empty 139 | | OkHead head -> 140 | let hash = Codec.Hash.decode head |> unwrap in 141 | Lwt.return @@ Ok (`Head hash) 142 | | ErrorDetachedHead -> Lwt.return @@ Error `Detached_head 143 | | ErrorMsg msg -> Lwt.return @@ Error (`Msg msg) 144 | | Undefined _ -> Lwt.return @@ Error (`Msg "Undefined") 145 | 146 | let push t endpoint = 147 | let open Raw.Client.Remote.Push in 148 | let (module Remote) = remote in 149 | Logs.info (fun l -> l "Remote.push"); 150 | let req, p = Capability.Request.create Params.init_pointer in 151 | Params.endpoint_set p (Remote.encode endpoint); 152 | let* (x : Results.t) = Capability.call_for_value_exn t method_id req in 153 | let x = Results.result_get x in 154 | decode_push_result x 155 | end 156 | 157 | module Tree = struct 158 | type t = tree 159 | 160 | type concrete = [ `Contents of hash | `Tree of (step * concrete) list ] 161 | 162 | let empty repo = 163 | let open Raw.Client.Repo.EmptyTree in 164 | Logs.info (fun l -> l "Tree.empty"); 165 | let req = Capability.Request.create_no_args () in 166 | Capability.call_for_caps repo method_id req Results.tree_get_pipelined 167 | |> Lwt.return 168 | 169 | let check tree = 170 | let open Raw.Client.Tree.Check in 171 | Logs.info (fun l -> l "Tree.check"); 172 | let req = Capability.Request.create_no_args () in 173 | Capability.call_for_value tree method_id req >|= function 174 | | Ok res -> Results.bool_get res 175 | | _ -> false 176 | 177 | let find tree key = 178 | let open Raw.Client.Tree.Find in 179 | Logs.info (fun l -> l "Tree.find"); 180 | let req, p = Capability.Request.create Params.init_pointer in 181 | Params.key_set p (Codec.Key.encode key); 182 | let+ x = Capability.call_for_value_exn tree method_id req in 183 | if Results.has_contents x then 184 | Some (Results.contents_get x |> Codec.Contents.decode |> unwrap) 185 | else None 186 | 187 | let find_tree tree key = 188 | let open Raw.Client.Tree.FindTree in 189 | Logs.info (fun l -> l "Tree.find_tree"); 190 | let req, p = Capability.Request.create Params.init_pointer in 191 | Params.key_set p (Codec.Key.encode key); 192 | let cap = 193 | Capability.call_for_caps tree method_id req Results.tree_get_pipelined 194 | in 195 | let+ ok = check cap in 196 | if ok then Some cap else None 197 | 198 | let get_tree t key = 199 | let open Raw.Client.Tree.FindTree in 200 | log_key (module Store) "Tree.find_tree" key; 201 | let req, p = Capability.Request.create Params.init_pointer in 202 | Codec.Key.encode key |> Params.key_set p; 203 | Capability.call_for_caps t method_id req Results.tree_get_pipelined 204 | |> Lwt.return 205 | 206 | let add tree key value = 207 | let open Raw.Client.Tree.Add in 208 | Logs.info (fun l -> l "Tree.add"); 209 | let req, p = Capability.Request.create Params.init_pointer in 210 | Params.key_set p (Codec.Key.encode key); 211 | Params.contents_set p (Codec.Contents.encode value); 212 | Capability.call_for_caps tree method_id req Results.tree_get_pipelined 213 | |> Lwt.return 214 | 215 | let add_tree tree key value = 216 | let open Raw.Client.Tree.AddTree in 217 | Logs.info (fun l -> l "Tree.add_tree"); 218 | let req, p = Capability.Request.create Params.init_pointer in 219 | Params.key_set p (Codec.Key.encode key); 220 | Params.tree_set p (Some value); 221 | Capability.call_for_caps tree method_id req Results.tree_get_pipelined 222 | |> Lwt.return 223 | 224 | let mem tree key = 225 | let open Raw.Client.Tree.Mem in 226 | Logs.info (fun l -> l "Tree.mem"); 227 | let req, p = Capability.Request.create Params.init_pointer in 228 | Params.key_set p (Codec.Key.encode key); 229 | let+ x = Capability.call_for_value_exn tree method_id req in 230 | Results.exists_get x 231 | 232 | let mem_tree tree key = 233 | let open Raw.Client.Tree.MemTree in 234 | Logs.info (fun l -> l "Tree.mem_tree"); 235 | let req, p = Capability.Request.create Params.init_pointer in 236 | Params.key_set p (Codec.Key.encode key); 237 | let+ x = Capability.call_for_value_exn tree method_id req in 238 | Results.exists_get x 239 | 240 | let concrete tree = 241 | let open Raw.Client.Tree.GetConcrete in 242 | Logs.info (fun l -> l "Tree.concrete"); 243 | let req = Capability.Request.create_no_args () in 244 | let+ x = Capability.call_for_value_exn tree method_id req in 245 | let concrete = Results.concrete_get x in 246 | Codec.Tree.decode concrete 247 | 248 | let find_hash t key = 249 | let open Raw.Client.Tree.FindHash in 250 | log_key (module Store) "Tree.find_hash" key; 251 | let req, p = Capability.Request.create Params.init_pointer in 252 | Codec.Key.encode key |> Params.key_set p; 253 | let+ res = Capability.call_for_value_exn t method_id req in 254 | match Results.has_hash res with 255 | | true -> Some (Results.hash_get res |> Codec.Hash.decode |> unwrap) 256 | | false -> None 257 | 258 | let remove t key = 259 | let open Raw.Client.Tree.Remove in 260 | log_key (module Store) "Tree.remove" key; 261 | let req, p = Capability.Request.create Params.init_pointer in 262 | Codec.Key.encode key |> Params.key_set p; 263 | Capability.call_for_caps t method_id req Results.tree_get_pipelined 264 | |> Lwt.return 265 | end 266 | 267 | module St = Store 268 | 269 | module Store = struct 270 | type t = store 271 | 272 | let master t = 273 | let open Raw.Client.Repo.Master in 274 | Logs.info (fun l -> l "Store.master"); 275 | let req = Capability.Request.create_no_args () in 276 | Capability.call_for_caps t method_id req Results.store_get_pipelined 277 | |> Lwt.return 278 | 279 | let of_branch t branch = 280 | let open Raw.Client.Repo.OfBranch in 281 | Logs.info (fun l -> 282 | l "Store.of_branch: %a" (Irmin.Type.pp Store.Branch.t) branch); 283 | let req, p = Capability.Request.create Params.init_pointer in 284 | branch |> Codec.Branch.encode |> Params.branch_set p; 285 | Capability.call_for_caps t method_id req Results.store_get_pipelined 286 | |> Lwt.return 287 | 288 | let find t key = 289 | let open Raw.Client.Store.Find in 290 | log_key (module Store) "Store.find" key; 291 | let req, p = Capability.Request.create Params.init_pointer in 292 | Codec.Key.encode key |> Params.key_set p; 293 | let+ res = Capability.call_for_value_exn t method_id req in 294 | match Results.has_contents res with 295 | | true -> 296 | Result.map Option.some 297 | (Results.contents_get res |> Codec.Contents.decode) 298 | | false -> Ok None 299 | 300 | let get t key = 301 | let+ value = find t key in 302 | match value with 303 | | Ok (Some c) -> c 304 | | Ok None -> invalid_arg "Irmin_rpc: no blob found during get" 305 | | Error (`Msg m) -> raise (Remote_error m) 306 | 307 | let find_tree t key = 308 | let open Raw.Client.Store.FindTree in 309 | log_key (module Store) "Store.find_tree" key; 310 | let req, p = Capability.Request.create Params.init_pointer in 311 | Codec.Key.encode key |> Params.key_set p; 312 | let cap = 313 | Capability.call_for_caps t method_id req Results.tree_get_pipelined 314 | in 315 | let+ ok = Tree.check cap in 316 | if ok then Some cap else None 317 | 318 | let get_tree t key = 319 | let open Raw.Client.Store.FindTree in 320 | log_key (module Store) "Store.find_tree" key; 321 | let req, p = Capability.Request.create Params.init_pointer in 322 | Codec.Key.encode key |> Params.key_set p; 323 | Capability.call_for_caps t method_id req Results.tree_get_pipelined 324 | |> Lwt.return 325 | 326 | let find_hash t key = 327 | let open Raw.Client.Store.FindHash in 328 | log_key (module Store) "Store.find_hash" key; 329 | let req, p = Capability.Request.create Params.init_pointer in 330 | Codec.Key.encode key |> Params.key_set p; 331 | let+ res = Capability.call_for_value_exn t method_id req in 332 | match Results.has_hash res with 333 | | true -> Some (Results.hash_get res |> Codec.Hash.decode |> unwrap) 334 | | false -> None 335 | 336 | let set ~info t key contents = 337 | let open Raw.Client.Store.Set in 338 | log_key (module Store) "Store.set" key; 339 | let req, p = Capability.Request.create Params.init_pointer in 340 | Params.key_set p (Codec.Key.encode key); 341 | let (_ : Raw.Builder.Info.t) = 342 | info () |> Codec.Info.encode |> Params.info_set_builder p 343 | in 344 | Codec.Contents.encode contents |> Params.contents_set p; 345 | let+ _ = Capability.call_for_value_exn t method_id req in 346 | () 347 | 348 | let test_and_set ~info t key ~test ~set = 349 | let open Raw.Client.Store.TestAndSet in 350 | log_key (module Store) "Store.test_and_set" key; 351 | let req, p = Capability.Request.create Params.init_pointer in 352 | Params.key_set p (Codec.Key.encode key); 353 | let (_ : Raw.Builder.Info.t) = 354 | info () |> Codec.Info.encode |> Params.info_set_builder p 355 | in 356 | Option.iter 357 | (fun contents -> Codec.Contents.encode contents |> Params.test_set p) 358 | test; 359 | Option.iter 360 | (fun contents -> Codec.Contents.encode contents |> Params.set_set p) 361 | set; 362 | let+ x = Capability.call_for_value t method_id req in 363 | match x with Ok _ -> true | _ -> false 364 | 365 | let set_tree ~info t key tree = 366 | let open Raw.Client.Store.SetTree in 367 | log_key (module Store) "Store.set_tree" key; 368 | let req, p = Capability.Request.create Params.init_pointer in 369 | Codec.Key.encode key |> Params.key_set p; 370 | Params.tree_set p (Some tree); 371 | let (_ : Raw.Builder.Info.t) = 372 | info () |> Codec.Info.encode |> Params.info_set_builder p 373 | in 374 | let+ _ = Capability.call_for_value_exn t method_id req in 375 | () 376 | 377 | let test_and_set_tree ~info t key ~test ~set = 378 | let open Raw.Client.Store.TestAndSetTree in 379 | log_key (module Store) "Store.test_and_set_tree" key; 380 | let req, p = Capability.Request.create Params.init_pointer in 381 | Params.key_set p (Codec.Key.encode key); 382 | let (_ : Raw.Builder.Info.t) = 383 | info () |> Codec.Info.encode |> Params.info_set_builder p 384 | in 385 | Params.test_set p test; 386 | Params.set_set p set; 387 | let+ x = Capability.call_for_value t method_id req in 388 | match x with Ok _ -> true | _ -> false 389 | 390 | let remove ~info t key = 391 | let open Raw.Client.Store.Remove in 392 | log_key (module Store) "Store.remove" key; 393 | let req, p = Capability.Request.create Params.init_pointer in 394 | key |> Codec.Key.encode |> Params.key_set p; 395 | let (_ : Raw.Builder.Info.t) = 396 | info () |> Codec.Info.encode |> Params.info_set_builder p 397 | in 398 | let+ _ = Capability.call_for_value_exn t method_id req in 399 | () 400 | 401 | let merge_with_branch t ~info branch = 402 | let open Raw.Client.Store.MergeWithBranch in 403 | Logs.info (fun l -> 404 | l "Store.merge_with_branch: %a" 405 | (Irmin.Type.pp Store.Branch.t) 406 | branch); 407 | let req, p = Capability.Request.create Params.init_pointer in 408 | branch |> Codec.Branch.encode |> Params.branch_set p; 409 | let (_ : Raw.Builder.Info.t) = 410 | info () |> Codec.Info.encode |> Params.info_set_builder p 411 | in 412 | let+ res = Capability.call_for_value_exn t method_id req in 413 | Results.result_get res |> Codec.Merge_result.decode |> unwrap 414 | 415 | let remote t = 416 | if Option.is_none R.v then Lwt.return None 417 | else 418 | let open Raw.Client.Store.Remote in 419 | Logs.info (fun l -> l "Store.remote"); 420 | let req = Capability.Request.create_no_args () in 421 | Lwt.return 422 | @@ Some 423 | (Capability.call_for_caps t method_id req 424 | Results.remote_get_pipelined) 425 | 426 | let pack t = 427 | if Option.is_some Pack.v then Lwt.return None 428 | else 429 | let open Raw.Client.Store.Pack in 430 | Logs.info (fun l -> l "Store.pack"); 431 | let req = Capability.Request.create_no_args () in 432 | let cap = 433 | Capability.call_for_caps t method_id req Results.pack_get_pipelined 434 | in 435 | Lwt.return @@ Some cap 436 | 437 | let last_modified t key = 438 | let open Raw.Client.Store.LastModified in 439 | log_key (module Store) "Store.last_modified" key; 440 | let req, p = Capability.Request.create Params.init_pointer in 441 | Params.key_set p (Codec.Key.encode key); 442 | Lwt.return 443 | @@ Capability.call_for_caps t method_id req Results.commit_get_pipelined 444 | end 445 | 446 | module Pack = struct 447 | type t = pack 448 | 449 | let integrity_check ?(auto_repair = false) t = 450 | let open Raw.Client.Pack.IntegrityCheck in 451 | Logs.info (fun l -> l "Pack.integrity_check"); 452 | let req, p = Capability.Request.create Params.init_pointer in 453 | Params.auto_repair_set p auto_repair; 454 | Params.pack_set p (Some t); 455 | let* x = Capability.call_for_value_exn t method_id req in 456 | let results = Results.result_get x in 457 | Lwt.return 458 | @@ 459 | let open Raw.Reader.Pack.IntegrityCheckResult in 460 | match Raw.Reader.Pack.IntegrityCheckResult.get results with 461 | | NoError -> Ok `No_error 462 | | Fixed n -> Ok (`Fixed (Int64.to_int n)) 463 | | Corrupted n -> Error (`Corrupted (Int64.to_int n)) 464 | | CannotFix m -> Error (`Cannot_fix m) 465 | | Undefined x -> failwith ("undefined: " ^ string_of_int x) 466 | end 467 | 468 | module Branch = struct 469 | include St.Branch 470 | 471 | let list t = 472 | let open Raw.Client.Repo.BranchList in 473 | Logs.info (fun l -> l "Branch.list"); 474 | let req = Capability.Request.create_no_args () in 475 | let+ res = Capability.call_for_value_exn t method_id req in 476 | Results.branches_get_list res |> List.map (Codec.Branch.decode >> unwrap) 477 | 478 | let remove t branch = 479 | let open Raw.Client.Repo.BranchRemove in 480 | Logs.info (fun l -> 481 | l "Branch.remove: %a" (Irmin.Type.pp St.Branch.t) branch); 482 | let req, p = Capability.Request.create Params.init_pointer in 483 | branch |> Codec.Branch.encode |> Params.branch_set p; 484 | let+ _ = Capability.call_for_value_exn t method_id req in 485 | () 486 | 487 | let set t branch commit = 488 | let open Raw.Client.Repo.BranchSet in 489 | Logs.info (fun l -> 490 | l "Branch.set: %a" (Irmin.Type.pp St.Branch.t) branch); 491 | let req, p = Capability.Request.create Params.init_pointer in 492 | branch |> Codec.Branch.encode |> Params.branch_set p; 493 | Params.commit_set p (Some commit); 494 | let+ _ = Capability.call_for_value_exn t method_id req in 495 | () 496 | end 497 | 498 | module Contents = struct 499 | include St.Contents 500 | 501 | module Cache = Irmin.Private.Lru.Make (struct 502 | type t = hash 503 | 504 | let equal a b = Irmin.Type.unstage (Irmin.Type.equal St.Hash.t) a b 505 | 506 | let hash = St.Hash.short_hash 507 | end) 508 | 509 | let cache = Cache.create 16 510 | 511 | let of_hash repo hash = 512 | let open Raw.Client.Repo.ContentsOfHash in 513 | Logs.info (fun l -> l "Contents.of_hash"); 514 | if Cache.mem cache hash then Lwt.return_some (Cache.find cache hash) 515 | else 516 | let req, p = Capability.Request.create Params.init_pointer in 517 | let () = Params.hash_set p (Codec.Hash.encode hash) in 518 | let+ x = Capability.call_for_value_exn repo method_id req in 519 | if Results.has_contents x then 520 | let c = Results.contents_get x in 521 | let c = Codec.Contents.decode c |> unwrap in 522 | let () = Cache.add cache hash c in 523 | Some c 524 | else None 525 | 526 | let find store key = 527 | let+ hash = Store.find_hash store key in 528 | match hash with 529 | | None -> None 530 | | Some x -> 531 | Some 532 | (fun repo -> 533 | let+ x = of_hash repo x in 534 | Option.get x) 535 | end 536 | 537 | let repo t = 538 | let open Raw.Client.Irmin.Repo in 539 | Logs.info (fun l -> l "Irmin.repo"); 540 | let req = Capability.Request.create_no_args () in 541 | Capability.call_for_caps t method_id req Results.repo_get_pipelined 542 | |> Lwt.return 543 | 544 | let ping t = 545 | let open Raw.Client.Irmin.Ping in 546 | Logs.info (fun l -> l "Irmin.ping"); 547 | let req = Capability.Request.create_no_args () in 548 | let+ res = Capability.call_for_value t method_id req in 549 | Result.map (fun _ -> ()) res 550 | end 551 | -------------------------------------------------------------------------------- /src/irmin-rpc/client.mli: -------------------------------------------------------------------------------- 1 | include Client_intf.Client 2 | (** @inline *) 3 | -------------------------------------------------------------------------------- /src/irmin-rpc/client_intf.ml: -------------------------------------------------------------------------------- 1 | open Capnp_rpc_lwt 2 | open Irmin 3 | 4 | (* Concrete types for an RPC store. *) 5 | module Types = struct 6 | type store = Raw.Client.Store.t Capability.t 7 | 8 | type repo = Raw.Client.Repo.t Capability.t 9 | 10 | type commit = Raw.Client.Commit.t Capability.t 11 | 12 | type remote = Raw.Client.Remote.t Capability.t 13 | 14 | type pack = Raw.Client.Pack.t Capability.t 15 | 16 | type tree = Raw.Client.Tree.t Capability.t 17 | end 18 | 19 | module type S = sig 20 | type t = Raw.Client.Irmin.t Capability.t 21 | (** A handle on an Irmin RPC server. *) 22 | 23 | include module type of Types 24 | (** @inline *) 25 | 26 | type branch 27 | (** Branch type, inherited from the underlying Irmin store *) 28 | 29 | type key 30 | (** Key type, inherited from the underlying Irmin store *) 31 | 32 | type contents 33 | (** Value type, inherited from the underlying Irmin store *) 34 | 35 | type hash 36 | (** Hash type, inherited from the underlying Irmin store *) 37 | 38 | type step 39 | (** Key step, inherited from the underlying Irmin store *) 40 | 41 | type info 42 | 43 | module Key : Irmin.Path.S with type t = key and type step = step 44 | 45 | module Hash : Irmin.Hash.S with type t = hash 46 | 47 | module Info : Irmin.Info.S with type t = info 48 | 49 | module Store : sig 50 | type t = store 51 | (** Subset of the Irmin store API in which stores, repositories and commits 52 | are Capnp capabilities for optionally-remote values. *) 53 | 54 | val master : repo -> t Lwt.t 55 | (** Access the [master] branch *) 56 | 57 | val of_branch : repo -> branch -> t Lwt.t 58 | (** Access a specific branch *) 59 | 60 | val get : t -> key -> contents Lwt.t 61 | (** Get value of specified key *) 62 | 63 | val find : t -> key -> (contents option, [> `Msg of string ]) result Lwt.t 64 | (** Get value of specified key, returning an option result to avoid raising 65 | exceptions *) 66 | 67 | val find_hash : t -> key -> hash option Lwt.t 68 | (** Get the hash of the contents stored at [key], if the key exists *) 69 | 70 | val find_tree : t -> key -> tree option Lwt.t 71 | (** Find a tree from the Irmin store, if it exists *) 72 | 73 | val get_tree : t -> key -> tree Lwt.t 74 | (** Get a tree from the Irmin store *) 75 | 76 | val set : info:Info.f -> t -> key -> contents -> unit Lwt.t 77 | (** Set a value at the specified key *) 78 | 79 | val test_and_set : 80 | info:Info.f -> 81 | t -> 82 | key -> 83 | test:contents option -> 84 | set:contents option -> 85 | bool Lwt.t 86 | 87 | val set_tree : info:Info.f -> t -> key -> tree -> unit Lwt.t 88 | (** Set a tree at the specified key *) 89 | 90 | val test_and_set_tree : 91 | info:Info.f -> 92 | t -> 93 | key -> 94 | test:tree option -> 95 | set:tree option -> 96 | bool Lwt.t 97 | 98 | val remove : info:Info.f -> t -> key -> unit Lwt.t 99 | (** Remove the specified key *) 100 | 101 | val merge_with_branch : 102 | t -> info:Info.f -> branch -> (unit, Merge.conflict) result Lwt.t 103 | (** Merge the current branch with another branch *) 104 | 105 | val remote : t -> remote option Lwt.t 106 | (** Get [remote] capability *) 107 | 108 | val pack : t -> pack option Lwt.t 109 | (** Get [pack] capability *) 110 | 111 | val last_modified : t -> key -> commit Lwt.t 112 | (** Returns the last commit containing changes to the specified key *) 113 | end 114 | 115 | module Branch : sig 116 | include Irmin.Branch.S with type t = branch 117 | 118 | val list : repo -> branch list Lwt.t 119 | (** List all branches *) 120 | 121 | val remove : repo -> branch -> unit Lwt.t 122 | (** Remove a branch *) 123 | 124 | val set : repo -> branch -> commit -> unit Lwt.t 125 | (** Set branch to points to the provided commit *) 126 | end 127 | 128 | module Commit : sig 129 | type t = commit 130 | 131 | val check : commit -> bool Lwt.t 132 | 133 | val of_hash : repo -> hash -> commit Lwt.t 134 | (** Get commit from specified hash *) 135 | 136 | val hash : commit -> hash Lwt.t 137 | (** Get commit hash *) 138 | 139 | val info : commit -> Info.t Lwt.t 140 | (** Get commit info *) 141 | 142 | val parents : commit -> hash list Lwt.t 143 | (** Get commit parent hashes *) 144 | 145 | val tree : commit -> tree Lwt.t 146 | (** Get commit tree *) 147 | end 148 | 149 | module Remote : sig 150 | type endpoint 151 | (** Remote endpoint type *) 152 | 153 | type t = remote 154 | 155 | val clone : remote -> endpoint -> commit Lwt.t 156 | (** Clone remote repository *) 157 | 158 | val pull : remote -> info:Info.f -> endpoint -> commit Lwt.t 159 | (** Pull from remote repository *) 160 | 161 | val push : 162 | remote -> 163 | endpoint -> 164 | ([ `Empty | `Head of hash ], [ `Detached_head | `Msg of string ]) result 165 | Lwt.t 166 | (** Push to remote repository *) 167 | end 168 | 169 | module Pack : sig 170 | type t = pack 171 | 172 | val integrity_check : 173 | ?auto_repair:bool -> 174 | pack -> 175 | ( [ `No_error | `Fixed of int ], 176 | [ `Corrupted of int | `Cannot_fix of string ] ) 177 | result 178 | Lwt.t 179 | (** Perform pack/index integrity check *) 180 | end 181 | 182 | module Tree : sig 183 | type t = tree 184 | 185 | type concrete = [ `Contents of hash | `Tree of (step * concrete) list ] 186 | 187 | val empty : repo -> tree Lwt.t 188 | (** Create an empty tree *) 189 | 190 | val check : tree -> bool Lwt.t 191 | 192 | val find : tree -> key -> contents option Lwt.t 193 | (** Find value associated with key *) 194 | 195 | val find_tree : tree -> key -> tree option Lwt.t 196 | (** Get a subtree *) 197 | 198 | val get_tree : t -> key -> tree Lwt.t 199 | (** Get a subtree *) 200 | 201 | val add : tree -> key -> contents -> tree Lwt.t 202 | (** Add new key/value to tree *) 203 | 204 | val add_tree : tree -> key -> tree -> tree Lwt.t 205 | (** Add subtree *) 206 | 207 | val mem : tree -> key -> bool Lwt.t 208 | (** Check if contents exist at the given key *) 209 | 210 | val mem_tree : tree -> key -> bool Lwt.t 211 | (** Check if a subtree exists at the given key *) 212 | 213 | val concrete : tree -> concrete Lwt.t 214 | (** Return a concrete representation of a tree *) 215 | 216 | val find_hash : tree -> key -> hash option Lwt.t 217 | (** Get hash of contents at the given key *) 218 | 219 | val remove : tree -> key -> tree Lwt.t 220 | (** Remove a key from an existing tree *) 221 | end 222 | 223 | module Contents : sig 224 | include Irmin.Contents.S with type t = contents 225 | 226 | val of_hash : repo -> hash -> contents option Lwt.t 227 | (** Get hash from contents, this function uses caching to avoid calling to 228 | the server for every request *) 229 | 230 | val find : store -> key -> (repo -> contents Lwt.t) option Lwt.t 231 | (** Returns a function that returns the contents associated with the 232 | specified key, if available *) 233 | end 234 | 235 | val repo : t -> repo Lwt.t 236 | (** Acquire a repo handle *) 237 | 238 | val ping : t -> (unit, [> `Capnp of Capnp_rpc.Error.t ]) result Lwt.t 239 | (** Ping server *) 240 | end 241 | 242 | module type MAKER = functor 243 | (Store : Irmin.S) 244 | (Remote : Config.REMOTE with type t = Store.Private.Remote.endpoint) 245 | (Pack : Config.PACK with type repo = Store.repo) 246 | -> 247 | S 248 | with type branch = Store.branch 249 | and type key = Store.key 250 | and type contents = Store.contents 251 | and type hash = Store.hash 252 | and type Remote.endpoint = Remote.t 253 | and type step = Store.Key.step 254 | and module Key = Store.Key 255 | and module Hash = Store.Hash 256 | and type info = Store.Info.t 257 | 258 | module type Client = sig 259 | module type S = S 260 | 261 | module type MAKER = MAKER 262 | 263 | module Make : MAKER 264 | end 265 | -------------------------------------------------------------------------------- /src/irmin-rpc/codec.ml: -------------------------------------------------------------------------------- 1 | include Codec_intf 2 | open Lwt.Syntax 3 | 4 | exception Error_message of string 5 | 6 | let unwrap = function Ok x -> x | Error (`Msg m) -> raise (Error_message m) 7 | 8 | let errorf fmt = Format.kasprintf (fun m -> Error (`Msg m)) fmt 9 | 10 | let codec_of_type (type a) (t : a Irmin.Type.t) = 11 | let encode = Irmin.Type.to_string t 12 | and decode s = 13 | (Irmin.Type.of_string t s 14 | : (a, [ `Msg of _ ]) result 15 | :> (a, [> `Msg of _ ]) result) 16 | in 17 | (encode, decode) 18 | 19 | module Make (Store : Irmin.S) = struct 20 | module Branch = struct 21 | type t = Store.branch 22 | 23 | let encode, decode = codec_of_type Store.Branch.t 24 | end 25 | 26 | module Key = struct 27 | type t = Store.key 28 | 29 | let encode, decode = codec_of_type Store.Key.t 30 | 31 | module Step = struct 32 | type t = Store.step 33 | 34 | let encode, decode = codec_of_type Store.Key.step_t 35 | end 36 | end 37 | 38 | module Hash = struct 39 | type t = Store.hash 40 | 41 | let encode, decode = codec_of_type Store.Hash.t 42 | end 43 | 44 | module Contents = struct 45 | type t = Store.contents 46 | 47 | let encode, decode = codec_of_type Store.Contents.t 48 | end 49 | 50 | module Info = struct 51 | type t = Store.Info.t 52 | 53 | let encode : t -> Raw.Builder.Info.t = 54 | fun t -> 55 | let open Raw.Builder.Info in 56 | let b = init_root () in 57 | author_set b (Store.Info.author t); 58 | message_set b (Store.Info.message t); 59 | date_set b (Store.Info.date t); 60 | b 61 | 62 | let decode : Raw.Reader.Info.t -> t = 63 | fun str -> 64 | let open Raw.Reader.Info in 65 | let author = author_get str 66 | and message = message_get str 67 | and date = date_get str in 68 | Store.Info.v ~author ~message date 69 | end 70 | 71 | module Tree = struct 72 | type t = [ `Contents of Store.hash | `Tree of (Store.step * t) list ] 73 | 74 | let rec of_irmin_tree (x : Store.tree) : t Lwt.t = 75 | match Store.Tree.destruct x with 76 | | `Contents (c, _) -> Lwt.return @@ `Contents (Store.Tree.Contents.hash c) 77 | | `Node node -> 78 | let* l = Store.Tree.list (Store.Tree.of_node node) Store.Key.empty in 79 | let+ x = 80 | Lwt_list.map_s 81 | (fun (step, tree) -> 82 | let+ x = of_irmin_tree tree in 83 | (step, x)) 84 | l 85 | in 86 | `Tree x 87 | 88 | let to_irmin_tree repo (t : t) : Store.tree Lwt.t = 89 | let rec inner repo t = 90 | match t with 91 | | `Contents hash -> 92 | let+ x = 93 | Store.Tree.of_hash repo (`Contents (hash, Store.Metadata.default)) 94 | in 95 | Option.get x 96 | | `Tree l -> 97 | Lwt_list.fold_left_s 98 | (fun acc (step, tree) -> 99 | let* t = inner repo tree in 100 | Store.Tree.add_tree acc (Store.Key.v [ step ]) t) 101 | Store.Tree.empty l 102 | in 103 | inner repo t 104 | 105 | let encode (tree : t) : Raw.Builder.Tree.Concrete.t Lwt.t = 106 | let rec inner tr key (tree : t) = 107 | let module B = Raw.Builder in 108 | let module R = Raw.Reader in 109 | B.Tree.Concrete.key_set tr (Key.encode key); 110 | match tree with 111 | | `Contents hash -> 112 | let s = Hash.encode hash in 113 | ignore (B.Tree.Concrete.contents_set tr s); 114 | Lwt.return_unit 115 | | `Tree l -> 116 | let* l = 117 | Lwt_list.map_p 118 | (fun (step, tree) -> 119 | let node = B.Tree.Node.init_root () in 120 | B.Tree.Node.step_set node (Key.Step.encode step); 121 | let tt = B.Tree.Concrete.init_root () in 122 | let+ () = inner tt (Store.Key.rcons key step) tree in 123 | B.Tree.Node.tree_set_builder node tt |> ignore; 124 | node) 125 | (List.rev l) 126 | in 127 | let (_ 128 | : ( Irmin_api.rw, 129 | B.Tree.Node.t, 130 | R.builder_array_t ) 131 | Capnp.Array.t) = 132 | B.Tree.Concrete.node_set_list tr l 133 | in 134 | Lwt.return_unit 135 | in 136 | let tr = Raw.Builder.Tree.Concrete.init_root () in 137 | let+ () = inner tr Store.Key.empty tree in 138 | tr 139 | 140 | let decode (tree : Raw.Reader.Tree.Concrete.t) : t = 141 | let rec inner tree = 142 | let module Tree = Raw.Reader.Tree in 143 | let module Node = Raw.Reader.Tree.Node in 144 | match Tree.Concrete.get tree with 145 | | Node l -> 146 | Capnp.Array.to_list l 147 | |> List.map (fun node -> 148 | let step = Node.step_get node |> Key.Step.decode |> unwrap in 149 | let tree = Node.tree_get node |> inner in 150 | (step, tree)) 151 | |> fun t -> `Tree t 152 | | Contents c -> 153 | let hash = Hash.decode c |> unwrap in 154 | `Contents hash 155 | | Undefined _ -> `Tree [] 156 | in 157 | inner tree 158 | end 159 | 160 | module Commit = struct 161 | type t = Store.commit 162 | 163 | let encode : t -> Raw.Builder.Commit.Value.t Lwt.t = 164 | fun t -> 165 | let open Raw.Builder.Commit.Value in 166 | let b = Raw.Builder.Commit.Value.init_root () in 167 | hash_set b (Store.Commit.hash t |> Hash.encode); 168 | let (_ : Raw.Builder.Info.t) = 169 | info_set_builder b (Store.Commit.info t |> Info.encode) 170 | in 171 | ignore 172 | (parents_set_list b (Store.Commit.parents t |> List.map Hash.encode)); 173 | let* x = Store.Commit.tree t |> Tree.of_irmin_tree in 174 | let* t = Tree.encode x in 175 | ignore (tree_set_builder b t); 176 | Lwt.return b 177 | 178 | let decode : 179 | Store.repo -> 180 | Raw.Reader.Commit.Value.t -> 181 | (t, [> `Msg of string | `Commit_not_found of Store.hash ]) result Lwt.t 182 | = 183 | fun repo str -> 184 | let open Raw.Reader.Commit.Value in 185 | match hash_get str |> Hash.decode with 186 | | Ok hash -> ( 187 | let+ commit = Store.Commit.of_hash repo hash in 188 | match commit with 189 | | Some c -> Ok c 190 | | None -> Error (`Commit_not_found hash)) 191 | | Error _ as e -> Lwt.return e 192 | end 193 | 194 | module Merge_result = struct 195 | type t = (unit, Irmin.Merge.conflict) result 196 | 197 | let encode : Raw.Builder.Store.MergeResult.t -> t -> unit = 198 | fun b t -> 199 | let open Raw.Builder.Store.MergeResult in 200 | match t with 201 | | Ok () -> ok_set b 202 | | Error (`Conflict msg) -> error_msg_set b msg 203 | 204 | let decode : 205 | Raw.Reader.Store.MergeResult.t -> (t, [ `Msg of string ]) result = 206 | fun str -> 207 | let open Raw.Reader.Store.MergeResult in 208 | match get str with 209 | | Ok -> Ok (Ok ()) 210 | | ErrorMsg m -> Ok (Error (`Conflict m)) 211 | | Undefined i -> errorf "Unknown MergeResult case with tag %i" i 212 | end 213 | 214 | module Push_result = struct 215 | type t = 216 | ( [ `Empty | `Head of Store.commit ], 217 | [ `Detached_head | `Msg of string ] ) 218 | result 219 | 220 | let encode : t -> Raw.Builder.Remote.PushResult.t Lwt.t = 221 | fun t -> 222 | let open Raw.Builder.Remote.PushResult in 223 | let b = init_root () in 224 | match t with 225 | | Ok `Empty -> 226 | ok_empty_set b; 227 | Lwt.return b 228 | | Ok (`Head c) -> 229 | Store.Commit.hash c |> Hash.encode |> ok_head_set b; 230 | Lwt.return b 231 | | Error `Detached_head -> 232 | error_detached_head_set b; 233 | Lwt.return b 234 | | Error (`Msg m) -> 235 | error_msg_set b m; 236 | Lwt.return b 237 | end 238 | 239 | let encode_commit_info cm info = 240 | let module Info = Raw.Builder.Info in 241 | let i = Store.Commit.info cm in 242 | Info.author_set info (Store.Info.author i); 243 | Info.message_set info (Store.Info.message i); 244 | Info.date_set info (Store.Info.date i) 245 | end 246 | 247 | module Unit = struct 248 | type t = unit 249 | 250 | let encode, decode = codec_of_type Irmin.Type.unit 251 | end 252 | -------------------------------------------------------------------------------- /src/irmin-rpc/codec.mli: -------------------------------------------------------------------------------- 1 | include Codec_intf.Codec 2 | (** @inline *) 3 | -------------------------------------------------------------------------------- /src/irmin-rpc/codec_intf.ml: -------------------------------------------------------------------------------- 1 | open Raw 2 | 3 | type info_struct = Builder.Info.struct_t 4 | 5 | type commit_struct = Builder.Commit.Value.struct_t 6 | 7 | type ('hash, 'step) concrete_tree = 8 | [ `Contents of 'hash | `Tree of ('step * ('hash, 'step) concrete_tree) list ] 9 | 10 | module type SERIALISABLE = sig 11 | type t 12 | 13 | val encode : t -> string 14 | 15 | val decode : string -> (t, [> `Msg of string ]) result 16 | end 17 | 18 | module type MAKER = functor (Store : Irmin.S) -> sig 19 | module Branch : SERIALISABLE with type t = Store.branch 20 | 21 | module Key : sig 22 | module Step : SERIALISABLE with type t = Store.step 23 | 24 | include SERIALISABLE with type t = Store.key 25 | end 26 | 27 | module Hash : SERIALISABLE with type t = Store.hash 28 | 29 | module Contents : SERIALISABLE with type t = Store.contents 30 | 31 | module Info : sig 32 | type t = Store.Info.t 33 | 34 | val encode : t -> Raw.Builder.Info.t 35 | 36 | val decode : Raw.Reader.Info.t -> t 37 | end 38 | 39 | module Tree : sig 40 | type t = (Store.hash, Store.step) concrete_tree 41 | 42 | val of_irmin_tree : Store.tree -> t Lwt.t 43 | 44 | val to_irmin_tree : Store.repo -> t -> Store.tree Lwt.t 45 | 46 | val encode : t -> Raw.Builder.Tree.Concrete.t Lwt.t 47 | 48 | val decode : Raw.Reader.Tree.Concrete.t -> t 49 | end 50 | 51 | module Commit : sig 52 | type t = Store.commit 53 | 54 | val encode : t -> Raw.Builder.Commit.Value.t Lwt.t 55 | 56 | val decode : 57 | Store.repo -> 58 | Raw.Reader.Commit.Value.t -> 59 | (t, [> `Msg of string | `Commit_not_found of Store.hash ]) result Lwt.t 60 | end 61 | 62 | module Merge_result : sig 63 | type t = (unit, Irmin.Merge.conflict) result 64 | 65 | val encode : Raw.Builder.Store.MergeResult.t -> t -> unit 66 | 67 | val decode : 68 | Raw.Reader.Store.MergeResult.t -> (t, [ `Msg of string ]) result 69 | end 70 | 71 | module Push_result : sig 72 | type t = 73 | ( [ `Empty | `Head of Store.commit ], 74 | [ `Detached_head | `Msg of string ] ) 75 | result 76 | 77 | val encode : t -> Raw.Builder.Remote.PushResult.t Lwt.t 78 | end 79 | 80 | val encode_commit_info : Store.commit -> info_struct builder_t -> unit 81 | end 82 | 83 | module type Codec = sig 84 | module type SERIALISABLE = SERIALISABLE 85 | 86 | module Unit : SERIALISABLE with type t = unit 87 | 88 | module type MAKER = MAKER 89 | 90 | module Make : MAKER 91 | end 92 | -------------------------------------------------------------------------------- /src/irmin-rpc/config.ml: -------------------------------------------------------------------------------- 1 | include Config_intf 2 | 3 | module Remote = struct 4 | module Make (C : Codec.SERIALISABLE) = struct 5 | type t = C.t 6 | 7 | let v = Some (module C : Codec.SERIALISABLE with type t = C.t) 8 | end 9 | 10 | module None (Store : Irmin.S) = struct 11 | type t = Store.Private.Remote.endpoint 12 | 13 | let v = None 14 | end 15 | end 16 | 17 | module Pack = struct 18 | module type STORE = STORE 19 | 20 | module Make (P : STORE) = struct 21 | type repo = P.repo 22 | 23 | let v = Some (module P : STORE with type repo = P.repo) 24 | end 25 | 26 | module None (Store : Irmin.S) = struct 27 | type repo = Store.repo 28 | 29 | let v = None 30 | end 31 | end 32 | -------------------------------------------------------------------------------- /src/irmin-rpc/config.mli: -------------------------------------------------------------------------------- 1 | include Config_intf.Config 2 | -------------------------------------------------------------------------------- /src/irmin-rpc/config_intf.ml: -------------------------------------------------------------------------------- 1 | module type REMOTE = sig 2 | type t 3 | 4 | val v : (module Codec.SERIALISABLE with type t = t) option 5 | end 6 | 7 | module type STORE = sig 8 | type repo 9 | 10 | val integrity_check : 11 | ?ppf:Format.formatter -> 12 | auto_repair:bool -> 13 | repo -> 14 | ( [> `Fixed of int | `No_error ], 15 | [> `Cannot_fix of string | `Corrupted of int ] ) 16 | result 17 | end 18 | 19 | module type PACK = sig 20 | type repo 21 | 22 | val v : (module STORE with type repo = repo) option 23 | end 24 | 25 | module type Config = sig 26 | module type REMOTE = REMOTE 27 | 28 | module type PACK = PACK 29 | 30 | module Remote : sig 31 | module Make : functor (C : Codec.SERIALISABLE) -> REMOTE with type t = C.t 32 | 33 | module None (Store : Irmin.S) : 34 | REMOTE with type t = Store.Private.Remote.endpoint 35 | end 36 | 37 | module Pack : sig 38 | module type STORE = STORE 39 | 40 | module Make : functor (S : STORE) -> PACK with type repo = S.repo 41 | 42 | module None (Store : Irmin.S) : PACK with type repo = Store.repo 43 | end 44 | end 45 | -------------------------------------------------------------------------------- /src/irmin-rpc/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irmin_rpc) 3 | (public_name irmin-rpc) 4 | (flags :standard -w -53-55) 5 | (libraries capnp capnp-rpc capnp-rpc-lwt capnp-rpc-net cohttp fmt repr irmin 6 | lwt result logs)) 7 | 8 | (rule 9 | (targets irmin_api.ml irmin_api.mli) 10 | (action 11 | (run capnpc -o ocaml %{dep:irmin_api.capnp}))) 12 | -------------------------------------------------------------------------------- /src/irmin-rpc/irmin_api.capnp: -------------------------------------------------------------------------------- 1 | @0x96075cba27939f6f; 2 | 3 | # Store.hash 4 | using Hash = Data; 5 | 6 | # Store.contents 7 | using Contents = Data; 8 | using Endpoint = Data; 9 | using Key = Text; 10 | 11 | # Irmin.info 12 | struct Info { 13 | author @0 :Text; 14 | message @1 :Text; 15 | date @2 :Int64; 16 | } 17 | 18 | 19 | # Store.Tree 20 | interface Tree { 21 | struct Node { 22 | step @0 :Text; 23 | tree @1 :Concrete; 24 | } 25 | 26 | # Store.Tree.Concrete 27 | struct Concrete { 28 | key @0 :Key; 29 | union { 30 | contents @1 :Hash; 31 | node @2 :List(Node); 32 | } 33 | } 34 | 35 | # Get the contents associated with `key` 36 | find @0 (key :Key) -> (contents :Contents); 37 | 38 | # Get the tree with a root at `key` 39 | findTree @1 (key :Key) -> (tree :Tree); 40 | 41 | # Add a value 42 | add @2 (key :Key, contents :Contents) -> (tree :Tree); 43 | 44 | # Add a tree 45 | addTree @3 (key :Key, tree :Tree) -> (tree :Tree); 46 | 47 | # Check if there is a value associated with `key` 48 | mem @4 (key :Key) -> (exists :Bool); 49 | 50 | # Check if there is a tree associated with `key` 51 | memTree @5 (key :Key) -> (exists :Bool); 52 | 53 | # Get a concrete representation of an Irmin tree 54 | getConcrete @6 () -> (concrete :Concrete); 55 | 56 | # Get tree hash 57 | hash @7 () -> (hash :Hash); 58 | 59 | # Find hash for value associated with `key` 60 | findHash @8 (key :Key) -> (hash :Hash); 61 | 62 | # Remove a value from the tree 63 | remove @9 (key :Key) -> (tree :Tree); 64 | 65 | listKeys @10 (key :Key) -> (keys :List(Key)); 66 | 67 | # Check if tree exists 68 | check @11 () -> (bool :Bool); 69 | } 70 | 71 | interface Commit { 72 | struct Value { 73 | hash @0 :Hash; 74 | info @1 :Info; 75 | parents @2 :List(Hash); 76 | tree @3 :Tree.Concrete; 77 | } 78 | 79 | read @0 () -> (value :Value); 80 | 81 | # Get commit tree 82 | tree @1 () -> (tree :Tree); 83 | 84 | # Get commit parent hashes 85 | parents @2 () -> (hashes :List(Hash)); 86 | 87 | # Get commit info 88 | info @3 () -> (info :Info); 89 | 90 | # Get commit hash 91 | hash @4 () -> (hash :Hash); 92 | 93 | # Check if commit exists 94 | check @5 () -> (bool :Bool); 95 | } 96 | 97 | interface Remote { 98 | struct PushResult { 99 | union { 100 | okEmpty @0 :Void; 101 | okHead @1 :Hash; 102 | errorDetachedHead @2 :Void; 103 | errorMsg @3 :Text; 104 | } 105 | } 106 | 107 | # Push to a remote endpoint 108 | push @0 (endpoint :Endpoint) -> (result :PushResult); 109 | 110 | # Pull from a remote endpoint 111 | pull @1 (endpoint :Endpoint, info :Info) -> (result :Commit); 112 | 113 | # Clone a remote endpoint 114 | clone @2 (endpoint :Endpoint) -> (result :Commit); 115 | } 116 | 117 | interface Pack { 118 | struct IntegrityCheckResult { 119 | union { 120 | noError @0 :Void; 121 | fixed @1 :Int64; 122 | cannotFix @2 :Text; 123 | corrupted @3 :Int64; 124 | } 125 | } 126 | 127 | # Check the integrity of pack and index files 128 | integrityCheck @0 (pack :Pack, autoRepair :Bool) -> (result :IntegrityCheckResult); 129 | } 130 | 131 | interface Store { 132 | # Find the value for `key` 133 | find @0 (key :Key) -> (contents :Contents); 134 | 135 | # Get the tree with a root at `key` 136 | findTree @1 (key :Key) -> (tree :Tree); 137 | 138 | # Set `key` to `contents` 139 | set @2 (key :Key, contents :Contents, info :Info) -> (); 140 | 141 | # Set tree with a root at `key` 142 | setTree @3 (key :Key, tree :Tree, info :Info) -> (); 143 | 144 | # Remove the value associated with `key` 145 | remove @4 (key :Key, info :Info) -> (); 146 | 147 | # Check if contents exist at `key` 148 | mem @5 (key :Key) -> (exists :Bool); 149 | 150 | # Check if a tree exists with a root at `key` 151 | memTree @6 (key :Key) -> (exists :Bool); 152 | 153 | # Merge API on stores 154 | struct MergeResult { 155 | union { 156 | ok @0 :Void; 157 | errorMsg @1 :Text; 158 | } 159 | } 160 | 161 | # Merge the current branch with another branch 162 | mergeWithBranch @7 (branch :Text, info :Info) -> (result :MergeResult); 163 | 164 | # Access `Irmin.Remote` functionality` 165 | remote @8 () -> (remote: Remote); 166 | 167 | # Access `Irmin_pack` functionality 168 | pack @9 () -> (pack :Pack); 169 | 170 | # Get the commit that last modified `key` 171 | lastModified @10 (key :Key) -> (commit :Commit); 172 | 173 | # Get a hash of the contents stored at `key` 174 | findHash @11 (key :Key) -> (hash :Hash); 175 | 176 | testAndSet @12 (key :Key, test :Contents, set :Contents, info :Info) -> (); 177 | testAndSetTree @13 (key :Key, test :Tree, set :Tree, info :Info) -> (); 178 | } 179 | 180 | interface Repo { 181 | # Get a Store handle for the main branch 182 | master @0 () -> (store :Store); 183 | 184 | # Get a Store handle for the given branch 185 | ofBranch @1 (branch :Text) -> (store :Store); 186 | 187 | # List all branches 188 | branchList @2 () -> (branches :List(Text)); 189 | 190 | # Remove a branch 191 | branchRemove @3 (branch :Text) -> (); 192 | 193 | # Create a new branch using the given branch name and `commit` 194 | branchSet @4 (branch :Text, commit :Commit) -> (); 195 | 196 | # Find commit for `hash` 197 | commitOfHash @5 (hash :Hash) -> (commit :Commit); 198 | 199 | # Find contents for `hash` 200 | contentsOfHash @6 (hash :Hash) -> (contents :Contents); 201 | 202 | # Create an empty tree 203 | emptyTree @7 () -> (tree :Tree); 204 | } 205 | 206 | # The top-level interface of an RPC server 207 | interface Irmin { 208 | 209 | # Each RPC server monitors exactly one repository 210 | repo @0 () -> (repo :Repo); 211 | 212 | # Check availability of server 213 | ping @1 () -> (); 214 | } 215 | -------------------------------------------------------------------------------- /src/irmin-rpc/irmin_rpc.ml: -------------------------------------------------------------------------------- 1 | module Codec = Codec 2 | module Config = Config 3 | module Client = Client 4 | module Server = Server 5 | 6 | module Private = struct 7 | module Utils = Utils 8 | end 9 | 10 | module Make 11 | (Store : Irmin.S) 12 | (Remote : Config.REMOTE with type t = Store.Private.Remote.endpoint) 13 | (Pack : Config.PACK with type repo = Store.repo) = 14 | struct 15 | module Client = Client.Make (Store) (Remote) (Pack) 16 | module Server = Server.Make (Store) (Remote) (Pack) 17 | end 18 | -------------------------------------------------------------------------------- /src/irmin-rpc/raw.ml: -------------------------------------------------------------------------------- 1 | include Irmin_api.MakeRPC (Capnp_rpc_lwt) 2 | -------------------------------------------------------------------------------- /src/irmin-rpc/server.ml: -------------------------------------------------------------------------------- 1 | open Server_intf 2 | open Capnp_rpc_lwt 3 | open Lwt.Syntax 4 | open Lwt.Infix 5 | open Utils 6 | 7 | let ( let+! ) x f = Lwt.map (Result.map f) x 8 | 9 | module type S = S 10 | 11 | module type MAKER = MAKER 12 | 13 | module Log = (val Logs.src_log (Logs.Src.create "irmin.rpc" ~doc:"Irmin RPC") 14 | : Logs.LOG) 15 | 16 | let ignore_result_set r = 17 | ignore (r : (Irmin_api.rw, string, Raw.Reader.builder_array_t) Capnp.Array.t) 18 | 19 | module type RESULTS = sig 20 | type t 21 | 22 | val init_pointer : Raw.Builder.pointer_t -> t 23 | end 24 | 25 | let with_initialised_results (type t) (module Results : RESULTS with type t = t) 26 | f = 27 | let response, results = Service.Response.create Results.init_pointer in 28 | Service.return_lwt (fun () -> 29 | let+ x = f results in 30 | Result.map (fun () -> response) x) 31 | 32 | module Make : MAKER = 33 | functor 34 | (St : Irmin.S) 35 | (R : Config_intf.REMOTE with type t = St.Private.Remote.endpoint) 36 | (Pack : Config_intf.PACK with type repo = St.repo) 37 | -> 38 | struct 39 | module P = Pack 40 | 41 | let remote = 42 | match R.v with 43 | | Some x -> x 44 | | None -> 45 | (module struct 46 | type t = St.Private.Remote.endpoint 47 | 48 | let decode _ = assert false 49 | 50 | let encode _ = assert false 51 | end) 52 | 53 | module Sy = Irmin.Sync.Make (St) 54 | module Codec = Codec.Make (St) 55 | 56 | type repo = St.repo 57 | 58 | type store = St.t 59 | 60 | type commit = St.commit 61 | 62 | type hash = St.hash 63 | 64 | type info = St.info 65 | 66 | let unwrap = function 67 | | Ok x -> x 68 | | Error (`Msg m) -> failwith m 69 | | Error (`Commit_not_found h) -> 70 | Fmt.failwith "Commit not found: %a" (Irmin.Type.pp St.Hash.t) h 71 | 72 | let convert_error pp = 73 | Fmt.strf "%a" pp >> Capnp_rpc.Exception.v ~ty:`Failed >> fun e -> 74 | `Capnp (`Exception e) 75 | 76 | let process_write_error = 77 | Lwt.map 78 | (Result.map_error (convert_error (Irmin.Type.pp St.write_error_t))) 79 | 80 | module Tree = struct 81 | type t = Raw.Client.Tree.t cap 82 | 83 | let trees = Hashtbl.create 8 84 | 85 | let read (t : t) = Hashtbl.find trees t 86 | 87 | let rec local' (tree : St.tree) = 88 | let module Tree = Raw.Service.Tree in 89 | object 90 | inherit Tree.service 91 | 92 | method find_impl params release_param_caps = 93 | let open Tree.Find in 94 | let key = Params.key_get params |> Codec.Key.decode in 95 | release_param_caps (); 96 | Logs.info (fun f -> f "Tree.find"); 97 | with_initialised_results 98 | (module Results) 99 | (fun results -> 100 | let* c = St.Tree.find tree (unwrap key) in 101 | let () = 102 | Option.iter 103 | (fun x -> 104 | Results.contents_set results (Codec.Contents.encode x)) 105 | c 106 | in 107 | Lwt.return (Ok ())) 108 | 109 | method find_hash_impl params release_param_caps = 110 | let open Tree.FindHash in 111 | let key = Params.key_get params |> Codec.Key.decode in 112 | release_param_caps (); 113 | log_key_result (module St) "Tree.find_hash" key; 114 | with_initialised_results 115 | (module Results) 116 | (fun results -> 117 | let+ x = St.Tree.find tree (unwrap key) in 118 | Option.iter 119 | (fun x -> 120 | let hash = St.Contents.hash x in 121 | Codec.Hash.encode hash |> Results.hash_set results) 122 | x; 123 | Ok ()) 124 | 125 | method add_impl params release_param_caps = 126 | let open Tree.Add in 127 | let key = Params.key_get params |> Codec.Key.decode in 128 | let contents = Params.contents_get params in 129 | release_param_caps (); 130 | log_key_result (module St) "Tree.add" key; 131 | with_initialised_results 132 | (module Results) 133 | (fun results -> 134 | let contents = contents |> Codec.Contents.decode |> unwrap in 135 | let+ tree = St.Tree.add tree (unwrap key) contents in 136 | Results.tree_set results (Some (local tree)); 137 | Ok ()) 138 | 139 | method find_tree_impl params release_param_caps = 140 | let open Tree.FindTree in 141 | let key = Params.key_get params |> Codec.Key.decode in 142 | release_param_caps (); 143 | Logs.info (fun f -> f "Tree.find_tree"); 144 | with_initialised_results 145 | (module Results) 146 | (fun results -> 147 | let* (c : St.tree option) = 148 | St.Tree.find_tree tree (unwrap key) 149 | in 150 | Option.iter 151 | (fun c -> Results.tree_set results (Some (local c))) 152 | c; 153 | Lwt.return (Ok ())) 154 | 155 | method add_tree_impl params release_param_caps = 156 | let open Tree.AddTree in 157 | let key = Params.key_get params |> Codec.Key.decode in 158 | let tr = Params.tree_get params in 159 | release_param_caps (); 160 | log_key_result (module St) "Tree.add_tree" key; 161 | with_initialised_results 162 | (module Results) 163 | (fun results -> 164 | let tr = read (Option.get tr) in 165 | let+ tt = St.Tree.add_tree tree (unwrap key) tr in 166 | Results.tree_set results (Some (local tt)); 167 | Ok ()) 168 | 169 | method mem_impl params release_param_caps = 170 | let open Tree.Mem in 171 | let key = Params.key_get params |> Codec.Key.decode in 172 | release_param_caps (); 173 | Logs.info (fun f -> f "Tree.mem"); 174 | with_initialised_results 175 | (module Results) 176 | (fun results -> 177 | let* e = St.Tree.mem tree (unwrap key) in 178 | Results.exists_set results e; 179 | Lwt.return (Ok ())) 180 | 181 | method mem_tree_impl params release_param_caps = 182 | let open Tree.MemTree in 183 | let key = Params.key_get params |> Codec.Key.decode in 184 | release_param_caps (); 185 | Logs.info (fun f -> f "Tree.mem_tree"); 186 | with_initialised_results 187 | (module Results) 188 | (fun results -> 189 | let* e = St.Tree.mem_tree tree (unwrap key) in 190 | Results.exists_set results e; 191 | Lwt.return (Ok ())) 192 | 193 | method get_concrete_impl _params release_param_caps = 194 | let open Tree.GetConcrete in 195 | release_param_caps (); 196 | Logs.info (fun f -> f "Tree.get_concrete"); 197 | with_initialised_results 198 | (module Results) 199 | (fun results -> 200 | let* c = Codec.Tree.of_irmin_tree tree in 201 | let* c = Codec.Tree.encode c in 202 | ignore (Results.concrete_set_builder results c); 203 | Lwt.return (Ok ())) 204 | 205 | method hash_impl _params release_param_caps = 206 | let open Tree.Hash in 207 | release_param_caps (); 208 | Logs.info (fun f -> f "Tree.hash"); 209 | with_initialised_results 210 | (module Results) 211 | (fun results -> 212 | let hash = St.Tree.hash tree in 213 | Results.hash_set results (Codec.Hash.encode hash); 214 | Lwt.return @@ Ok ()) 215 | 216 | method remove_impl params release_param_caps = 217 | let open Tree.Remove in 218 | let key = Params.key_get params |> Codec.Key.decode in 219 | release_param_caps (); 220 | log_key_result (module St) "Tree.remove" key; 221 | with_initialised_results 222 | (module Results) 223 | (fun results -> 224 | let* tree = St.Tree.remove tree (unwrap key) in 225 | Results.tree_set results (Some (local tree)); 226 | Lwt.return @@ Ok ()) 227 | 228 | method list_keys_impl params release_param_caps = 229 | let open Tree.ListKeys in 230 | let key = Params.key_get params |> Codec.Key.decode in 231 | release_param_caps (); 232 | log_key_result (module St) "Tree.list_keys" key; 233 | with_initialised_results 234 | (module Results) 235 | (fun results -> 236 | let key = unwrap key in 237 | let* tree = St.Tree.list tree key in 238 | let l = 239 | List.map 240 | (fun (step, _) -> St.Key.rcons key step |> Codec.Key.encode) 241 | tree 242 | in 243 | Results.keys_set_list results l |> ignore; 244 | Lwt.return @@ Ok ()) 245 | 246 | method check_impl _params release_param_caps = 247 | let open Tree.Check in 248 | release_param_caps (); 249 | Logs.info (fun f -> f "Tree.check"); 250 | with_initialised_results 251 | (module Results) 252 | (fun results -> 253 | Results.bool_set results true; 254 | Lwt.return_ok ()) 255 | end 256 | |> Tree.local 257 | 258 | and local tree = 259 | let x = local' tree in 260 | Capability.when_released x (fun () -> Hashtbl.remove trees x); 261 | Hashtbl.replace trees x tree; 262 | x 263 | end 264 | 265 | module Commit = struct 266 | type t = Raw.Client.Commit.t cap 267 | 268 | let read repo t = 269 | let open Raw.Client.Commit.Read in 270 | let req = Capability.Request.create_no_args () in 271 | let* str = Capability.call_for_value_exn t method_id req in 272 | Codec.Commit.decode repo (Results.value_get str) 273 | 274 | let local commit = 275 | let module Commit = Raw.Service.Commit in 276 | object 277 | inherit Commit.service 278 | 279 | method tree_impl _params release_param_caps = 280 | let open Commit.Tree in 281 | release_param_caps (); 282 | Logs.info (fun f -> f "Commit.tree"); 283 | with_initialised_results 284 | (module Results) 285 | (fun results -> 286 | let tree = St.Commit.tree commit in 287 | let tree = Tree.local tree in 288 | let _ = Results.tree_set results (Some tree) in 289 | Capability.dec_ref tree; 290 | Lwt.return @@ Ok ()) 291 | 292 | method parents_impl _params release_param_caps = 293 | let open Commit.Parents in 294 | release_param_caps (); 295 | Logs.info (fun f -> f "Commit.parents"); 296 | with_initialised_results 297 | (module Results) 298 | (fun results -> 299 | let parents = 300 | St.Commit.parents commit |> List.map Codec.Hash.encode 301 | in 302 | ignore_result_set (Results.hashes_set_list results parents); 303 | Lwt.return (Ok ())) 304 | 305 | method info_impl _params release_param_caps = 306 | let open Commit.Info in 307 | release_param_caps (); 308 | Logs.info (fun f -> f "Commit.info"); 309 | with_initialised_results 310 | (module Results) 311 | (fun results -> 312 | let (_ : Raw.Builder.Info.t) = 313 | St.Commit.info commit 314 | |> Codec.Info.encode 315 | |> Results.info_set_builder results 316 | in 317 | Lwt.return (Ok ())) 318 | 319 | method hash_impl _params release_param_caps = 320 | let open Commit.Hash in 321 | release_param_caps (); 322 | Logs.info (fun f -> f "Commit.hash"); 323 | with_initialised_results 324 | (module Results) 325 | (fun results -> 326 | let hash = St.Commit.hash commit |> Codec.Hash.encode in 327 | Results.hash_set results hash; 328 | Lwt.return (Ok ())) 329 | 330 | method read_impl _params release_param_caps = 331 | let open Commit.Read in 332 | release_param_caps (); 333 | Logs.info (fun f -> f "Commit.read"); 334 | with_initialised_results 335 | (module Results) 336 | (fun results -> 337 | let+ (_ : Raw.Builder.Commit.Value.t) = 338 | commit 339 | |> Codec.Commit.encode 340 | >|= Results.value_set_builder results 341 | in 342 | Ok ()) 343 | 344 | method check_impl _params release_param_caps = 345 | let open Commit.Check in 346 | release_param_caps (); 347 | Logs.info (fun f -> f "Commit.check"); 348 | with_initialised_results 349 | (module Results) 350 | (fun results -> 351 | Results.bool_set results true; 352 | Lwt.return_ok ()) 353 | end 354 | |> Commit.local 355 | end 356 | 357 | module Pack = struct 358 | let local repo = 359 | let (module P) = Option.get Pack.v in 360 | let repo : P.repo = Obj.magic repo in 361 | let module Pack = Raw.Service.Pack in 362 | object 363 | inherit Pack.service 364 | 365 | method integrity_check_impl params release_param_caps = 366 | let open Pack.IntegrityCheck in 367 | let auto_repair = Params.auto_repair_get params in 368 | release_param_caps (); 369 | with_initialised_results 370 | (module Results) 371 | (fun results -> 372 | let chk = P.integrity_check ~auto_repair repo in 373 | let inner = 374 | Raw.Builder.Pack.IntegrityCheckResult.init_root () 375 | in 376 | let () = 377 | match chk with 378 | | Ok `No_error -> 379 | Raw.Builder.Pack.IntegrityCheckResult.no_error_set inner 380 | | Ok (`Fixed n) -> 381 | Raw.Builder.Pack.IntegrityCheckResult.fixed_set_int inner 382 | n 383 | | Error (`Corrupted n) -> 384 | Raw.Builder.Pack.IntegrityCheckResult.corrupted_set_int 385 | inner n 386 | | Error (`Cannot_fix m) -> 387 | Raw.Builder.Pack.IntegrityCheckResult.cannot_fix_set inner 388 | m 389 | in 390 | ignore (Results.result_set_builder results inner); 391 | Lwt.return @@ Ok ()) 392 | end 393 | |> Pack.local 394 | end 395 | 396 | module Remote = struct 397 | let remote_of_endpoint e = St.E e 398 | 399 | module type RESULT_SET = sig 400 | type t 401 | 402 | val result_set : t -> Raw.Client.Commit.t cap option -> unit 403 | end 404 | 405 | let handle_pull (type t) (module Results : RESULT_SET with type t = t) 406 | store results = function 407 | | Ok _ -> 408 | St.Head.find store >|= fun head -> 409 | let () = 410 | match head with 411 | | Some head -> 412 | let commit = Commit.local head in 413 | Results.result_set results (Some commit); 414 | Capability.dec_ref commit 415 | | _ -> () 416 | in 417 | Ok () 418 | | Error e -> Lwt.return @@ Error (convert_error Sy.pp_pull_error e) 419 | 420 | let local store = 421 | let module Remote = Raw.Service.Remote in 422 | object 423 | inherit Remote.service 424 | 425 | method push_impl params release_param_caps = 426 | let open Remote.Push in 427 | let endpoint = Params.endpoint_get params in 428 | release_param_caps (); 429 | Logs.info (fun f -> f "Remote.push"); 430 | let (module Remote) = remote in 431 | with_initialised_results 432 | (module Results) 433 | (fun results -> 434 | let remote = 435 | endpoint |> Remote.decode |> unwrap |> remote_of_endpoint 436 | in 437 | let+ (_ : Raw.Builder.Remote.PushResult.t) = 438 | Sy.push store remote 439 | >>= Codec.Push_result.encode 440 | >|= Results.result_set_builder results 441 | in 442 | Ok ()) 443 | 444 | method pull_impl params release_param_caps = 445 | let open Remote.Pull in 446 | let endpoint = Params.endpoint_get params in 447 | let info = Codec.Info.decode (Params.info_get params) in 448 | release_param_caps (); 449 | Logs.info (fun f -> f "Remote.pull"); 450 | let (module Remote) = remote in 451 | with_initialised_results 452 | (module Results) 453 | (fun results -> 454 | let remote = 455 | endpoint |> Remote.decode |> unwrap |> remote_of_endpoint 456 | in 457 | Sy.pull store remote (`Merge (fun () -> info)) 458 | >>= handle_pull 459 | (module Results : RESULT_SET with type t = Results.t) 460 | store results) 461 | 462 | method clone_impl params release_param_caps = 463 | let open Remote.Clone in 464 | let endpoint = Params.endpoint_get params in 465 | release_param_caps (); 466 | Logs.info (fun f -> f "Remote.clone"); 467 | let (module Remote) = remote in 468 | with_initialised_results 469 | (module Results) 470 | (fun results -> 471 | let remote = 472 | endpoint |> Remote.decode |> unwrap |> remote_of_endpoint 473 | in 474 | Sy.pull store remote `Set 475 | >>= handle_pull 476 | (module Results : RESULT_SET with type t = Results.t) 477 | store results) 478 | end 479 | |> Remote.local 480 | end 481 | 482 | module Store = struct 483 | type t = Raw.Client.Store.t cap 484 | 485 | let local store = 486 | let module Store = Raw.Service.Store in 487 | object 488 | inherit Store.service 489 | 490 | method find_impl params release_param_caps = 491 | let open Store.Find in 492 | let key = Params.key_get params |> Codec.Key.decode in 493 | release_param_caps (); 494 | log_key_result (module St) "Store.find" key; 495 | with_initialised_results 496 | (module Results) 497 | (fun results -> 498 | let+ x = St.find store (unwrap key) in 499 | Option.iter 500 | (fun x -> 501 | Codec.Contents.encode x |> Results.contents_set results) 502 | x; 503 | Ok ()) 504 | 505 | method find_hash_impl params release_param_caps = 506 | let open Store.FindHash in 507 | let key = Params.key_get params |> Codec.Key.decode in 508 | release_param_caps (); 509 | log_key_result (module St) "Store.find_hash" key; 510 | with_initialised_results 511 | (module Results) 512 | (fun results -> 513 | let+ x = St.find store (unwrap key) in 514 | Option.iter 515 | (fun x -> 516 | let hash = St.Contents.hash x in 517 | Codec.Hash.encode hash |> Results.hash_set results) 518 | x; 519 | Ok ()) 520 | 521 | method find_tree_impl params release_param_caps = 522 | let open Store.FindTree in 523 | let key = Params.key_get params |> Codec.Key.decode in 524 | release_param_caps (); 525 | log_key_result (module St) "Store.find_tree" key; 526 | with_initialised_results 527 | (module Results) 528 | (fun results -> 529 | let+ () = 530 | St.find_tree store (unwrap key) >|= fun tree -> 531 | Option.iter 532 | (fun tree -> 533 | let x = Tree.local tree in 534 | let () = Results.tree_set results (Some x) in 535 | Capability.dec_ref x) 536 | tree 537 | in 538 | Ok ()) 539 | 540 | method set_impl params release_param_caps = 541 | let open Store.Set in 542 | let key = Params.key_get params |> Codec.Key.decode in 543 | let info = Params.info_get params 544 | and contents = Params.contents_get params in 545 | release_param_caps (); 546 | log_key_result (module St) "Store.set" key; 547 | Service.return_lwt (fun () -> 548 | let info = info |> Codec.Info.decode 549 | and contents = contents |> Codec.Contents.decode |> unwrap in 550 | let+! () = 551 | St.set ~info:(fun () -> info) store (unwrap key) contents 552 | |> process_write_error 553 | in 554 | Service.Response.create_empty ()) 555 | 556 | method set_tree_impl params release_param_caps = 557 | let open Store.SetTree in 558 | let key = Params.key_get params |> Codec.Key.decode in 559 | let info = Params.info_get params 560 | and tree = Params.tree_get params in 561 | release_param_caps (); 562 | log_key_result (module St) "Store.set_tree" key; 563 | Service.return_lwt (fun () -> 564 | let info = info |> Codec.Info.decode in 565 | let tree = Tree.read (Option.get tree) in 566 | let+! () = 567 | St.set_tree ~info:(fun () -> info) store (unwrap key) tree 568 | |> process_write_error 569 | in 570 | Service.Response.create_empty ()) 571 | 572 | method remove_impl params release_param_caps = 573 | let open Store.Remove in 574 | let key = Params.key_get params |> Codec.Key.decode 575 | and info = Params.info_get params in 576 | release_param_caps (); 577 | log_key_result (module St) "Store.remove" key; 578 | Service.return_lwt (fun () -> 579 | let info = info |> Codec.Info.decode in 580 | let+! () = 581 | St.remove ~info:(fun () -> info) store (unwrap key) 582 | |> process_write_error 583 | in 584 | Service.Response.create_empty ()) 585 | 586 | method mem_impl params release_param_caps = 587 | let open Store.Mem in 588 | let key = Params.key_get params |> Codec.Key.decode in 589 | release_param_caps (); 590 | log_key_result (module St) "Store.mem" key; 591 | with_initialised_results 592 | (module Results) 593 | (fun results -> 594 | St.mem store (unwrap key) >|= fun exists -> 595 | Results.exists_set results exists; 596 | Ok ()) 597 | 598 | method mem_tree_impl params release_param_caps = 599 | let open Store.MemTree in 600 | let key = Params.key_get params |> Codec.Key.decode in 601 | release_param_caps (); 602 | log_key_result (module St) "Store.mem" key; 603 | with_initialised_results 604 | (module Results) 605 | (fun results -> 606 | St.mem_tree store (unwrap key) >|= fun exists -> 607 | Results.exists_set results exists; 608 | Ok ()) 609 | 610 | method merge_with_branch_impl params release_param_caps = 611 | let open Store.MergeWithBranch in 612 | let branch = Params.branch_get params 613 | and info = Params.info_get params in 614 | release_param_caps (); 615 | Logs.info (fun f -> f "Store.merge_into: :%s" branch); 616 | with_initialised_results 617 | (module Results) 618 | (fun results -> 619 | let branch = branch |> Codec.Branch.decode |> unwrap 620 | and info = info |> Codec.Info.decode in 621 | let b_merge_result = 622 | Raw.Builder.Store.MergeResult.init_root () 623 | in 624 | let+ () = 625 | St.merge_with_branch store ~info:(fun () -> info) branch 626 | >|= Codec.Merge_result.encode b_merge_result 627 | in 628 | let (_ : Raw.Builder.Store.MergeResult.t) = 629 | Results.result_set_builder results b_merge_result 630 | in 631 | Ok ()) 632 | 633 | method remote_impl _params release_param_caps = 634 | let open Store.Remote in 635 | release_param_caps (); 636 | Logs.info (fun f -> f "Store.remote"); 637 | with_initialised_results 638 | (module Results) 639 | (fun results -> 640 | if Option.is_some R.v then ( 641 | let cap = Remote.local store in 642 | Results.remote_set results (Some cap); 643 | Capability.dec_ref cap); 644 | Lwt.return @@ Ok ()) 645 | 646 | method pack_impl _params release_param_caps = 647 | let open Store.Pack in 648 | release_param_caps (); 649 | Logs.info (fun f -> f "Store.pack"); 650 | with_initialised_results 651 | (module Results) 652 | (fun results -> 653 | if Option.is_some P.v then ( 654 | let cap = Pack.local (St.repo store) in 655 | Results.pack_set results (Some cap); 656 | Capability.dec_ref cap); 657 | Lwt.return @@ Ok ()) 658 | 659 | method last_modified_impl params release_param_caps = 660 | let open Store.LastModified in 661 | let key = Params.key_get params |> Codec.Key.decode in 662 | release_param_caps (); 663 | log_key_result (module St) "Store.last_modified" key; 664 | with_initialised_results 665 | (module Results) 666 | (fun results -> 667 | St.last_modified ~n:1 store (unwrap key) >|= function 668 | | [] -> Ok () 669 | | x :: _ -> 670 | let commit = Commit.local x in 671 | Results.commit_set results (Some commit); 672 | Capability.dec_ref commit; 673 | Ok ()) 674 | 675 | method test_and_set_impl params release_param_caps = 676 | let open Store.TestAndSet in 677 | let key = Params.key_get params |> Codec.Key.decode in 678 | let info = Params.info_get params 679 | and test = 680 | if Params.has_test params then Some (Params.test_get params) 681 | else None 682 | and set = 683 | if Params.has_set params then Some (Params.set_get params) 684 | else None 685 | in 686 | release_param_caps (); 687 | log_key_result (module St) "Store.test_and_set" key; 688 | Service.return_lwt (fun () -> 689 | let info = info |> Codec.Info.decode 690 | and test = 691 | Option.map (fun x -> Codec.Contents.decode x |> unwrap) test 692 | and set = 693 | Option.map (fun x -> Codec.Contents.decode x |> unwrap) set 694 | in 695 | let+! () = 696 | St.test_and_set 697 | ~info:(fun () -> info) 698 | store (unwrap key) ~test ~set 699 | |> process_write_error 700 | in 701 | Service.Response.create_empty ()) 702 | 703 | method test_and_set_tree_impl params release_param_caps = 704 | let open Store.TestAndSetTree in 705 | let key = Params.key_get params |> Codec.Key.decode in 706 | let info = Params.info_get params 707 | and test = Params.test_get params 708 | and set = Params.set_get params in 709 | release_param_caps (); 710 | log_key_result (module St) "Store.test_and_set_tree" key; 711 | Service.return_lwt (fun () -> 712 | let info = info |> Codec.Info.decode 713 | and test = Option.map (fun x -> Tree.read x) test 714 | and set = Option.map (fun x -> Tree.read x) set in 715 | let+! () = 716 | St.test_and_set_tree 717 | ~info:(fun () -> info) 718 | store (unwrap key) ~test ~set 719 | |> process_write_error 720 | in 721 | Service.Response.create_empty ()) 722 | end 723 | |> Store.local 724 | end 725 | 726 | module Repo = struct 727 | type t = Raw.Client.Repo.t cap 728 | 729 | module BranchMap = Map.Make (struct 730 | type t = St.Branch.t 731 | 732 | let compare a b = 733 | (Irmin.Type.unstage @@ Irmin.Type.compare St.Branch.t) a b 734 | end) 735 | 736 | let local repo = 737 | let module Repo = Raw.Service.Repo in 738 | object 739 | inherit Repo.service 740 | 741 | method master_impl _params release_param_caps = 742 | let open Repo.Master in 743 | release_param_caps (); 744 | Logs.info (fun f -> f "Repo.master"); 745 | with_initialised_results 746 | (module Results) 747 | (fun results -> 748 | let+ store = St.master repo in 749 | let store_service = Store.local store in 750 | Results.store_set results (Some store_service); 751 | Capability.dec_ref store_service; 752 | Ok ()) 753 | 754 | method of_branch_impl params release_param_caps = 755 | let open Repo.OfBranch in 756 | let branch = Params.branch_get params in 757 | release_param_caps (); 758 | Log.info (fun f -> f "Repo.of_branch: %s" branch); 759 | with_initialised_results 760 | (module Results) 761 | (fun results -> 762 | let branch = branch |> Codec.Branch.decode |> unwrap in 763 | let+ store = St.of_branch repo branch in 764 | let store_service = Store.local store in 765 | Results.store_set results (Some store_service); 766 | Capability.dec_ref store_service; 767 | Ok ()) 768 | 769 | method branch_list_impl _params release_param_caps = 770 | let open Repo.BranchList in 771 | release_param_caps (); 772 | Log.info (fun f -> f "Repo.branch_list"); 773 | with_initialised_results 774 | (module Results) 775 | (fun results -> 776 | let+ branches = St.Repo.branches repo in 777 | let branches = List.map Codec.Branch.encode branches in 778 | Results.branches_set_list results branches |> ignore_result_set; 779 | Ok ()) 780 | 781 | method branch_remove_impl params release_param_caps = 782 | let open Repo.BranchRemove in 783 | let branch = Params.branch_get params in 784 | release_param_caps (); 785 | Log.info (fun f -> f "Repo.branch_remove: %s" branch); 786 | Service.return_lwt (fun () -> 787 | let branch = branch |> Codec.Branch.decode |> unwrap in 788 | let+ () = St.Branch.remove repo branch in 789 | Ok (Service.Response.create_empty ())) 790 | 791 | method branch_set_impl params release_param_caps = 792 | let open Repo.BranchSet in 793 | let branch = Params.branch_get params in 794 | let commit = Params.commit_get params |> Option.get in 795 | release_param_caps (); 796 | Service.return_lwt (fun () -> 797 | let branch = branch |> Codec.Branch.decode |> unwrap in 798 | let* commit = Commit.read repo commit >|= unwrap in 799 | let+ () = St.Branch.set repo branch commit in 800 | Ok (Service.Response.create_empty ())) 801 | 802 | method commit_of_hash_impl params release_param_caps = 803 | let open Repo.CommitOfHash in 804 | let hash = Params.hash_get params in 805 | release_param_caps (); 806 | Logs.info (fun f -> f "Repo.commit_of_hash: %s" hash); 807 | with_initialised_results 808 | (module Results) 809 | (fun results -> 810 | let hash = hash |> Codec.Hash.decode |> unwrap in 811 | let+ commit = St.Commit.of_hash repo hash in 812 | let commit = Option.map (fun c -> Commit.local c) commit in 813 | Results.commit_set results commit; 814 | Option.iter Capability.dec_ref commit; 815 | Ok ()) 816 | 817 | method contents_of_hash_impl params release_param_caps = 818 | let open Repo.ContentsOfHash in 819 | let hash = Params.hash_get params in 820 | release_param_caps (); 821 | Logs.info (fun f -> f "Repo.contents_of_hash: %s" hash); 822 | with_initialised_results 823 | (module Results) 824 | (fun results -> 825 | let hash = hash |> Codec.Hash.decode |> unwrap in 826 | let+ contents = St.Contents.of_hash repo hash in 827 | Option.iter 828 | (fun c -> 829 | let s = Codec.Contents.encode c in 830 | Results.contents_set results s) 831 | contents; 832 | Ok ()) 833 | 834 | method empty_tree_impl _params release_param_caps = 835 | let open Repo.EmptyTree in 836 | release_param_caps (); 837 | Logs.info (fun f -> f "Repo.empty_tree"); 838 | with_initialised_results 839 | (module Results) 840 | (fun results -> 841 | Results.tree_set results (Some (Tree.local St.Tree.empty)); 842 | Lwt.return @@ Ok ()) 843 | end 844 | |> Repo.local 845 | end 846 | 847 | let local ctx = 848 | let module I = Raw.Service.Irmin in 849 | object 850 | inherit I.service 851 | 852 | val repo_service = Repo.local ctx 853 | 854 | method repo_impl _params release_param_caps = 855 | let open I.Repo in 856 | release_param_caps (); 857 | Logs.info (fun f -> f "Irmin.repo"); 858 | let response, results = 859 | Service.Response.create Results.init_pointer 860 | in 861 | Capability.inc_ref repo_service; 862 | Results.repo_set results (Some repo_service); 863 | Service.return response 864 | 865 | method ping_impl _params release_param_caps = 866 | release_param_caps (); 867 | Logs.info (fun f -> f "Irmin.ping"); 868 | let response = Service.Response.create_empty () in 869 | Service.return response 870 | end 871 | |> I.local 872 | end 873 | -------------------------------------------------------------------------------- /src/irmin-rpc/server.mli: -------------------------------------------------------------------------------- 1 | include Server_intf.Server 2 | (** @inline *) 3 | -------------------------------------------------------------------------------- /src/irmin-rpc/server_intf.ml: -------------------------------------------------------------------------------- 1 | type 'a cap = 'a Capnp_rpc_lwt.Capability.t 2 | 3 | module type S = sig 4 | type repo 5 | 6 | type store 7 | 8 | type commit 9 | 10 | type hash 11 | 12 | type info 13 | 14 | module Commit : sig 15 | type t = Raw.Client.Commit.t cap 16 | 17 | val local : commit -> t 18 | 19 | val read : 20 | repo -> 21 | t -> 22 | (commit, [> `Msg of string | `Commit_not_found of hash ]) result Lwt.t 23 | end 24 | 25 | module Store : sig 26 | type t = Raw.Client.Store.t cap 27 | 28 | val local : store -> t 29 | end 30 | 31 | module Repo : sig 32 | type t = Raw.Client.Repo.t cap 33 | 34 | val local : repo -> t 35 | end 36 | 37 | val local : repo -> Raw.Client.Irmin.t cap 38 | end 39 | 40 | module type MAKER = functor 41 | (Store : Irmin.S) 42 | (Remote : Config_intf.REMOTE with type t = Store.Private.Remote.endpoint) 43 | (Pack : Config_intf.PACK with type repo = Store.repo) 44 | -> 45 | S 46 | with type repo = Store.repo 47 | and type store = Store.t 48 | and type commit = Store.commit 49 | and type hash = Store.hash 50 | and type info = Store.Info.t 51 | 52 | module type Server = sig 53 | module type S = S 54 | 55 | module type MAKER = MAKER 56 | 57 | module Make : MAKER 58 | end 59 | -------------------------------------------------------------------------------- /src/irmin-rpc/utils.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ( >> ) f g x = g (f x) 4 | 5 | module Option = struct 6 | let iter_lwt f = function Some v -> f v | None -> Lwt.return_unit 7 | 8 | let map_lwt f = function 9 | | Some v -> f v >|= Option.some 10 | | None -> Lwt.return_none 11 | 12 | include Option 13 | end 14 | 15 | module String = struct 16 | let to_list s = 17 | let rec loop acc i = if i < 0 then acc else loop (s.[i] :: acc) (i - 1) in 18 | loop [] (String.length s - 1) 19 | 20 | let is_substring sub s = 21 | let rec inner ~from chars = 22 | match chars with 23 | | [] -> true 24 | | c :: cs -> ( 25 | from < String.length s 26 | && 27 | match String.index_from_opt s from c with 28 | | Some i -> inner ~from:(i + 1) cs 29 | | None -> false) 30 | in 31 | inner ~from:0 (to_list sub) 32 | 33 | include String 34 | end 35 | 36 | let log_key (type k) (module Store : Irmin.S with type key = k) s (key : k) = 37 | if Store.Key.is_empty key then Logs.info (fun l -> l "%s: /" s) 38 | else Logs.info (fun l -> l "%s: %a" s (Irmin.Type.pp Store.Key.t) key) 39 | 40 | let log_key_result (type k) (module Store : Irmin.S with type key = k) s 41 | (key : (k, 'b) result) = 42 | match key with 43 | | Ok key -> 44 | if Store.Key.is_empty key then Logs.info (fun l -> l "%s: /" s) 45 | else Logs.info (fun l -> l "%s: %a" s (Irmin.Type.pp Store.Key.t) key) 46 | | Error (`Msg e) -> Logs.err (fun l -> l "Invalid key: %s" e) 47 | -------------------------------------------------------------------------------- /src/irmin-rpc/utils.mli: -------------------------------------------------------------------------------- 1 | val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c 2 | (** Left-to-right function composition. *) 3 | 4 | module Option : sig 5 | include module type of Option 6 | 7 | val iter_lwt : ('a -> unit Lwt.t) -> 'a option -> unit Lwt.t 8 | 9 | val map_lwt : ('a -> 'b Lwt.t) -> 'a option -> 'b option Lwt.t 10 | end 11 | 12 | module String : sig 13 | include module type of String 14 | 15 | val to_list : string -> char list 16 | (** Convert a string to a list of characters. *) 17 | 18 | val is_substring : string -> string -> bool 19 | (** [is_substring "bar" "foo bar baz"] is [true]. *) 20 | end 21 | 22 | val log_key : (module Irmin.S with type key = 'a) -> string -> 'a -> unit 23 | 24 | val log_key_result : 25 | (module Irmin.S with type key = 'a) -> 26 | string -> 27 | ('a, [ `Msg of string ]) result -> 28 | unit 29 | -------------------------------------------------------------------------------- /test/common.ml: -------------------------------------------------------------------------------- 1 | module Server = Irmin_mem.KV.Make (Irmin.Contents.String) 2 | module RPC = 3 | Irmin_rpc.Make 4 | (Server) 5 | (Irmin_rpc.Config.Remote.None (Server)) 6 | (Irmin_rpc.Config.Pack.None (Server)) 7 | 8 | (** API changes to ease test-writing. Might want to upstream these at some 9 | point. *) 10 | module Client = struct 11 | include RPC.Client.Store 12 | 13 | let of_branch = Fun.flip of_branch 14 | end 15 | 16 | (** Extended [TESTABLE]s for store types. *) 17 | module Alcotest = struct 18 | let of_typ (type a) (t : a Irmin.Type.t) : a Alcotest.testable = 19 | Alcotest.testable (Irmin.Type.pp t) 20 | (Irmin.Type.unstage @@ Irmin.Type.equal t) 21 | 22 | let msg : [ `Msg of string ] Alcotest.testable = 23 | Alcotest.testable 24 | (fun ppf (`Msg msg) -> Fmt.pf ppf "Msg %s" msg) 25 | (fun (`Msg a) (`Msg b) -> String.equal a b) 26 | 27 | (* TODO: upstream these equality functions to Capnp_rpc *) 28 | 29 | let capnp_exception_equal (a : Capnp_rpc.Exception.t) 30 | (b : Capnp_rpc.Exception.t) = 31 | String.equal a.reason b.reason 32 | && 33 | match (a.ty, b.ty) with 34 | | `Disconnected, `Disconnected 35 | | `Failed, `Failed 36 | | `Overloaded, `Overloaded 37 | | `Unimplemented, `Unimplemented -> 38 | true 39 | | `Undefined a, `Undefined b -> Int.equal a b 40 | | (`Disconnected | `Failed | `Overloaded | `Unimplemented | `Undefined _), _ 41 | -> 42 | false 43 | 44 | let capnp_error_equal (a : Capnp_rpc.Error.t) (b : Capnp_rpc.Error.t) = 45 | match (a, b) with 46 | | `Cancelled, `Cancelled -> true 47 | | `Exception a, `Exception b -> capnp_exception_equal a b 48 | | (`Cancelled | `Exception _), _ -> false 49 | 50 | let capnp_exception : Capnp_rpc.Exception.t Alcotest.testable = 51 | Alcotest.testable Capnp_rpc.Exception.pp capnp_exception_equal 52 | 53 | let capnp_error : [ `Capnp of Capnp_rpc.Error.t ] Alcotest.testable = 54 | Alcotest.testable 55 | (fun ppf (`Capnp err) -> Fmt.pf ppf "Capnp %a" Capnp_rpc.Error.pp err) 56 | (fun (`Capnp a) (`Capnp b) -> capnp_error_equal a b) 57 | 58 | let tree = of_typ Server.Tree.concrete_t 59 | 60 | let info info_t = of_typ info_t 61 | 62 | let find = Alcotest.(result (option string) msg) 63 | 64 | let find_tree = Alcotest.(option tree) 65 | 66 | include Alcotest 67 | end 68 | 69 | (** Helpers for constructing data. *) 70 | 71 | module Faker = struct 72 | let () = Random.self_init () 73 | 74 | let string ?(length = 10) () = 75 | String.init length (fun _i -> Random.int 256 |> Char.chr) 76 | 77 | let info (type a) (module Info : Irmin.Info.S with type t = a) () = 78 | let date = Random.int64 Int64.max_int 79 | and author = string () 80 | and message = string () in 81 | Info.v ~author ~message date 82 | end 83 | 84 | (** Tree with a single child. *) 85 | let stree only_key only_child = `Tree [ (only_key, only_child) ] 86 | 87 | (** Sequence of nested trees each with exactly one child. *) 88 | let strees : string list -> Server.Tree.concrete -> Server.Tree.concrete = 89 | List.fold_right stree 90 | 91 | let contents v = `Contents (v, ()) 92 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package irmin-rpc) 4 | (libraries alcotest alcotest-lwt repr irmin.mem irmin-rpc lwt lwt.unix 5 | capnp-rpc capnp-rpc-lwt fmt)) 6 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Lwt.Syntax 3 | open Common 4 | open Irmin_rpc.Private.Utils 5 | module Server = Irmin_mem.KV.Make (Irmin.Contents.String) 6 | module RPC = 7 | Irmin_rpc.Make 8 | (Server) 9 | (Irmin_rpc.Config.Remote.None (Server)) 10 | (Irmin_rpc.Config.Pack.None (Server)) 11 | 12 | (** API changes to ease test-writing. Might want to upstream these at some 13 | point. *) 14 | module Client = struct 15 | include RPC.Client 16 | 17 | let of_branch = Fun.flip Store.of_branch 18 | end 19 | 20 | open Client 21 | 22 | (** Default info. *) 23 | let info = Info.none 24 | 25 | module Test_store = struct 26 | type ctx = { client : Client.repo; server : Server.repo } 27 | (** Each test gets its own client/server pair over a fresh in-memory Irmin 28 | store. *) 29 | 30 | let ctx () = 31 | let+ server = Server.Repo.v (Irmin_mem.config ()) in 32 | let client = RPC.Server.Repo.local server in 33 | { server; client } 34 | 35 | let rec resolve_tree server (x : Client.Tree.concrete) = 36 | match x with 37 | | `Contents x -> 38 | let+ c = Server.Contents.of_hash server x in 39 | let c = Option.get c in 40 | `Contents (c, Server.Metadata.default) 41 | | `Tree l -> 42 | let+ l = 43 | Lwt_list.map_s 44 | (fun (step, t) -> 45 | let+ t = resolve_tree server t in 46 | (step, t)) 47 | l 48 | in 49 | `Tree l 50 | 51 | let test_case name (fn : ctx -> unit Lwt.t) = 52 | Alcotest_lwt.test_case name `Quick (fun _switch () -> ctx () >>= fn) 53 | 54 | (** Tests *) 55 | 56 | let test_master { client; _ } = 57 | let+ (_ : Store.t) = client |> Store.master in 58 | () 59 | 60 | let test_of_branch { client; _ } = 61 | let+ (_ : Store.t) = client |> Client.of_branch "foo" in 62 | () 63 | 64 | let test_get { server; client } = 65 | let* () = 66 | let* master = server |> Server.master in 67 | Server.set_exn master ~info [ "k" ] "v" 68 | in 69 | let* master = client |> Store.master in 70 | Store.get master [ "k" ] >|= Alcotest.(check string) "Binding [k → v]" "v" 71 | 72 | let test_find { server; client } = 73 | let* () = 74 | let* master = server |> Server.master in 75 | Server.set_exn master ~info [ "k" ] "v" 76 | in 77 | let* master = client |> Store.master in 78 | let* () = 79 | Store.find master [ "k" ] 80 | >|= Alcotest.(check find) "Binding [k → Some v]" (Ok (Some "v")) 81 | in 82 | let* () = 83 | Store.find master [ "k_absent" ] 84 | >|= Alcotest.(check find) "Binding [k_absent → None]" (Ok None) 85 | in 86 | Lwt.return () 87 | 88 | let test_find_tree { server; client } = 89 | let tree = 90 | strees [ "a"; "b"; "c" ] 91 | (`Tree 92 | [ 93 | ("leaf", contents "data1"); ("branch", stree "f" (contents "data2")); 94 | ]) 95 | in 96 | 97 | let* () = 98 | let* master = server |> Server.master in 99 | tree 100 | |> Server.Tree.of_concrete 101 | |> Server.set_tree_exn master ~info [ "k" ] 102 | in 103 | let* master = client |> Store.master in 104 | let* () = 105 | Client.Store.find_tree master [ "k" ] 106 | >>= Option.map_lwt Client.Tree.concrete 107 | >>= Option.map_lwt (resolve_tree server) 108 | >|= Alcotest.(check find_tree) "Binding [k → Some tree]" (Some tree) 109 | in 110 | let* () = 111 | Client.Store.find_tree master [ "k_absent" ] 112 | >>= Option.map_lwt Client.Tree.concrete 113 | >>= Option.map_lwt (resolve_tree server) 114 | >|= Alcotest.(check find_tree) "Binding [k_absent → Some tree]" None 115 | in 116 | Lwt.return () 117 | 118 | let test_set { server; client } = 119 | let info = Faker.info (module Server.Info) () in 120 | let* () = 121 | let* master = client |> Store.master in 122 | Store.set ~info:(fun () -> info) master [ "k" ] "v" 123 | in 124 | let* master = server |> Server.master in 125 | let* () = 126 | Server.get master [ "k" ] 127 | >|= Alcotest.(check string) "Binding [k → v]" "v" 128 | in 129 | let* () = 130 | Server.Head.get master 131 | >|= Server.Commit.info 132 | >|= Alcotest.(check (info Server.Info.t)) 133 | "New commit has the correct info" info 134 | in 135 | Lwt.return () 136 | 137 | let random_string n = 138 | String.init n (fun _ -> char_of_int (31 + Random.int 95)) 139 | 140 | let test_tree { server; client } = 141 | let info () = Faker.info (module Server.Info) () in 142 | let* master = Client.Store.master client in 143 | let* tree = Client.Tree.empty client in 144 | let* tree = Client.Tree.add tree [ "a" ] (random_string 2048) in 145 | let* tree = Client.Tree.add_tree tree [ "b" ] tree in 146 | let* tree = Client.Tree.remove tree [ "b" ] in 147 | let* () = Client.Store.set_tree master [ "tree" ] tree ~info in 148 | let* tree = Client.Tree.concrete tree >>= resolve_tree server in 149 | let* master = Server.master server in 150 | let* () = 151 | Server.find_tree master [ "tree" ] 152 | >>= Option.map_lwt Server.Tree.to_concrete 153 | >|= Alcotest.(check find_tree) "tree matches" (Some tree) 154 | in 155 | Lwt.return () 156 | 157 | let test_test_and_set { server; client } = 158 | let info () = Faker.info (module Server.Info) () in 159 | let* master = Client.Store.master client in 160 | let s = random_string 1024 in 161 | let s' = random_string 1024 in 162 | let* ok = 163 | Client.Store.test_and_set master ~info [ "test"; "set" ] ~test:None 164 | ~set:(Some s) 165 | in 166 | Alcotest.(check bool) "test and set, initial value" true ok; 167 | let* ok = 168 | Client.Store.test_and_set master ~info [ "test"; "set" ] ~test:None 169 | ~set:(Some s') 170 | in 171 | Alcotest.(check bool) "test and set, incorrect value" false ok; 172 | let* ok = 173 | Client.Store.test_and_set master ~info [ "test"; "set" ] ~test:(Some s) 174 | ~set:(Some s') 175 | in 176 | Alcotest.(check bool) "test and set, correct value" true ok; 177 | let* master = Server.master server in 178 | let* v = Server.find master [ "test"; "set" ] in 179 | Alcotest.(check (option string)) 180 | "test and set, value from store" (Some s') v; 181 | Lwt.return () 182 | 183 | let test_test_and_set_tree { server; client } = 184 | let info () = Faker.info (module Client.Info) () in 185 | let* master = Client.Store.master client in 186 | let* tree = Client.Tree.empty client in 187 | let* tree = Client.Tree.add tree [ "a" ] "1" in 188 | let* tree = Client.Tree.add tree [ "b" ] "2" in 189 | let* tree = Client.Tree.add tree [ "c" ] "3" in 190 | let* ok = 191 | Client.Store.test_and_set_tree master ~info [ "test"; "tree" ] ~test:None 192 | ~set:(Some tree) 193 | in 194 | Alcotest.(check bool) "test and set tree, initial value" true ok; 195 | let* ok = 196 | Client.Store.test_and_set_tree master ~info [ "test"; "tree" ] ~test:None 197 | ~set:None 198 | in 199 | Alcotest.(check bool) "test and set tree, incorrect value" false ok; 200 | let* ok = 201 | Client.Store.test_and_set_tree master ~info [ "test"; "tree" ] 202 | ~test:(Some tree) ~set:None 203 | in 204 | Alcotest.(check bool) "test and set tree, correct value" true ok; 205 | let* master = Server.master server in 206 | let* v = Server.find master [ "test"; "tree" ] in 207 | Alcotest.(check (option string)) 208 | "test and set tree, value from store" None v; 209 | Lwt.return () 210 | 211 | let suite = 212 | [ 213 | test_case "master" test_master; 214 | test_case "of_branch" test_of_branch; 215 | test_case "get" test_get; 216 | test_case "find" test_find; 217 | test_case "find_tree" test_find_tree; 218 | test_case "set" test_set; 219 | test_case "tree" test_tree; 220 | test_case "test_and_set" test_test_and_set; 221 | test_case "test_and_set_tree" test_test_and_set_tree; 222 | ] 223 | end 224 | 225 | let () = 226 | Alcotest_lwt.run "irmin-rpc" 227 | [ 228 | ("utils", Test_utils.suite); 229 | ("store", Test_store.suite); 230 | ("disconnected", Test_disconnected.suite); 231 | ] 232 | |> Lwt_main.run 233 | -------------------------------------------------------------------------------- /test/test.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/test_disconnected.ml: -------------------------------------------------------------------------------- 1 | open Irmin_rpc.Private.Utils 2 | open Lwt.Infix 3 | open Common 4 | module S_server = Irmin_mem.KV.Make (Irmin.Contents.String) 5 | module RPC = 6 | Irmin_rpc.Make 7 | (Server) 8 | (Irmin_rpc.Config.Remote.None (S_server)) 9 | (Irmin_rpc.Config.Pack.None (Server)) 10 | module Client = RPC.Client 11 | module S_client = RPC.Client.Store 12 | 13 | (** Tests of the behaviour of the Irmin_rpc API when various capabilities are 14 | broken. *) 15 | 16 | let ( let* ) = Lwt.bind 17 | 18 | type ctx = { 19 | irmin : RPC.Client.t; 20 | store : S_client.t; 21 | repo : Client.repo; 22 | commit : Client.commit; 23 | } 24 | (** Each test consumes a broken capability of each type. *) 25 | 26 | let broken_exception = Capnp_rpc.Exception.v "Broken test capability" 27 | 28 | let ctx () = 29 | let b () = Capnp_rpc_lwt.Capability.broken broken_exception in 30 | { irmin = b (); store = b (); repo = b (); commit = b () } 31 | 32 | let check_failure (type a) (fn : unit -> a Lwt.t) : unit Lwt.t = 33 | Lwt.catch 34 | (fun () -> 35 | fn () >>= fun _ -> Alcotest.fail "Expected thread failure did not occur") 36 | (function 37 | | Failure error_msg -> ( 38 | (* Capnp error messages are too brittle to rely upon in test, so we 39 | just require that the message contains the string built into the 40 | broken capability above. *) 41 | match String.is_substring "Broken test capability" error_msg with 42 | | true -> Lwt.return_unit 43 | | false -> 44 | Alcotest.failf "Unexpected Failure error message: %s" error_msg) 45 | | exn -> Lwt.fail exn) 46 | 47 | let test_case name (fn : ctx -> unit Lwt.t) = 48 | Alcotest_lwt.test_case name `Quick (fun _switch () -> ctx () |> fn) 49 | 50 | (** Test cases *) 51 | 52 | let test_ping { irmin; _ } = 53 | let* () = 54 | RPC.Client.ping irmin 55 | >|= Alcotest.(check (result reject capnp_error)) 56 | "Error case" 57 | (Error (`Capnp (`Exception broken_exception))) 58 | in 59 | Lwt.return_unit 60 | 61 | let test_master { repo; _ } = 62 | (* [master] is pipelined, so we don't observe a failure until we _use_ the 63 | store capability. *) 64 | let* s = S_client.master repo in 65 | let* () = check_failure (fun () -> S_client.get s []) in 66 | Lwt.return_unit 67 | 68 | let test_of_branch { repo; _ } = 69 | let* s = S_client.of_branch repo "foo" in 70 | let* () = check_failure (fun () -> S_client.get s []) in 71 | Lwt.return_unit 72 | 73 | let suite = 74 | [ 75 | test_case "Irmin.ping" test_ping; 76 | test_case "Store.master" test_master; 77 | test_case "Store.of_branch" test_of_branch; 78 | ] 79 | -------------------------------------------------------------------------------- /test/test_disconnected.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest_lwt.test_case list 2 | -------------------------------------------------------------------------------- /test/test_utils.ml: -------------------------------------------------------------------------------- 1 | open Irmin_rpc.Private.Utils 2 | 3 | module String = struct 4 | let test_to_list () = 5 | let check input output = 6 | String.to_list input |> Alcotest.(check (list char)) input output 7 | in 8 | check "" []; 9 | check "x" [ 'x' ]; 10 | check "abc" [ 'a'; 'b'; 'c' ]; 11 | () 12 | 13 | let test_is_substring () = 14 | let check a b output = 15 | String.is_substring a b |> Alcotest.(check bool) b output 16 | in 17 | check "" "" true; 18 | check "" "abc" true; 19 | check "x" "x" true; 20 | check "foo" "foo" true; 21 | check "bar" "foo bar baz" true; 22 | check "bad" "foo bar baz" false; 23 | () 24 | end 25 | 26 | let suite = 27 | let test_case name fn = Alcotest_lwt.test_case_sync name `Quick fn in 28 | [ 29 | test_case "String.to_list" String.test_to_list; 30 | test_case "String.is_substring" String.test_is_substring; 31 | ] 32 | -------------------------------------------------------------------------------- /test/test_utils.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest_lwt.test_case list 2 | --------------------------------------------------------------------------------