Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

255 lines (225 sloc) 7.758 kB
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* depends *)
module List = BaseList
(* debug *)
#<Debugvar:DEBUG_DB$minlevel 1>
(* -- *)
type query =
| Set of Datas.t
| Remove of Keys.t
(* This type represents a map from nonempty paths to queries.
TODO: for speed and safety, represent multiple queries
not as lists, but an option of a set query and a list
of remove queries. Or only have a single recursive removal query. *)
type t = query list KeyRecMap.map
let path_to_nonempty_list l =
let l = Path.to_list l in
assert (not (List.is_empty l));
l
(* Print *)
let print_query = function
| Set d -> Printf.sprintf "set %s" (Datas.to_string d)
| Remove k -> Printf.sprintf "remove %s" (Keys.to_string k)
let print_query_list list =
List.to_string (fun q -> Printf.sprintf "%s " (print_query q)) list
let print_query_map map =
let rec aux map prof =
let indent = String.make (prof*8) '\032' in
if KeyRecMap.is_empty map then (Printf.sprintf "%sempty\n" indent)
else
KeyRecMap.fold (
fun key (qlist, new_map) acc ->
let query_string = print_query_list qlist in
Printf.sprintf "%s%s%s -> [%s],\n%s"
acc indent (Keys.to_string key)
query_string (aux new_map (succ prof))
) map ""
in aux map 0
(* Merge *)
let find_map_from_path map path =
let rec aux path map =
match path with
| [] -> raise Not_found
| [k] -> KeyRecMap.find k map
| hd :: tl ->
let _, new_map = KeyRecMap.find hd map in
aux tl new_map
in
aux (path_to_nonempty_list path) map
let rec check_no_set = function
| [] -> true
| Set _ :: _ -> false
| _ :: tl -> check_no_set tl
(* TODO: this seems broken.
The exception should be raised iff both transactions modify the same path
in any way. This is not the case now. It's not even symmetric.
TODO, including the next function, merge_query_list.
*)
let check_list l old_list old_map =
List.iter (
fun query ->
match query with
| Set (Datas.Data _) ->
(* TODO: this is too weak. What if old_list level above contains
remove of this node? the condition on Remove is not symmetric!*)
if not (check_no_set old_list) then begin
#<If>
Logger.log ~color:`red "Merge conflict at Data!"
#<End>;
raise Hldb.Merge
end
| Set (Datas.Link _) ->
if not (KeyRecMap.is_empty old_map && check_no_set old_list) then begin
#<If>
Logger.log ~color:`red "Merge conflict at Link!"
#<End>;
raise Hldb.Merge
end
| Set (Datas.Copy (_, _)) ->
if not (check_no_set old_list) then begin
#<If>
Logger.log ~color:`red "Merge conflict at Copy!"
#<End>;
raise Hldb.Merge
end
| Set Datas.UnsetData -> assert false
| Remove k ->
(* TODO: isn't this too strong? what if old_list also removes it?
Louis says it can stay so for now, but has to be symmetric *)
if KeyRecMap.mem k old_map then begin
#<If>
Logger.log ~color:`red "Merge conflict at Remove!"
#<End>;
raise Hldb.Merge
end
) l
(* TODO: simplify *)
let mergeable_query_list ql1 m1 ql2 m2 =
match ql1 with
| [] ->
begin match ql2 with
| [] -> ()
| l -> check_list l [] m1
end
| l -> check_list l ql2 m2
(** check the mergeability of m1 and m2; raise Merge, if failure *)
let mergeable_query_maps m1 m2 =
#<If>
Logger.log ~color:`yellow "checking the mergeability of query maps %s%s"
(print_query_map m1) (print_query_map m2)
#<End>;
if KeyRecMap.is_empty m1 || KeyRecMap.is_empty m2 then ()
else
let rec aux m1 m2 =
KeyRecMap.iter (
fun key (query_list, new_map) ->
(*
Mathieu Wed Mar 16 16:43:04 CET 2011
AIE AIE AIE (mem + find)
*)
if KeyRecMap.mem key m1 then
let old_query_list, old_map = KeyRecMap.find key m1 in
mergeable_query_list query_list new_map old_query_list old_map;
aux new_map old_map
) m2
in
aux m1 m2
(** merge m1 and m2 *)
let merge_query_map m1 m2 =
#<If>
Logger.log ~color:`yellow "merging query maps %s%s"
(print_query_map m1) (print_query_map m2)
#<End>;
let rec aux m1 m2 =
KeyRecMap.fold (
fun key (query_list, new_map) acc ->
if KeyRecMap.mem key acc then
let old_query_list, old_map = KeyRecMap.find key acc in
let new_query_list =
mergeable_query_list query_list new_map old_query_list old_map;
query_list @ old_query_list
in
let new_map = aux new_map old_map in
KeyRecMap.add key (new_query_list, new_map) acc
else
KeyRecMap.add key (query_list, new_map) acc
) m2 m1
in
let res = aux m1 m2 in
#<If>
Logger.log ~color:`yellow "result = \n%s" (print_query_map res)
#<End>;
res
(* Add and remove *)
let add_to_query_map map path query =
let rec aux map path =
match path with
| [] -> map
| key :: rest ->
let new_map, old_query_list =
match KeyRecMap.find_opt key map with
| Some (ql, m) -> aux m rest, ql
| _ -> aux KeyRecMap.empty rest, []
in
let new_query_list =
if rest <> [] then old_query_list (*TODO: perhaps remove Removes*)
else
let is_remove query =
match query with
| Remove _ -> true
| Set _ -> false
in
if is_remove query then
(* Multiple [Remove] are OK, as long as they remove
different children. *)
if List.mem query old_query_list then old_query_list
else query :: old_query_list
else
(* Multiple [Set] overwrite each other. *)
let pruned_list = List.filter is_remove old_query_list in
query :: pruned_list
in
KeyRecMap.add key (new_query_list, new_map) map
in
aux map (path_to_nonempty_list path)
let overwrite_in_query_map map path new_map =
let rec aux map path =
match path with
| [] -> new_map
| key :: rest ->
let new_map, old_query_list =
match KeyRecMap.find_opt key map with
| Some (ql, m) -> aux m rest, ql
| _ -> aux KeyRecMap.empty rest, []
in
KeyRecMap.add key (old_query_list, new_map) map
in
aux map (path_to_nonempty_list path)
let remove_from_query_map map path =
let rec aux map path =
match path with
| [] -> assert false
| [x] -> KeyRecMap.remove x map
| hd :: tl ->
let old_data, old_map = KeyRecMap.find hd map in
let new_map = aux old_map tl in
KeyRecMap.add hd (old_data, new_map) map
in
try aux map (path_to_nonempty_list path)
with Not_found -> map
let rec find_set_in_query_list = function
| [] -> None
| Set d :: _ -> Some d
| _ :: tl -> find_set_in_query_list tl
Jump to Line
Something went wrong with that request. Please try again.