Skip to content
This repository
Newer
Older
100644 136 lines (121 sloc) 5.583 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
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 open Cps.Ops
24
25 module N = Hlnet
26
27 module F = functor (Backend: Badop.S) ->
28 struct
29
30 include Badop_protocol.F
31 (struct
32 type spoken = D.Dialog.response
33 type understood = D.Dialog.query
34 type revision = Backend.revision
35 end)
36
37 type t = {
38 backend: Backend.database;
39 endpoint: N.endpoint;
40 scheduler: Scheduler.t;
41 }
42
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
43 let rec transaction_callback (transmap: Backend.transaction IntMap.t ref) channel
fccc6851 » MLstate
2011-06-21 Initial open-source release
44 : (D.Dialog.query transaction_op
45 -> (D.Dialog.response transaction_op -> unit) -> unit)
46 =
47 fun request k ->
48 match request with
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
49 | Read (path, (D.Query (tr_version, op) as query)) ->
50 Backend.read (IntMap.find tr_version !transmap) path op
fccc6851 » MLstate
2011-06-21 Initial open-source release
51 @> fun resp -> Read (path, D.Dialog_aux.respond query resp) |> k
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
52 | Write (path, tr_next_version, op) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
53 Badop.Aux.map_write_op (* From Protocol.transaction to Backend.transaction *)
54 ~revision:(fun r k -> r |> k)
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
55 ~transaction:(fun () k -> assert false |> k)
fccc6851 » MLstate
2011-06-21 Initial open-source release
56 op
57 @> fun op ->
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
58 Backend.write (IntMap.find (pred tr_next_version) !transmap) path op
59 @> fun backend_response ->
60 let tr = Badop.Aux.result_transaction backend_response in
61 transmap := IntMap.add tr_next_version tr !transmap (* no continuation needed *)
62 | WriteList (tr_next_version, D.Query l_q) ->
63 let l_paths,l_op = List.split l_q in
fccc6851 » MLstate
2011-06-21 Initial open-source release
64 Badop.Aux.map_write_list_op (* From Protocol.transaction to Backend.transaction *)
65 ~revision:(fun r k -> r |> k)
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
66 ~transaction:(fun _ k -> assert false |> k)
fccc6851 » MLstate
2011-06-21 Initial open-source release
67 l_op
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
68 @> fun l_op ->
69 Backend.write_list (IntMap.find (pred tr_next_version) !transmap) (List.combine l_paths l_op)
70 @> fun tr ->
71 transmap := IntMap.add tr_next_version tr !transmap (* no continuation needed *)
72 | Prepare (D.Query tr_next_version as query) ->
73 Backend.Tr.prepare (IntMap.find (pred tr_next_version) !transmap)
74 @> fun (tr,success) ->
75 transmap := IntMap.add tr_next_version tr !transmap;
76 Prepare (D.Dialog_aux.respond query success) |> k
77 | Commit (D.Query tr_version as query) ->
78 Backend.Tr.commit (IntMap.find tr_version !transmap)
fccc6851 » MLstate
2011-06-21 Initial open-source release
79 @> fun resp -> Commit (D.Dialog_aux.respond query resp) |> k
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
80 | Abort (D.Query tr_version as query) ->
81 Backend.Tr.abort (IntMap.find tr_version !transmap)
fccc6851 » MLstate
2011-06-21 Initial open-source release
82 @> fun resp -> Abort (D.Dialog_aux.respond query resp) |> k
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
83 | Fork (D.Query tr_version as query) ->
84 let channel = N.dup channel transaction_channel_spec in
85 let transmap = ref (IntMap.filter_keys ((<=) tr_version) !transmap) in
86 N.setup_respond channel (transaction_callback transmap channel);
87 Fork (D.Dialog_aux.respond query channel) |> k
88 | Read (_, D.Response _) | WriteList (_, D.Response _) | Prepare (D.Response _)
89 | Commit (D.Response _) | Abort (D.Response _) | Fork (D.Response _) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
90 assert false
91
92 let main_callback db (channel: database) :
93 D.Dialog.query database_query -> D.Dialog.response database_query Cps.t
94 =
95 fun request k ->
96 let init_tr backend_tr k =
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
97 let channel = N.dup channel transaction_channel_spec in
98 N.setup_respond channel (transaction_callback (ref (IntMap.singleton 0 backend_tr)) channel);
99 channel |> k
fccc6851 » MLstate
2011-06-21 Initial open-source release
100 in
101 match request with
102 | Transaction (D.Query () as query) ->
103 Backend.Tr.start db
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
104 (fun _exc -> N.panic channel)
fccc6851 » MLstate
2011-06-21 Initial open-source release
105 @> fun backend_tr -> init_tr backend_tr
106 @> fun tr -> Transaction (D.Dialog_aux.respond query tr) |> k
107 | Transaction_at (D.Query rev as query) ->
108 Backend.Tr.start_at_revision db rev
114c5eca » Louis Gesbert
2011-07-01 [enhance] database client/server: much more efficient protocol
109 (fun _exc -> N.panic channel)
fccc6851 » MLstate
2011-06-21 Initial open-source release
110 @> fun backend_tr -> init_tr backend_tr
111 @> fun tr -> Transaction_at (D.Dialog_aux.respond query tr) |> k
112 | Status (D.Query () as query) ->
113 Backend.status db
114 @> fun st ->
115 Status (D.Dialog_aux.respond query (Badop.Layer ("Server",st))) |> k
116 | Transaction (D.Response _) | Transaction_at (D.Response _) | Status (D.Response _) ->
117 assert false
118
119 let listener (db: Backend.database) :
120 database -> unit
121 =
122 fun channel -> N.setup_respond channel (main_callback db channel)
123
124 let start scheduler bindto options k =
125 N.listen scheduler bindto;
126 Backend.open_database options
127 @> fun db ->
128 N.accept scheduler bindto database_channel_spec (listener db);
129 { backend = db; endpoint = bindto; scheduler = scheduler; } |> k
130
131 let stop { backend = db; endpoint = endpoint; scheduler = scheduler; } k =
132 N.refuse scheduler endpoint; (* todo: ensure to close all channels bound to local endpoint *)
133 Backend.close_database db
134 @> k
135
136 end
Something went wrong with that request. Please try again.