Source file persistence.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
module Api = Persistent.Make(Capnp.BytesMessage)

class type ['a] persistent = object
  method save : ('a Sturdy_ref.t, Capnp_rpc_proto.Exception.t) result
end

let with_persistence
    (persistent:'b #persistent)
    (_:(#Service.generic as 'a) -> 'b Capability.t)
    (impl : 'a) =
  (* We ignore the second argument. It's just to force the user to prove that [impl]
     really does have type ['a]. *)
  let dispatch_persistent method_id _params release_params =
    if method_id = Capnp.RPC.MethodID.method_id Api.Client.Persistent.Save.method_id then (
      let open Api.Service.Persistent.Save in
      release_params ();
      match persistent#save with
      | Error e -> Service.error (`Exception e)
      | Ok sr ->
        let resp, results = Service.Response.create Results.init_pointer in
        Sturdy_ref.builder Results.sturdy_ref_get results sr;
        Service.return resp
    ) else (
      release_params ();
      Service.fail ~ty:`Unimplemented "Unknown persistence method %d" method_id
    )
  in
  let wrapper = object (_ : #Service.generic)
    method release = impl#release
    method pp = impl#pp
    method dispatch ~interface_id ~method_id =
      if interface_id = Api.Service.Persistent.interface_id then dispatch_persistent method_id
      else impl#dispatch ~interface_id ~method_id
  end in
  Service.local wrapper

let with_sturdy_ref sr local impl =
  let persistent = object
    method save = Ok sr
  end in
  with_persistence persistent local impl

let save cap =
  let open Api.Client.Persistent.Save in
  let request = Capability.Request.create_no_args () in
  match Capability.call_for_value cap method_id request with
  | Error _ as e -> e
  | Ok response -> Ok (Sturdy_ref.reader Results.sturdy_ref_get response)

let save_exn cap =
  match save cap with
  | Error (`Capnp e) -> failwith (Fmt.to_to_string Capnp_rpc_proto.Error.pp e)
  | Ok x -> x