Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 187 lines (161 sloc) 6.986 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 Node_property = Badop_structure.Node_property
24
25 type 'a answer = [ `Answer of 'a | `Absent | `Linkto of Badop.path ]
26 (** This module provides a simple db, no specific results to handle *)
27
28 type database = { session: Session.t; file: string; mutable node_config : Node_property.config }
29 type transaction = { db: database; tr: Transaction.t }
30
31 let (|>) x f = f x
32
33 let open_database options k =
34 let options =
35 match options with
36 | Badop.Options_Local options -> options
37 | _ -> assert false in
38 let open_db ?readonly ?dot ?restore p =
39 match options.Badop.revision with
40 | Some rev -> Session.open_db ?readonly ?dot ?restore ~rev p
41 | None -> Session.open_db ?readonly ?dot ?restore p
42 in
43 let open_db ?readonly ?dot p =
44 match options.Badop.restore with
45 | Some restore -> open_db ?readonly ?dot ~restore p
46 | None -> open_db ?readonly ?dot p
47 in
48 let open_db ?readonly p =
49 if options.Badop.dot then open_db ?readonly ~dot:true p
50 else open_db ?readonly p
51 in
52 let open_db p =
53 if options.Badop.readonly then open_db ~readonly:true p
54 else open_db p
55 in
56 let path = options.Badop.path in
57
58 open_db path |> fun (db,_) -> { session = db; file = path; node_config = [] } |> k
59
60 let close_database db k =
61 Session.close_db db.session |> k
62
63 let status db k = Badop.Local db.file |> k
64
65 module Tr = struct
66 let start db k =
67 { db = db; tr = Session.new_trans db.session } |> k
68
69 let start_at_revision db rev k =
70 { db = db; tr = Session.new_trans ~read_only:(true, Some rev) db.session } |> k
71
72 let prepare trans k =
73 (* Executes [k] as soon as prepare finished, asynchronously, nonblocking.
74 When prepare is postponed and stored on the FIFO,
75 the continuation is stored as well. The exceptions from [k]
76 are never caught here. *)
77 if Transaction.modified trans.tr then
78 Session.try_trans_prepare trans.db.session trans.tr
79 (fun (tr, b) -> ({db = trans.db; tr = tr}, b) |> k)
80 else
81 (* Non-modifying trans, so nothing to do; commit will be void, too. *)
82 ({db = trans.db; tr = trans.tr}, true) |> k
83
84 let commit trans k =
85 if Transaction.modified trans.tr then
86 (* Assumption: [trans] is prepared by [execute_trans_prepare].
87 Here some continuations of [prepare] may be executed, but only in case
88 when some transactions are on the FIFO and are being prepared
89 after the actual commit is completed. *)
90 Session.really_commit trans.db.session trans.tr |> k
91 else
92 true |> k
93
94 let abort trans k = Session.abort_or_rollback trans.db.session trans.tr |> k
95 end
96
97 type revision = Revision.t
98
99 (** All the operations that query the db *)
100 type 'which read_op = ('which,revision) Badop.generic_read_op
101
102 let read trans path op k = match op with
103 | Badop.Stat (D.Query () as q) ->
104 (try `Answer (Badop.Stat (D.Dialog_aux.respond q (Session.stat trans.tr path)))
105 with Hldb.UnqualifiedPath -> `Absent) |> k
106 | Badop.Contents (D.Query () as q) ->
107 (try `Answer (Badop.Contents (D.Dialog_aux.respond q (Session.get trans.db.session trans.tr path)))
108 with Hldb.UnqualifiedPath -> `Absent) |> k
109 | Badop.Children (D.Query range as q) ->
110 (try
111 `Answer
112 (Badop.Children
113 (D.Dialog_aux.respond q
114 (Session.get_children trans.db.session trans.tr range path
115 |> List.map fst)))
116 with Hldb.UnqualifiedPath -> `Absent) |> k
117 | Badop.Revisions (D.Query range as q) ->
118 (try
119 `Answer
120 (Badop.Revisions
121 (D.Dialog_aux.respond q
122 ((if (range = (None, -1)
123 && (try ignore (Session.stat trans.tr path); true
124 with Hldb.UnqualifiedPath -> false))
125 then
126 (* current revision *)
127 [Session.get_rev trans.db.session]
128 else
129 (Session.get_all_rev_of_path trans.tr path
130 |> BaseList.filterbounds range Base.identity))
131 |> List.map (fun rev -> rev, Session.get_timestamp_from_rev trans.db.session rev))))
132 with Hldb.UnqualifiedPath -> `Absent) |> k
133 | Badop.Search (D.Query (words, _range_FIXME) as q) ->
134 (try
135 `Answer
136 (Badop.Search
137 (D.Dialog_aux.respond q
138 (Session.full_search trans.tr words path)))
139 (* FIXME: limit number of results *)
140 with Hldb.UnqualifiedPath -> `Absent) |> k
141 | _ -> assert false (* _ (Response _) can't happen (ensured by typing) *)
142
143 (** All the operations that write to the db *)
144 type 'which write_op = ('which,transaction,revision) Badop.generic_write_op
145
146 let write trans path op k = match op with
147 | Badop.Set (D.Query data as q) ->
148 Badop.Set (D.Dialog_aux.respond q { trans with tr = Session.set trans.tr path data }) |> k
149 | Badop.Clear (D.Query () as q) ->
150 Badop.Clear
151 (D.Dialog_aux.respond q
152 (try
153 { trans with tr = Session.remove trans.tr path }
154 with Hldb.UnqualifiedPath -> trans)) |> k
155 | Badop.Link (D.Query linkpath as q) ->
156 Badop.Link
157 (D.Dialog_aux.respond q
158 { trans with tr = Session.set_link trans.tr path linkpath }) |> k
159 | Badop.Copy (D.Query (copypath,copyrev) as q) ->
160 Badop.Copy
161 (D.Dialog_aux.respond q
162 { trans with tr = Session.set_copy trans.db.session trans.tr path (copypath, copyrev) }) |> k
163 | _ -> assert false (* _ (Response _) can't happen (ensured by typing) *)
164
165 let write_list trans path_op_list k =
166 let wr trans (path, op) k =
167 write trans path op (fun resp -> Badop.Aux.result_transaction resp |> k)
168 in
169 Cps.List.fold wr trans path_op_list k
170
171 let node_properties db config k =
172 (match db.node_config with
173 | [] ->
174 #<If:BADOP_DEBUG$minlevel 10>
175 Printf.printf "Set node config\n%s\n%!" (Node_property.StringOf.config config) #<End>;
176 db.node_config <- config
177 | nc ->
178 if nc <> config then
179 (#<If:BADOP_DEBUG$minlevel 5> Printf.eprintf "Try to set another config, refuse\n%!" #<End>;
180 failwith "Badop local: Invalid config"));
181 () |> k
182
183 module Debug = struct
184 let revision_to_string = Revision.to_string
185 let path_to_string = Path.to_string
186 end
Something went wrong with that request. Please try again.