Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 138 lines (114 sloc) 4.628 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Louis Gesbert
20 **)
21
22 module D = Badop_lib
23 module Dialog = Badop_lib.Dialog
24 open Cps.Ops
25
26 include Badop_protocol.F
27 (struct
28 type spoken = Dialog.query
29 type understood = Dialog.response
30 type revision (* Abstract *)
31 end)
32
33 module N = Hlnet
34
35 let open_database options k =
6ff7da0 [fix] database: adding the possibility to automatically attempt to re…
Louis Gesbert authored
36 let scheduler, remote, on_disconnect = match options with
37 | Badop.Options_Client (scheduler,(addr,port), on_disconnect) -> scheduler, N.Tcp (addr,port), on_disconnect
fccc685 Initial open-source release
MLstate authored
38 | _ -> assert false
39 in
40 let on_disconnect () =
6ff7da0 [fix] database: adding the possibility to automatically attempt to re…
Louis Gesbert authored
41 Logger.error "Disconnected from %s" (N.endpoint_to_string remote);
42 on_disconnect()
43 in
fccc685 Initial open-source release
MLstate authored
44 N.open_channel scheduler remote ~on_disconnect database_channel_spec @> k
45
46 let close_database db k = N.close_channel db |> k
47
48 let status db k =
49 match N.local_of_channel db, N.remote_of_channel db with
50 | N.Tcp (local_addr,_), N.Tcp (remote_addr,remote_port) ->
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
51 (N.sendreceive' db (Status (Dialog.query ()))
52 (fun _ -> Badop.Client (local_addr, (remote_addr, remote_port), Badop.Other "disconnected") |> k)
fccc685 Initial open-source release
MLstate authored
53 @> function
54 | Status (Dialog.Response st) ->
55 Badop.Client (local_addr, (remote_addr, remote_port), st) |> k
56 | _ -> assert false)
57 | _ -> assert false
58
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
59 let tr_next tr k =
60 if tr.last then
61 let tr' = { tr with version = succ tr.version } in tr.last <- false; tr' |> k
62 else
63 N.sendreceive tr.channel (Fork (Dialog.query tr.version))
64 @> function
65 | Fork (Dialog.Response tr_channel) ->
66 { channel = tr_channel; version = succ tr.version; last = true } |> k
67 | _ -> N.panic tr.channel
68
fccc685 Initial open-source release
MLstate authored
69 module Tr = struct
70
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
71 let start db errk k =
72 N.sendreceive' db (Transaction (Dialog.query ())) errk
fccc685 Initial open-source release
MLstate authored
73 @> function
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
74 | Transaction (Dialog.Response tr_channel) ->
75 N.on_disconnect tr_channel (fun () -> N.Disconnected (N.remote_of_channel db) |> errk);
76 { channel = tr_channel; version = 0; last = true } |> k
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
77 | _ -> N.panic db
fccc685 Initial open-source release
MLstate authored
78
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
79 let start_at_revision db rev errk k =
80 N.sendreceive' db (Transaction_at (Dialog.query rev)) errk
fccc685 Initial open-source release
MLstate authored
81 @> function
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
82 | Transaction_at (Dialog.Response tr_channel) ->
83 N.on_disconnect tr_channel (fun () -> N.Disconnected (N.remote_of_channel db) |> errk);
84 { channel = tr_channel; version = 0; last = true } |> k
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
85 | _ -> N.panic db
fccc685 Initial open-source release
MLstate authored
86
87 let prepare tr k =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
88 tr_next tr
89 @> fun tr ->
90 N.sendreceive tr.channel (Prepare (Dialog.query tr.version))
fccc685 Initial open-source release
MLstate authored
91 @> function
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
92 | Prepare (D.Response success) -> (tr, success) |> k
93 | _ -> N.panic tr.channel
fccc685 Initial open-source release
MLstate authored
94
95 let commit tr k =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
96 N.sendreceive tr.channel (Commit (Dialog.query tr.version))
fccc685 Initial open-source release
MLstate authored
97 @> function
98 | Commit (D.Response success) -> success |> k
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
99 | _ -> N.panic tr.channel
fccc685 Initial open-source release
MLstate authored
100
101 let abort tr k =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
102 N.sendreceive tr.channel (Abort (Dialog.query tr.version))
fccc685 Initial open-source release
MLstate authored
103 @> function
104 | Abort (D.Response ()) -> () |> k
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
105 | _ -> N.panic tr.channel
fccc685 Initial open-source release
MLstate authored
106
107 end
108
109 let read tr path query k =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
110 N.sendreceive tr.channel (Read (path, Dialog.query (tr.version, query)))
fccc685 Initial open-source release
MLstate authored
111 @> function
112 | Read (path', D.Response result) -> assert (path = path'); result |> k
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
113 | _ -> N.panic tr.channel
fccc685 Initial open-source release
MLstate authored
114
115 let write tr path query k =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
116 Badop.Aux.map_write_op ~transaction:(fun _tr k -> () |> k) ~revision:(fun x k -> x |> k) query
117 @> fun query1 -> tr_next tr
118 @> fun tr ->
119 N.send tr.channel (Write (path, tr.version, query1));
120 Badop.Aux.respond_set_transaction query tr |> k
fccc685 Initial open-source release
MLstate authored
121
122 let write_list tr l_path_query k =
114c5ec [enhance] database client/server: much more efficient protocol
Louis Gesbert authored
123 let paths,queries = List.split l_path_query in
124 Badop.Aux.map_write_list_op ~transaction:(fun _tr k -> () |> k) ~revision:(fun x k -> x |> k) queries
125 @> fun queries1 -> tr_next tr
126 @> fun tr ->
127 N.send tr.channel (WriteList (tr.version, Dialog.query (List.combine paths queries1)));
128 tr |> k
fccc685 Initial open-source release
MLstate authored
129
130 let node_properties _db _config k =
131 #<If:TESTING> () |> k #<Else>
132 Printf.eprintf " Can't set node properties on client \n%!"; () |> k #<End>
133
134 module Debug = struct
135 let revision_to_string r = DebugPrint.print r
136 let path_to_string = Path.to_string
137 end
Something went wrong with that request. Please try again.