Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 421 lines (375 sloc) 12.586 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 (* depends *)
19 module List = BaseList
20
21 (* -- *)
22
23 type full = {
24 cur_rev : Revision.t ;
25 content : Datas.t ;
26 map : Eid.t KeyMap.t ;
27 }
28
29 type delta = {
30 new_content : Datas.t option ;
31 new_childs : Eid.t KeyMap.t ;
32 (* TODO: verify: I think the semantics is that the children
33 cannot exist in the old node; they are always added,
34 never overwritten. *)
35 prof : int ;
36 }
37
38 (* Reverse delta. Tells what to do to get the previous version of a node. *)
39 type rev_delta =
40 { old_content : Datas.t option;
41 (* The content as it was back then.*)
42 extra_children : Keys.t list;
43 (* Which children to remove to get the old list. *)
44 rev_prof : int;
45 (* Auxiliary: how many deltas to here, counting form older to newer. *)
46 }
47
48 type io_t =
49 | Full of full
50 | Delta of (Uid.t * Revision.t * delta)
51 | RevDelta of Uid.t * Revision.t * rev_delta
52
53 type t = io_t
54
55 let max_full = 103
56 let max_delta =
57 #<If:DEBUG_DB_MAX_DELTA$defined>
58 begin
59 match DebugVariables.debug_db_max_delta with
60 | Some s when int_of_string s >= 0 ->
61 int_of_string s
62 | _ ->
63 failwith "Bad value for debug variable DEBUG_DB_MAX_DELTA"
64 end
65 #<Else>
66 103
67 #<End>
68
69
70 (*******************)
71 (* Screen printing *)
72 (*******************)
73
74 let print_delta_bis delta =
75 match delta.new_content with
76 | Some c -> (Printf.sprintf "content=%s" (Datas.to_string c))
77 | None -> (Printf.sprintf "content=%s" (Datas.to_string (Datas.empty)))
78
79 let print_map map = KeyMap.fold (
80 fun k eid acc -> Printf.sprintf "%s%s -> %s "
81 acc (Keys.to_string k) (Eid.to_string eid)
82 ) map ""
83
84 let print_delta delta =
85 Printf.sprintf "{new_content = %s, new_chilren = %s}"
86 (match delta.new_content with
87 | Some c -> Datas.to_string c
88 | _ -> "None")
89 (print_map delta.new_childs)
90
91 let print_rev_delta delta =
92 Printf.sprintf "{old_content = %s, extra_chilren = %s}"
93 (match delta.old_content with
94 | Some c -> Datas.to_string c
95 | _ -> "None")
96 (BaseString.concat_map
97 ~left:"[" "; " Keys.to_string delta.extra_children ~right:"]")
98
99 let print_full n =
100 Printf.sprintf
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
101 "rev=%s, content=%s, map=%s"
fccc685 Initial open-source release
MLstate authored
102 (Revision.to_string n.cur_rev)
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
103 (Datas.to_string n.content)
104 (print_map n.map)
fccc685 Initial open-source release
MLstate authored
105
106 let to_string = function
107 | Full node -> Printf.sprintf "Full {%s}" (print_full node)
108 | Delta (uid, rev, delta) -> Printf.sprintf "Delta {uid = %d; rev = %d; %s}"
109 (Uid.value uid) (Revision.value rev) (print_delta delta)
110 | RevDelta (uid, rev, rev_delta) ->
111 Printf.sprintf "RevDelta {uid = %d; rev = %d; %s}"
112 (Uid.value uid) (Revision.value rev)
113 (print_rev_delta rev_delta)
114
115
116 (************************)
117 (* Access to the fields *)
118 (************************)
119
120 let rec get_map ~f node =
121 match node with
122 | Full node -> node.map
123 | Delta (uid, _, delta) ->
124 let delta_map = delta.new_childs in
125 let rec_map = get_map ~f (f uid) in
126 (* TODO: probably not true:
127 Subsequent revisions may overwrite the same children,
128 so [KeyMap.safe_merge] is too strict here. *)
129 KeyMap.merge (fun a _ -> a) delta_map rec_map
130 | RevDelta (uid, _rev, delta) ->
131 let rec_map = get_map ~f (f uid) in
132 List.fold_left
133 (fun acc k -> KeyMap.remove k acc)
134 rec_map delta.extra_children
135
136 let rec get_children ~f = function
137 | Full full -> KeyMap.fold (fun k _ acc -> k :: acc) full.map []
138 | Delta (uid, _, delta) ->
139 let delta_children =
140 let map = delta.new_childs in
141 KeyMap.fold (fun k _eid acc -> k :: acc) map [] in
142 let rec_children = get_children ~f (f uid) in
143 List.merge (fun k1 k2 -> compare k1 k2)
144 delta_children rec_children
145 | RevDelta (_uid, _rev, _delta) as node ->
146 let map = get_map ~f node in
147 KeyMap.fold (fun k _eid acc -> k :: acc) map []
148
149 let rec get_children_eid ~f = function
150 | Full full -> KeyMap.fold (fun _ eid acc -> eid :: acc) full.map []
151 | Delta (uid, _, delta) ->
152 let delta_children =
153 let map = delta.new_childs in
154 KeyMap.fold (fun _k eid acc -> eid :: acc) map [] in
155 let rec_children = get_children_eid ~f (f uid) in
156 List.merge (fun eid1 eid2 -> compare eid1 eid2)
157 delta_children rec_children
158 | RevDelta (_uid, _rev, _delta) as node ->
159 let map = get_map ~f node in
160 KeyMap.fold (fun _k eid acc -> eid :: acc) map []
161
162 let rec get_content ~f = function
163 | Full node -> node.content
164 | Delta (uid, _, delta) -> (
165 match delta.new_content with
166 | Some d -> d
167 | None -> get_content ~f (f uid)
168 )
169 | RevDelta (uid, _rev, delta) ->
170 begin match delta.old_content with
171 | Some d -> d
172 | None -> get_content ~f (f uid)
173 end
174
175 let get_cur_rev = function
176 | Full node -> node.cur_rev
177 | Delta (_, rev, _) -> rev
178 | RevDelta (_uid, rev, _delta) -> rev
179
180 let rec next_eid ~f k node =
181 #<If:DEBUG_DB$minlevel 1000>
182 Logger.log ~color:`green "DB : next_eid node(%s) k(%s)"
846231a [enhance] db3: add logs & update some
Raja authored
183 (to_string node) (Keys.to_string k)
fccc685 Initial open-source release
MLstate authored
184 #<End>;
185 match node with
186 | Full node -> KeyMap.find k node.map
187 | Delta (uid, _, delta) -> (
188 match KeyMap.find_opt k delta.new_childs with
189 | Some neid -> neid
190 | _ -> next_eid ~f k (f uid)
191 )
192 | RevDelta (uid, _rev, _delta) -> next_eid ~f k (f uid)
193
194 let rec find_opt ~f k n =
195 match n with
196 | Full node -> KeyMap.find_opt k node.map
197 | Delta (uid, _, delta) -> (
198 match KeyMap.find_opt k delta.new_childs with
199 | Some neid -> Some neid
200 | _ -> find_opt ~f k (f uid)
201 )
202 | RevDelta (uid, _rev, delta) ->
203 if List.mem k delta.extra_children then None
204 else find_opt ~f k (f uid)
205
206
207 (************************)
208 (* Creation and updates *)
209 (************************)
210
211 let create ?content rev =
212 let content =
213 match content with
214 | Some d -> d
215 | _ -> Datas.empty
216 in
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
217 Full { cur_rev = rev
fccc685 Initial open-source release
MLstate authored
218 ; content = content
219 ; map = KeyMap.empty }
220
221 let is_full_map node =
222 match node with
223 | Full node -> (KeyMap.size node.map >= max_full)
224 | Delta (_, _, delta) -> (KeyMap.size delta.new_childs >= max_delta)
225 | RevDelta (_uid, _rev, delta) ->
226 (List.length delta.extra_children >= max_delta)
227
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
228 let update_full_to_full ?content ?child _uid rev node =
229 let new_map =
fccc685 Initial open-source release
MLstate authored
230 match child with
231 | Some (k, eid) ->
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
232 KeyMap.add k eid node.map
233 | _ -> node.map
fccc685 Initial open-source release
MLstate authored
234 in
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
235 let new_rev = rev in
fccc685 Initial open-source release
MLstate authored
236 let new_content =
237 match content with
238 | Some d -> d
239 | _ -> node.content
240 in
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
241 Full { cur_rev = new_rev
fccc685 Initial open-source release
MLstate authored
242 ; content = new_content
243 ; map = new_map}
244
245 let update_full_to_delta ?content ?child uid rev node =
246 if max_delta = 0 then
247 update_full_to_full ?content ?child uid rev node
248 else
249 let delta =
250 let new_content = content in
251 let new_childs =
252 match child with
253 | Some (k, eid) -> KeyMap.add k eid KeyMap.empty
254 | _ -> KeyMap.empty
255 in
256 {new_content = new_content
257 ; new_childs = new_childs
258 ; prof = 1}
259 in
260 Delta (uid, rev, delta)
261
262 let update_full_to_rev_delta ?content ?child uid rev node =
263 (* TODO *)
264 if max_delta = 0 then
265 update_full_to_full ?content ?child uid rev node
266 else
267 let delta =
268 let new_content = content in
269 let new_childs =
270 match child with
271 | Some (k, eid) -> KeyMap.add k eid KeyMap.empty
272 | _ -> KeyMap.empty
273 in
274 {new_content = new_content
275 ; new_childs = new_childs
276 ; prof = 1}
277 in
278 Delta (uid, rev, delta)
279
280 (* delta: if node updated by a new transaction *)
281 let update_delta ~f ?content ?child uid rev old_uid old_rev old_delta delta =
282 if delta then
283 match old_delta.prof with
284 | x when x >= max_delta ->
285 let old_node = Delta (old_uid, old_rev, old_delta) in
286 let map = get_map ~f old_node in
287 let map =
288 match child with
289 | Some (k, eid) -> KeyMap.add k eid map
290 | _ -> map
291 in
292 let new_content =
293 match content with
294 | Some d -> d
295 | _ -> get_content ~f old_node
296 in
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
297 Full { cur_rev = rev
fccc685 Initial open-source release
MLstate authored
298 ; content = new_content
299 ; map = map }
300 | _ ->
301 let new_delta =
302 let new_content =
303 match content with
304 | Some d -> Some d
305 | _ -> None
306 in
307 let new_childs =
308 match child with
309 | Some (k, eid) -> KeyMap.add k eid KeyMap.empty
310 | _ -> KeyMap.empty
311 in
312 {new_content = new_content
313 ; new_childs = new_childs
314 ; prof = succ old_delta.prof}
315 in
316 Delta (uid, rev, new_delta)
317 else
318 match old_delta.prof with
319 | x when x >= max_delta ->
320 let old_node = Delta (old_uid, old_rev, old_delta) in
321 let map = get_map ~f old_node in
322 let map =
323 match child with
324 | Some (k, eid) -> KeyMap.add k eid map
325 | _ -> map
326 in
327 let new_content =
328 match content with
329 | Some d -> d
330 | _ -> get_content ~f old_node
331 in
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
332 Full { cur_rev = old_rev
fccc685 Initial open-source release
MLstate authored
333 ; content = new_content
334 ; map = map }
335 | _ ->
336 let new_delta =
337 let new_content =
338 match content with
339 | Some d -> Some d
340 | _ -> old_delta.new_content
341 in
342 let new_childs =
343 match child with
344 | Some (k, eid) -> KeyMap.add k eid old_delta.new_childs
345 | _ -> old_delta.new_childs
346 in
347 {new_content = new_content
348 ; new_childs = new_childs
349 ; prof = old_delta.prof} in
350 Delta (old_uid, old_rev, new_delta)
351
352 let update ~f uid node rev ?content ?child delta =
353 let new_node =
354 match (node, delta) with
355 | (Full node, true) ->
356 begin match child with
357 | Some _ ->
358 update_full_to_rev_delta ?content ?child uid rev node
359 (* Old version: update_full_to_delta ?content ?child uid rev node *)
360 | None -> update_full_to_full ?content uid rev node
361 end
362 | (Full node, false) -> update_full_to_full ?content ?child uid rev node
363 | (Delta (old_uid, old_rev, old_delta), _) ->
364 update_delta ~f ?content ?child
365 uid rev old_uid old_rev old_delta delta
366 | (RevDelta (_uid, _rev, _delta), _) ->
367 (* Normally, this node should never be updated,
368 because the last revision will alsways be the Full node. *)
369 assert false
370 in
371 (new_node, is_full_map new_node)
372
373 let rec remove_child ~f rev node key =
374 match node with
372208f [enhance] db3: remove unusefull old_rev field from node structure
Raja authored
375 | Full node ->
fccc685 Initial open-source release
MLstate authored
376 let new_map = KeyMap.remove key node.map in
377 Full {node with
0ac35f0 [enhance] db3: remove unusefull fields from node structure
Raja authored
378 map = new_map; cur_rev = rev}
fccc685 Initial open-source release
MLstate authored
379 | Delta (uid, _rev, _delta) ->
380 let new_map = KeyMap.remove key (get_map ~f node) in
381 let content = get_content ~f node in
382 let new_node = create ~content rev in
383 let new_node = KeyMap.fold (
384 fun key eid node ->
385 let node, _ = update ~f uid node rev ~child:(key, eid) false in
386 node
387 ) new_map new_node
388 in
389 new_node
390 | RevDelta (uid, _rev, delta) ->
391 let delta = { delta with extra_children = key :: delta.extra_children } in
392 RevDelta (uid, rev, delta)
393
394
395 (***********)
396 (* Folding *)
397 (***********)
398
399 let fold ~f foo node acc = KeyMap.fold foo (get_map ~f node) acc
400
401 let fold_range (start_opt, length) ~f foo node acc =
402 let map = get_map ~f node in
403 if KeyMap.is_empty map then acc else
404 let start =
405 match start_opt with
406 | Some start -> start
407 | None -> if length >= 0 then fst (KeyMap.min map) else fst (KeyMap.max map)
408 in
409 if length = 0 then
410 KeyMap.fold_range foo map start (fst (KeyMap.max map)) acc
411 else
412 KeyMap.fold_length ~start ~length foo map acc
413
414
415 (****************************)
416 (* Disk writing and reading *)
417 (****************************)
418
419 external write : t -> io_t = "%identity"
420 external read : io_t -> t = "%identity"
Something went wrong with that request. Please try again.