Permalink
Browse files

[feature] database: First version of db-light with memory-based shado…

…w-tree with subkeys and no data.
  • Loading branch information...
1 parent cd23bda commit a57e447db2838cd4acef9a5a536d05a2764ee981 @nrs135 nrs135 committed with Louis Gesbert Jul 28, 2011
View
1 database.mllib
@@ -84,3 +84,4 @@ database/light/Transaction_light
database/light/Db_light
database/light/Io_light
database/light/Encode_light
+database/light/Mem_tree_light
View
416 database/light/db_light.ml
@@ -15,12 +15,14 @@
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
-(*#<Debugvar:DEBUG_DB>*)
+#<Debugvar:DEBUG_DB>
(* depends *)
module List = BaseList
module String = BaseString
module Hashtbl = BaseHashtbl
+module Mtl = Mem_tree_light
+
let sprintf fmt = Printf.sprintf fmt
let eprintf fmt = Printf.eprintf fmt
let printf fmt = Printf.printf fmt
@@ -35,12 +37,12 @@ exception Merge
exception At_root
exception At_leaf
-(* Datatypes *)
+(* Flags *)
+let verify = ref false
+let use_od = ref true
+let od_early = ref false
-module KeySet = Set.Make(Keys)
-let list_of_keyset ks = KeySet.fold (fun k l -> k::l) ks []
-let keyset_of_list l = List.fold_right KeySet.add l KeySet.empty
-let string_of_keyset ks = String.concat_map ~left:"[" ~right:"]" ~nil:"[]" ";" Keys.to_string (list_of_keyset ks)
+(* Datatypes *)
type index = ((Path.t * float) list) StringMap.t
@@ -51,7 +53,6 @@ type tree = {
mutable node : Node_light.t;
mutable up : tree ref;
mutable disk : bool;
- mutable subkeys : KeySet.t;
}
type t = {
@@ -61,6 +62,7 @@ type t = {
mutable next_uid : Uid.t;
mutable index : index;
mutable max_size : int;
+ mutable mtree : Mtl.mem_tree;
tree : tree;
}
@@ -76,7 +78,7 @@ let create_node ?max_size ?filemanager ?content () =
if _max_size < max_int
then
let disk_file = Io_light.get_content_file_name fm in
- #<If$minlevel 10>Logger.log ~color:`yellow "stuffing data to %s\n%!" disk_file#<End>;
+ #<If$minlevel 10>Logger.log ~color:`yellow "stuffing data to %s" disk_file#<End>;
Node_light.create ~disk_file ?max_size ?content ()
else
Node_light.create ?max_size ?content ()
@@ -91,15 +93,13 @@ let make_node t key data =
node = create_node ~max_size:t.max_size ?filemanager:t.db_filemanager ~content:data ();
up = ref (Obj.magic 0);
disk = false;
- subkeys = KeySet.empty;
} in
tree.up := tree;
tree
let make_t ?filemanager ?(max_size=max_int) () =
- Logger.log ~color:`yellow "DB-LIGHT : make_t: filemanager=%s max_size=%d"
- (if Option.is_some filemanager then "Some" else "None")
- max_size;
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : make_t: filemanager=%s max_size=%d"
+ (if Option.is_some filemanager then "Some" else "None") max_size#<End>;
let t = { version = "<new>";
db_filemanager = filemanager;
tcount = Eid.make 0;
@@ -110,8 +110,8 @@ let make_t ?filemanager ?(max_size=max_int) () =
node = create_node ~max_size ?filemanager ();
up = ref (Obj.magic 0);
disk = false;
- subkeys = KeySet.empty;
};
+ mtree = Mtl.make (Keys.StringKey "");
index = StringMap.empty;
max_size = max_size;
} in
@@ -127,7 +127,7 @@ let rec copy_node t parent tree =
node = tree.node;
up = ref parent;
disk = false;
- subkeys = tree.subkeys;
+ (*subkeys = tree.subkeys;*)
} in
Hashtbl.iter (fun k st -> Hashtbl.add ntree.sts k (copy_node t ntree st)) tree.sts;
t.tcount <- Eid.succ t.tcount;
@@ -137,9 +137,9 @@ let rec copy_node t parent tree =
(* Basic database operations *)
let set_version t version = t.version <- version
-
let set_filemanager t filemanager = t.db_filemanager <- filemanager
let set_max_size t max_size = t.max_size <- max_size
+let set_mtree t mtree = t.mtree <- mtree
let getdbm t =
match t.db_filemanager with
@@ -150,62 +150,60 @@ let ondemand_read not_quiet t path =
match getdbm t with
| Some dbm ->
(try
- let kl, node = snd (Encode_light.decode_kln (Dbm.find dbm (Encode_light.encode_path path)) 0) in
- let ks = keyset_of_list kl in
+ let node = snd (Encode_light.decode_node (Dbm.find dbm (Encode_light.encode_path path)) 0) in
if not_quiet then
- #<If>Logger.log ~color:`yellow "DB-LIGHT : ondemand read path %s -> %s,%s"
- (Path.to_string path) (string_of_keyset ks) (Node_light.to_string node)#<End>;
- Some (ks, node)
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : ondemand read path %s -> %s"
+ (Path.to_string path) (Node_light.to_string node)#<End>;
+ Some node
with Not_found ->
if not_quiet then
- #<If>Logger.log ~color:`yellow "DB-LIGHT : ondemand read path %s -> None" (Path.to_string path)#<End>;
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : ondemand read path %s -> None" (Path.to_string path)#<End>;
None)
| None ->
#<If>Logger.log ~color:`red "DB-LIGHT : ondemand_read Dbm is closed"#<End>;
None
-let _ondemand_subkeys t path = match ondemand_read false t path with | Some (ks, _) -> ks | None -> KeySet.empty
-
-let ondemand_subkeys t path = function
- | Some tree -> if tree.disk then tree.subkeys else _ondemand_subkeys t path
- | None -> _ondemand_subkeys t path
-
let ondemand_prime t path tree =
+ #<If$minlevel 30>Logger.log ~color:`yellow "DB-LIGHT : ondemand prime path=%s tree.disk=%b"
+ (Path.to_string path) tree.disk#<End>;
if not tree.disk
then
((match ondemand_read true t path with
- | Some (ks, node) ->
- tree.subkeys <- ks;
+ | Some node ->
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : ondemand prime path=%s to %s"
+ (Path.to_string path) (Node_light.to_string node)#<End>;
tree.node <- node
- (*Node_light.set_content ~max_size:t.max_size tree.node datas;*)
- | None -> ());
+ | None ->
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : ondemand prime path=%s not present"
+ (Path.to_string path)#<End>;
+ ());
tree.disk <- true)
-let ondemand_add t path ks node =
+let ondemand_add t path node =
match getdbm t with
| Some dbm ->
- #<If>Logger.log ~color:`yellow "DB-LIGHT : ondemand add path=%s ks=%s to %s"
- (Path.to_string path) (string_of_keyset ks) (Node_light.to_string node)#<End>;
- Dbm.replace dbm (Encode_light.encode_path path) (Encode_light.encode_kln (list_of_keyset ks,node))
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : ondemand add path=%s to %s"
+ (Path.to_string path) (Node_light.to_string node)#<End>;
+ Dbm.replace dbm (Encode_light.encode_path path) (Encode_light.encode_node node)
| None ->
#<If>Logger.log ~color:`red "DB-LIGHT : ondemand_add Dbm is closed"#<End>
let ondemand_remove _what t path =
match getdbm t with
| Some dbm ->
(* TODO: delete file *)
- #<If>Logger.log ~color:`yellow "DB-LIGHT : ondemand removing %s %s" _what (Path.to_string path)#<End>;
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : ondemand removing %s %s" _what (Path.to_string path)#<End>;
(try Dbm.remove dbm (Encode_light.encode_path path)
with Dbm.Dbm_error "dbm_delete" -> Logger.log ~color:`red "ondemand_remove: error")
| None ->
#<If>Logger.log ~color:`red "DB-LIGHT : ondemand_remove Dbm is closed"#<End>
type od_act =
- | OD_Add of t * KeySet.t * Node_light.t
+ | OD_Add of t * Node_light.t
| OD_Remove of t * string
let string_of_od_act p = function
- | OD_Add (_, ks, n) -> sprintf "Add (%s,%s,%s)" (Path.to_string p) (string_of_keyset ks) (Node_light.to_string n)
+ | OD_Add (_, n) -> sprintf "Add (%s,%s)" (Path.to_string p) (Node_light.to_string n)
| OD_Remove (_, what) -> sprintf "Remove (%s,\"%s\")" (Path.to_string p) what
let odacts = ((Hashtbl.create 100):(Path.t, od_act) Hashtbl.t)
@@ -215,32 +213,31 @@ let string_of_odacts () =
String.concat_map ~left:"[" ~right:"]" ~nil:"[]" "; " (fun s -> s) l
let add_od_act p act =
- (*(match Hashtbl.find_opt odacts p with
- | Some old_act -> eprintf "Replacing OD_ACT: %s -> %s\n%!" (string_of_od_act p old_act) (string_of_od_act p act)
- | None -> ());*)
+ #<If$minlevel 30>
+ (match Hashtbl.find_opt odacts p with
+ | Some old_act -> eprintf "Replacing OD_ACT: %s -> %s\n%!" (string_of_od_act p old_act) (string_of_od_act p act)
+ | None -> ())
+ #<End>;
Hashtbl.replace odacts p act
let same_t t1 t2 =
match (t1.db_filemanager, t2.db_filemanager) with
| Some fm1, Some fm2 -> fm1.Io_light.location = fm2.Io_light.location
| _, _ -> false
-let use_od = ref true
-let od_early = ref false
-
let od_read not_quiet t path =
if !use_od
then
(match Hashtbl.find_opt odacts path with
- | Some (OD_Add (tt, k, node)) -> if same_t t tt then Some (k, node) else ondemand_read not_quiet tt path
+ | Some (OD_Add (tt, node)) -> if same_t t tt then Some node else ondemand_read not_quiet tt path
| Some (OD_Remove (tt, _)) -> if same_t t tt then None else ondemand_read not_quiet tt path
| None -> ondemand_read not_quiet t path)
else ondemand_read not_quiet t path
-let od_add t path ks node =
+let od_add t path node =
if !use_od
- then add_od_act path (OD_Add (t, ks, node))
- else ondemand_add t path ks node
+ then add_od_act path (OD_Add (t, node))
+ else ondemand_add t path node
let od_rmv what t path =
if !use_od
@@ -252,209 +249,297 @@ let action_od () =
then
((*eprintf "od_acts: %s\n%!" (string_of_odacts ());*)
Hashtbl.iter (fun p -> function
- | OD_Add (t, ks, n) -> ondemand_add t p ks n
+ | OD_Add (t, n) -> ondemand_add t p n
| OD_Remove (t, what) -> ondemand_remove what t p) odacts;
Hashtbl.clear odacts)
let rec ondemand_remove_subtree t path tree_opt =
(*eprintf "ondemand_remove_subtree %s tree=%s\n%!"
(Path.to_string path) (Option.to_string (fun tree -> Uid.to_string tree.uid) tree_opt);*)
- let sks = ondemand_subkeys t path tree_opt in
- (*eprintf "ondemand_remove_subtree: sks=%s\n%!" (string_of_keyset sks);*)
- KeySet.iter
- (fun k ->
- ondemand_remove_subtree t (Path.add path k)
- (match tree_opt with
- | Some tree -> (try Some (Hashtbl.find tree.sts k) with Not_found -> None)
- | None -> None)) sks;
+ (match Mtl.find_mtree_sks t.mtree path with
+ | Some sks ->
+ (*eprintf "ondemand_remove_subtree: sks=%s\n%!" (String.concat_map ~left:"[" ~right:"]" "; " Keys.to_string sks);*)
+ List.iter
+ (fun k ->
+ ondemand_remove_subtree t (Path.add path k)
+ (match tree_opt with
+ | Some tree -> (try Some (Hashtbl.find tree.sts k) with Not_found -> None)
+ | None -> None)) sks;
+ | None -> ());
od_rmv "subtree" t path
-let refresh_data t path ks node tree =
+(*
+let refresh_data t path node tree =
if tree.disk
then ((*eprintf "refresh_data: path=%s content=%s node=%s subkeys=%s ks=%s\n%!"
(Path.to_string path) (Datas.to_string (Node_light.get_content tree.node)) (Node_light.to_string node)
(string_of_keyset tree.subkeys) (string_of_keyset ks);*)
- if not (Node_light.equals tree.node node) || not (KeySet.equal tree.subkeys ks) then od_add t path ks node)
+ if not (Node_light.equals tree.node node) then od_add t path node)
else (match od_read true t path with
- | Some (kss, nodes) ->
+ | Some nodes ->
(*eprintf "refresh_data: path=%s nodes=%s node=%s kss=%s ks=%s\n%!"
(Path.to_string path) (Node_light.to_string nodes) (Node_light.to_string node) (string_of_keyset kss) (string_of_keyset ks);*)
- if not (Node_light.equals nodes node) || not (KeySet.equal kss ks) then od_add t path ks node
- | None -> od_add t path ks node);
- tree.subkeys <- ks;
+ if not (Node_light.equals nodes node) then od_add t path node
+ | None -> od_add t path node);
tree.node <- node;
(*Node_light.set_content ~max_size:t.max_size tree.node data;*)
- tree.disk <- true
+ tree.disk <- true;
+ Mtl.refresh_mtree t.mtree path (Node_light.is_occupied node)
+*)
+
+let verify_mtree_at_path t path =
+ match getdbm t with
+ | Some dbm ->
+ let sks =
+ match Mtl.find_mtree_sks t.mtree path with
+ | Some sks -> sks
+ | None -> []
+ in
+ List.for_all (fun k ->
+ (try ignore (Dbm.find dbm (Encode_light.encode_path (Path.add path k))); true
+ with Not_found -> false)) sks
+ | None -> false
+
+let verify_mtree t =
+ match getdbm t with
+ | Some dbm ->
+ Mtl.fold
+ (fun path _k data valid ->
+ valid &&
+ (try
+ let datastr = Dbm.find dbm (Encode_light.encode_path path) in
+ let node = snd (Encode_light.decode_node datastr 0) in
+ let res = data = (node.Node_light.content <> Datas.UnsetData) in
+ if not res then Logger.log ~color:`red "verify_mtree: fails on path %s" (Path.to_string path);
+ res
+ with Not_found -> false))
+ true t.mtree Path.root
+ | None -> false
+
+let verify_database t =
+ match getdbm t with
+ | Some dbm ->
+ let disk_pathnodes =
+ let pathnodes = ref [] in
+ Dbm.iter (fun pathstr nodestr ->
+ match pathstr with
+ | "version" | "ondemand" | "max_size" | "timestamp" | "lock_pid" | "lock_hostname" ->
+ ()
+ | _ ->
+ let path = snd (Encode_light.decode_path pathstr 0) in
+ let node = snd (Encode_light.decode_node nodestr 0) in
+ pathnodes := (path,node)::!pathnodes
+ ) dbm;
+ !pathnodes
+ in
+ let dpaths = List.map (fun (p,_) -> p) disk_pathnodes in
+ let mem_pathdatas = Mtl.fold (fun p _k d pds -> (p,d)::pds) [] t.mtree Path.root in
+ let mpaths = List.map (fun (p,_) -> p) mem_pathdatas in
+ let module PS = Set.Make(Path) in
+ let dpset = List.fold_right PS.add dpaths PS.empty in
+ let mpset = List.fold_right PS.add mpaths PS.empty in
+ let not_on_disk = PS.diff mpset dpset in
+ let not_in_mem = PS.diff dpset mpset in
+ if (PS.is_empty not_on_disk) && (PS.is_empty not_in_mem)
+ then (let pncompare (p1,_) (p2,_) = Path.compare p1 p2 in
+ let pdcompare (p1,_) (p2,_) = Path.compare p1 p2 in
+ let dpns = List.sort pncompare disk_pathnodes in
+ let dpds = List.sort pdcompare mem_pathdatas in
+ List.iter2 (fun (p1,n) (p2,d) ->
+ if Path.compare p1 p2 <> 0
+ then Logger.error "verify_database: path mismatch %s %s" (Path.to_string p1) (Path.to_string p2)
+ else
+ (if d <> Node_light.is_occupied n
+ then Logger.log ~color:`red "verify_database: data mismatch on path %s node=%s mdata=%b"
+ (Path.to_string p1) (Node_light.to_string n) d))
+ dpns dpds;
+ Logger.log ~color:`green "verify_database: verifies");
+ if not (PS.is_empty not_on_disk)
+ then (let nodl = PS.fold (fun p ps -> p::ps) not_on_disk [] in
+ Logger.log ~color:`red "verify_database: not_on_disk=[%s]" (String.concat_map "; " Path.to_string nodl));
+ if not (PS.is_empty not_in_mem)
+ then (let niml = PS.fold (fun p ps -> p::ps) not_in_mem [] in
+ Logger.log ~color:`red "verify_database: not_in_mem=[%s]" (String.concat_map "; " Path.to_string niml))
+ | None ->
+ Logger.log ~color:`red "verify_database: Dbm file is closed!"
let verify_data t path tree_opt =
let msg =
match tree_opt with
| Some tree ->
(match od_read false t path with
- | Some (kss, node) ->
+ | Some node ->
sprintf "verify_data(disk=%b): path=%s\n" tree.disk (Path.to_string path)^
- (if KeySet.equal kss tree.subkeys
- then sprintf " ks: OK=%s\n" (string_of_keyset kss)
- else sprintf " ks: MEM=%s\n DSK=%s\n" (string_of_keyset tree.subkeys) (string_of_keyset kss))^
(if Node_light.equals tree.node node
then sprintf " data: OK=%s\n%!" (Node_light.to_string node)
else sprintf " data: MEM=%s\n DSK=%s\n%!" (Node_light.to_string tree.node) (Node_light.to_string node))
| None ->
sprintf "verify_data(disk=%b): path=%s\n" tree.disk (Path.to_string path)^
- (if KeySet.is_empty tree.subkeys
- then sprintf " ks: OK=%s\n" (string_of_keyset tree.subkeys)
- else sprintf " ks: MEM=%s\n" (string_of_keyset tree.subkeys))^
(if Node_light.equals_data tree.node Datas.UnsetData
then sprintf " data: OK=%s\n%!" (Node_light.to_string tree.node)
else sprintf " data: MEM=%s\n%!" (Node_light.to_string tree.node)))
| None ->
(match od_read false t path with
- | Some (kss, node) ->
+ | Some node ->
sprintf "verify_data(no tree): path=%s\n" (Path.to_string path)^
- sprintf " ks: MEM=None\n DSK=%s\n" (string_of_keyset kss)^
sprintf " data: MEM=None\n DSK=%s\n%!" (Node_light.to_string node)
| None ->
sprintf "verify_data(no tree): path=%s\n" (Path.to_string path)^
- sprintf " ks: OK=None\n"^
sprintf " data: OK=None\n%!")
in
Logger.log ~color:`red "%s" msg
let verifies t path = function
| Some tree ->
(match od_read false t path with
- | Some (kss, node) -> KeySet.equal kss tree.subkeys && Node_light.equals node tree.node
- | None -> KeySet.is_empty tree.subkeys && not (Node_light.is_occupied tree.node))
+ | Some node -> Node_light.equals node tree.node
+ | None -> not (Node_light.is_occupied tree.node))
| None ->
(match od_read false t path with
| Some _ -> false
| None -> true)
-let update_data t path ks data tree =
+let update_data t path data tree =
(*eprintf "update_data: path=%s ks=%s data=%s tree=%d\n%!"
(Path.to_string path) (string_of_keyset ks) (Datas.to_string data) (Uid.value tree.uid);*)
let _old_data = Node_light.get_content tree.node in
(if not tree.disk
then (match od_read true t path with
- | Some (kss, nodes) ->
+ | Some nodes ->
(*eprintf "nodes=%s data=%s kss=%s ks=%s\n%!"
(Node_light.to_string nodes) (Datas.to_string data) (string_of_keyset kss) (string_of_keyset ks);*)
- if not (Node_light.equals_data nodes data) || not (KeySet.equal kss ks)
+ if not (Node_light.equals_data nodes data)
then (Node_light.set_content ~max_size:t.max_size tree.node data;
- od_add t path ks tree.node)
+ od_add t path tree.node)
| None ->
Node_light.set_content ~max_size:t.max_size tree.node data;
- od_add t path ks tree.node)
+ od_add t path tree.node)
else
- if not (Node_light.equals_data tree.node data) || not (KeySet.equal tree.subkeys ks)
+ if not (Node_light.equals_data tree.node data)
then (Node_light.set_content ~max_size:t.max_size tree.node data;
- od_add t path ks tree.node);
- tree.subkeys <- ks);
+ od_add t path tree.node));
tree.disk <- true;
#<If$minlevel 3>Logger.log ~color:`yellow "DB-LIGHT : update_data: data=%s old_data=%s, using %s data"
(Datas.to_string data) (Datas.to_string _old_data)
(if Node_light.equals_data tree.node data then "new" else "old")#<End>
-let add_tree t path data =
+let add_tree ?(no_write=false) t path data =
#<If>Logger.log ~color:`yellow "DB-LIGHT : add_tree: path=%s data=%s" (Path.to_string path) (Datas.to_string data)#<End>;
let rec aux pt here tree = function
| [] ->
tree.up := pt;
- pt.subkeys <- KeySet.add (Path.last path) pt.subkeys;
- update_data t path tree.subkeys data tree
+ if no_write
+ then Node_light.set_content ~max_size:t.max_size tree.node data
+ else update_data t path data tree
| k::rest ->
(try
let st = Hashtbl.find tree.sts k in
aux tree (Path.add here k) st rest
with Not_found ->
let st = make_node t k Datas.UnsetData in
st.up <- ref tree;
- tree.subkeys <- KeySet.add k tree.subkeys;
- od_add t here tree.subkeys tree.node;
+ od_add t here tree.node;
Hashtbl.add tree.sts k st;
aux tree (Path.add here k) st rest)
in
aux t.tree Path.root t.tree (Path.to_list path);
if !od_early then action_od ();
- t.tcount <- Eid.succ t.tcount
+ t.tcount <- Eid.succ t.tcount;
+ Mtl.add_mtree t.mtree path data
let add_bare_tree t tree k =
let st = make_node t k Datas.UnsetData in
st.up <- ref tree;
- tree.subkeys <- KeySet.add k tree.subkeys;
Hashtbl.add tree.sts k st;
st
let rec find_st t path tree k =
- (*if not (verifies t path (Some tree)) then verify_data t path (Some tree);*)
+ if !verify
+ then (ignore (verify_mtree t);
+ if not (verifies t path (Some tree)) then verify_data t path (Some tree));
try
- (*eprintf "find_st: trying sts(%s)\n%!" (string_of_sts tree.sts);*)
+ #<If$minlevel 30>Logger.log ~color:`yellow "DB-LIGHT : find_st: trying sts(%s)" (string_of_sts tree.sts)#<End>;
let st = Hashtbl.find tree.sts k in
- (*eprintf "find_st: path=%s tree=%d k=%s from sts %d\n%!"
- (Path.to_string path) (Uid.value tree.uid) (Keys.to_string k) (Uid.value st.uid);*)
- st
+ #<If$minlevel 30>Logger.log ~color:`yellow "DB-LIGHT : find_st: path=%s tree=%d k=%s from sts %d (st.disk=%b)"
+ (Path.to_string path) (Uid.value tree.uid)
+ (Keys.to_string k) (Uid.value st.uid) st.disk#<End>;
+ if st.disk
+ then st
+ else (ondemand_prime t (Path.add path k) st;
+ st)
with Not_found ->
- (*eprintf "find_st: trying subkeys([%s])\n%!" (string_of_keyset tree.subkeys);
- eprintf "tree.disk=%b\n%!" tree.disk;*)
+ #<If$minlevel 30>
+ let sks =
+ match Mtl.find_mtree t.mtree path with
+ | Some mtree -> Hashtbl.fold (fun k _ ks -> k::ks) mtree.Mtl.msts []
+ | None -> []
+ in
+ Logger.log ~color:`yellow "DB-LIGHT : find_st: trying subkeys([%s])" (String.concat_map "; " Keys.to_string sks);
+ Logger.log ~color:`yellow "DB-LIGHT : find_st: tree.disk=%b" tree.disk
+ #<End>;
if tree.disk
- then
- if KeySet.mem k tree.subkeys
- then
- let st = add_bare_tree t tree k in
- ondemand_prime t (Path.add path k) st;
- (*eprintf "find_st: from prime %d\n%!" (Uid.value st.uid);*)
- st
- else raise Not_found
- else ((*eprintf "find_st: priming %s %d\n%!" (Path.to_string path) (Uid.value tree.uid);*)
+ then
+ if (match Mtl.find_mtree t.mtree path with
+ | Some mtree -> Hashtbl.mem mtree.Mtl.msts k
+ | None -> false)
+ then
+ let st = add_bare_tree t tree k in
+ ondemand_prime t (Path.add path k) st;
+ #<If$minlevel 30>Logger.log ~color:`yellow "DB-LIGHT : find_st: from prime %d" (Uid.value st.uid)#<End>;
+ st
+ else raise Not_found
+ else (#<If$minlevel 30>Logger.log ~color:`yellow "DB-LIGHT : find_st: priming %s %d"
+ (Path.to_string path) (Uid.value tree.uid)#<End>;
ondemand_prime t path tree;
find_st t path tree k)
let remove_tree t path =
#<If>Logger.log ~color:`yellow "DB-LIGHT : remove_tree: path=%s" (Path.to_string path)#<End>;
- let rec aux here tree kl =
+ let rec aux here tree mtree kl =
(*eprintf "remove_tree(aux): here=%s tree=%d kl=[%s]\n%!"
(Path.to_string here) (Uid.value tree.uid) (String.concat_map ";" Keys.to_string kl);*)
match kl with
| [] -> false
| [k] ->
(try
let st = find_st t here tree k in
- #<If$minlevel 2>Logger.log ~color:`yellow "DB-LIGHT : remove_tree(rmv): path=%s data=%s"
- (Path.to_string path) (Datas.to_string (Node_light.get_content st.node))#<End>;
+ #<If$minlevel 2>Logger.log ~color:`yellow
+ "DB-LIGHT : remove_tree(rmv): path=%s data=%s"
+ (Path.to_string path) (Datas.to_string (Node_light.get_content st.node))#<End>;
(*eprintf "remove_tree: here_path=%s\n%!" (Path.to_string (Path.add here k));*)
ondemand_remove_subtree t path (Some st);
- let newsubkeys = KeySet.remove k tree.subkeys; in
- (*eprintf "remove_tree: here=%s remove key %s from tree %d\n%!"
- (Path.to_string here) (Keys.to_string k) (Uid.value tree.uid);*)
- refresh_data t here newsubkeys tree.node tree;
- tree.subkeys <- newsubkeys;
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : remove_tree: here=%s remove key %s from tree %d"
+ (Path.to_string here) (Keys.to_string k) (Uid.value tree.uid)#<End>;
+ (*refresh_data t here tree.node tree;*)
Node_light.delete st.node;
Hashtbl.remove tree.sts k;
+ Hashtbl.remove mtree.Mtl.msts k;
true
with Not_found -> false)
| k::rest ->
(try
let st = find_st t here tree k in
+ let mst = Hashtbl.find mtree.Mtl.msts k in
(*eprintf "remove_tree: at key=%s st=%d\n%!" (Keys.to_string k) (Uid.value st.uid);*)
- let removed = aux (Path.add here k) st rest in
+ let removed = aux (Path.add here k) st mst rest in
(*eprintf "remove_tree: at key=%s st=%d removed=%b #sts=%d content=%s\n%!"
(Keys.to_string k) (Uid.value st.uid)
removed (Hashtbl.length st.sts) (Datas.to_string (Node_light.get_content st.node));*)
- if removed && Hashtbl.length st.sts = 0 && Node_light.equals_data st.node Datas.UnsetData
- then (let newsubkeys = KeySet.remove k tree.subkeys; in
- (*eprintf "remove_tree: here=%s remove key %s from tree %d\n%!"
+ if removed && Hashtbl.length mst.Mtl.msts = 0 && Node_light.equals_data st.node Datas.UnsetData
+ then ((*eprintf "remove_tree: here=%s remove key %s from tree %d\n%!"
(Path.to_string here) (Keys.to_string k) (Uid.value tree.uid);*)
- refresh_data t here newsubkeys tree.node tree;
- tree.subkeys <- newsubkeys;
- (*eprintf "remove_tree: remove k=%s from tree=%d sts\n%!" (Keys.to_string k) (Uid.value tree.uid);*)
+ (*refresh_data t here tree.node tree; (* <-- TODO: Check if this is redundant (no keyset any more) *)*)
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : remove_tree: here=%s remove k=%s from tree=%d sts"
+ (Path.to_string here) (Keys.to_string k) (Uid.value tree.uid)#<End>;
od_rmv "path" t (Path.add here k);
(*eprintf "remove_tree: removing %s\n%!" (Path.to_string (Path.add here k));*)
Node_light.delete st.node;
- Hashtbl.remove tree.sts k);
+ Hashtbl.remove tree.sts k;
+ Hashtbl.remove mtree.Mtl.msts k);
removed
with Not_found -> false)
in
- let removed = aux Path.root t.tree (Path.to_list path) in
+ let removed = aux Path.root t.tree t.mtree (Path.to_list path) in
if !od_early then action_od ();
(match removed, Eid.pred t.tcount with
| true, Some eid -> t.tcount <- eid
@@ -481,8 +566,10 @@ let path_from_node node =
aux node []
let node_is_leaf t node =
- if not node.disk then ondemand_prime t (path_from_node node) node;
- KeySet.is_empty node.subkeys
+ (*eprintf "node_is_leaf: path=%s\n%!" (Path.to_string (path_from_node node));*)
+ (match Mtl.find_mtree t.mtree (path_from_node node) with
+ | Some mtree -> Hashtbl.length mtree.Mtl.msts = 0
+ | None -> true)
let up_node node = if node_is_root node then raise At_root else !(node.up)
@@ -516,19 +603,24 @@ let down_node t node key = if node_is_leaf t node then raise At_leaf else find_s
let down_node_opt t node key = try Some (down_node t node key) with | Not_found -> None | At_leaf -> None
let find_node t path =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : find_node: path=%s" (Path.to_string path)#<End>;
let tree = down_path t path in
if not tree.disk then ondemand_prime t path tree;
tree
-let find_node_opt t path = try Some (find_node t path) with Not_found -> None
+let find_node_opt t path =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : find_node_opt: path=%s" (Path.to_string path)#<End>;
+ try Some (find_node t path) with Not_found -> None
-let find_data t path = Node_light.get_content (find_node t path).node
+let find_data t path =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : find_data: path=%s" (Path.to_string path)#<End>;
+ Node_light.get_content (find_node t path).node
let find_data_opt t path = try Some (find_data t path) with Not_found -> None
-let string_of_node { sts=_; uid; key; node; up; subkeys } =
- sprintf "%d(^%dv%s): %s -> %s"
- (Uid.value uid) (Uid.value ((!up).uid)) (string_of_keyset subkeys)
+let string_of_node { sts=_; uid; key; node; up; } =
+ sprintf "%d(^%dvs): %s -> %s"
+ (Uid.value uid) (Uid.value ((!up).uid)) (*string_of_keyset subkeys*)
(Keys.to_string key) (Datas.to_string (Node_light.get_content node))
let rec string_of_tree0 indent node =
@@ -538,7 +630,8 @@ let rec string_of_tree0 indent node =
sprintf "%s%s%s ->\n%s%s" acc indent (Keys.to_string k) indent (string_of_tree0 (indent^" ") v))
node.sts s
let string_of_tree = string_of_tree0 ""
-let print_t t = printf "%s\n" (string_of_tree t.tree); flush stdout
+
+let print_t t = printf "mtree: \n%s\ntree: %s\n%!" (Mtl.string_of_mtree t.mtree) (string_of_tree t.tree)
(* the root of the database *)
let root_eid = Eid.make 0
@@ -575,18 +668,21 @@ let start = root_eid
let get_next_uid db = db.next_uid
let is_empty db = (Eid.value db.tcount = 0)
- let get_index db = db.index
+ let get_index _db = assert false (*db.index*)
+ let get_mtree db = db.mtree
(*****************************)
(* navigation through the db *)
(*****************************)
let get_tree_of_path db path =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : get_tree_of_path: path=%s" (Path.to_string path)#<End>;
try find_node db path
with Not_found -> raise UnqualifiedPath
let get_node_of_path db path =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : get_node_of_path: path=%s" (Path.to_string path)#<End>;
try ((find_node db path).node,rev)
with Not_found -> raise UnqualifiedPath
@@ -604,13 +700,17 @@ let start = root_eid
(* may raise UnqualifiedPath *)
let rec get db path =
- #<If:DEBUG_DB$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : get: path=%s%!" (Path.to_string path)#<End>;
let node, _rev = get_node_of_path db path in
+ let res =
match Node_light.get_content node with
| Datas.Data d -> d
| Datas.Link p
| Datas.Copy (_, p) -> get db p
| Datas.UnsetData -> DataImpl.empty
+ in
+ #<If$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : get: path=%s returning data=%s"
+ (Path.to_string path) (DataImpl.to_string res)#<End>;
+ res
let get_data (db:t) node =
let _ = db in
@@ -646,7 +746,7 @@ let start = root_eid
if inrange
then
(if not tree.disk then ondemand_prime db path tree;
- KeySet.fold
+ List.fold_right
(fun key (pl,pllen) ->
let sn = find_st db path tree key in
let spl,spllen =
@@ -660,7 +760,9 @@ let start = root_eid
aux sn spath pllen start (depth+1)
else ([],pllen)
in
- (pl@spl,spllen)) tree.subkeys start)
+ (pl@spl,spllen)) (match Mtl.find_mtree_sks db.mtree path with
+ | Some sks -> sks
+ | None -> assert false) start)
else
([],len)
in
@@ -687,28 +789,29 @@ let start = root_eid
(* may raise UnqualifiedPath *)
let get_children db range_opt path =
let ch = _get_children db range_opt path 1 true true in
- #<If:DEBUG_DB$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : get_children: %s -> [%s]"
+ #<If$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : get_children: %s -> [%s]"
(Path.to_string path) (String.concat_map "; " Path.to_string ch)#<End>;
ch
(* won't raise UnqualifiedPath *)
let get_all_children db range_opt path =
let ch = _get_children db range_opt path max_int false false in
- #<If:DEBUG_DB$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : get_all_children: %s -> [%s]%!"
+ #<If$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : get_all_children: %s -> [%s]%!"
(Path.to_string path) (String.concat_map "; " Path.to_string ch)#<End>;
ch
(********************)
(* basics DB writes *)
(********************)
- let update db path data = add_tree db path data; db
+ let update ?no_write db path data = add_tree ?no_write db path data; db
let remove db path = ignore (remove_tree db path); db
(* index management *)
- let update_index db update_list =
+ let update_index db _update_list = db
+(*
#<If$minlevel 3>
Logger.log ~color:`yellow
"DB-LIGHT : update_index: [%s]"
@@ -733,8 +836,10 @@ let start = root_eid
) db.index update_list
in
{db with index = new_index}
+*)
- let remove_from_index db remove_list =
+ let remove_from_index db _remove_list = db
+(*
#<If$minlevel 3>
Logger.log ~color:`yellow
"DB-LIGHT : remove_from_index: [%s]"
@@ -758,7 +863,7 @@ let start = root_eid
) db.index remove_list
in
{db with index = new_index}
-
+*)
(******************************************************)
@@ -832,11 +937,10 @@ let start = root_eid
db*)
let rec follow_path (db:t) node path_end =
- (*#<If:DEBUG_DB$minlevel 10>
- Logger.log ~color:`green
- (sprintf "DB : low-level following path; remaining: %s"
- (Path.to_string (Path.of_list path_end)))
- #<End>;*)
+ #<If$minlevel 10>
+ Logger.log ~color:`green "DB-LIGHT : low-level following path; remaining: %s"
+ (Path.to_string (Path.of_list path_end))
+ #<End>;
match path_end with
| [] -> ([], node)
| k :: rest ->
@@ -850,7 +954,7 @@ let start = root_eid
with Not_found -> raise UnqualifiedPath
let follow_link db path =
- #<If:DEBUG_DB$minlevel 20>Logger.log ~color:`yellow "DB-LIGHT : follow_link: path=%s" (Path.to_string path)#<End>;
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : follow_link: path=%s" (Path.to_string path)#<End>;
let rec aux db path =
let path_end = Path.to_list path in
let (path_end, node) = follow_path db db.tree path_end in
@@ -870,6 +974,7 @@ let start = root_eid
(*
let tt_ref = ref (make_t ())
+let dbl = ref []
let file = "/tmp/db_light_self_test"
let dodb file f =
@@ -878,19 +983,22 @@ let dodb file f =
Dbm.close db;
res
+let km1 = Keys.IntKey (-1)
let k0 = Keys.IntKey 0
let k1 = Keys.IntKey 1
let k2 = Keys.IntKey 2
let path = Path.of_list ([Keys.IntKey 1; Keys.IntKey 0; Keys.IntKey 2; Keys.IntKey 1; Keys.IntKey 583955; Keys.IntKey 0])
let path1 = Path.of_list ([k1])
+let path20 = Path.of_list ([k2;k0])
+let path2m1 = Path.of_list ([k2;km1])
let path10 = Path.add path1 k0
let path102 = Path.add path10 k2
let path1021 = Path.add path102 k1
let path1021n n = Path.add path1021 (Keys.IntKey n)
let path1021mn m n = Path.add (Path.add path1021 (Keys.IntKey m)) (Keys.IntKey n)
let rawfind file str = dodb file (fun db -> Dbm.find db str)
-let find file path = dodb file (fun db -> snd (Encode_light.decode_kln (Dbm.find db (Encode_light.encode_path path)) 0))
+let find file path = dodb file (fun db -> snd (Encode_light.decode_node (Dbm.find db (Encode_light.encode_path path)) 0))
let set_dbl file decode =
let dbl = ref [] in
@@ -902,22 +1010,22 @@ let set_dbl file decode =
| _ -> dbl := (Path.to_string (snd (Encode_light.decode_path k 0)),
snd (decode d 0))::!dbl);
(*print_endline (String.escaped (Printf.sprintf "%s -> %s" k d)) *) ) db);
- dbl
+ !dbl
let set_dbld file = set_dbl file Encode_light.decode_datas
let set_dbln file = set_dbl file Encode_light.decode_kln
let all_disk_nodes file =
let nodes = ref [] in
dodb file (fun db ->
- Dbm.iter (fun k d ->
+ Dbm.iter (fun k _d ->
(match k with
| "version" -> ()
| "timestamp" -> ()
| _ -> nodes := ((snd (Encode_light.decode_path k 0))::!nodes))) db);
!nodes
-let cleardb () =
+let cleardb file =
let db = Dbm.opendbm file [(*Dbm.Dbm_create;*) Dbm.Dbm_rdwr] 0O664 in
let keys = ref [] in
Dbm.iter (fun k _ -> keys := k::!keys) db;
@@ -1006,7 +1114,7 @@ let _ =
eprintf "remove abd\n%!"; ignore (remove_tree tt abd); print_t tt; vfy 11 pl;
eprintf "remove a\n%!"; ignore (remove_tree tt a); print_t tt; vfy 12 pl;
eprintf "remove def\n%!"; ignore (remove_tree tt def); print_t tt; vfy 13 pl;
- set_dbl file
- Io_light.close filemanager
+ Io_light.close filemanager;
+ dbl := set_dbln file
*)
View
15 database/light/db_light.mli
@@ -18,10 +18,15 @@
exception UnqualifiedPath
exception Merge
+(* flags *)
+val verify : bool ref
+val use_od : bool ref
+val od_early : bool ref
+
+(* types *)
type t
type tree
-(*type node_map*)
type index = ((Path.t * float) list) StringMap.t
(* access to node *)
@@ -42,10 +47,12 @@ val get_tcount : t -> Eid.t
val get_next_uid : t -> Uid.t
val is_empty : t -> bool
val get_index : t -> index
+val get_mtree : t -> Mem_tree_light.mem_tree
val set_version : t -> string -> unit
val set_filemanager : t -> Io_light.t option -> unit
val set_max_size : t -> int -> unit
+val set_mtree : t -> Mem_tree_light.mem_tree -> unit
(* navigation through the db *)
val get_node_of_path : t -> Path.t -> Node_light.t * Revision.t
@@ -55,7 +62,8 @@ val get_tree_of_path : t -> Path.t -> tree
val make : ?filemanager:Io_light.t -> ?max_size:int -> unit -> t
(* basic db writing *)
-val update : t -> Path.t -> Datas.t -> t
+(*val add_mtree : mem_tree -> Path.t -> Datas.t -> unit*)
+val update : ?no_write:bool -> t -> Path.t -> Datas.t -> t
val remove : t -> Path.t -> t
val set_rev : t -> Revision.t -> t
@@ -105,6 +113,7 @@ val follow_path : t -> tree -> Keys.t list -> Keys.t list * tree
val follow_link : t -> Path.t -> Path.t * tree
(* Caching *)
-val od_early : bool ref
val action_od : unit -> unit
+(* Verification *)
+val verify_database : t -> unit
View
45 database/light/encode_light.ml
@@ -21,6 +21,7 @@
module String = Base.String
let sprintf = Printf.sprintf
+let fprintf = Printf.fprintf
let ei8 i =
let s = String.create 1 in
@@ -131,6 +132,20 @@ let get_len c1 c2 c3 c4 s i c =
then i+9, di64 s (i+1)
else assert false
+let get_len_ic c1 c2 c3 c4 c ic =
+ try
+ let s = "xxxxxxxx" in
+ if c = c1
+ then (really_input ic s 0 1; di8 s 0)
+ else if c = c2
+ then (really_input ic s 0 2; di16 s 0)
+ else if c = c3
+ then (really_input ic s 0 4; di32 s 0)
+ else if c = c4
+ then (really_input ic s 0 8; di64 s 0)
+ else assert false
+ with End_of_file -> assert false
+
let rec decode_key s i =
match s.[i] with
| ('i' | 'j' | 'I' | 'J') as c ->
@@ -156,6 +171,33 @@ let rec decode_key s i =
i, Keys.VariableKey num
| _ -> assert false
+let rec decode_key_ic ic =
+ match input_char ic with
+ | ('i' | 'j' | 'I' | 'J') as c ->
+ let num = get_len_ic 'i' 'j' 'I' 'J' c ic in
+ Keys.IntKey num
+ | ('s' | 't' | 'S' | 'T') as c ->
+ let len = get_len_ic 's' 't' 'S' 'T' c ic in
+ let s = String.create len in
+ really_input ic s 0 len;
+ Keys.StringKey s
+ | ('l' | 'm' | 'L' | 'M') as c ->
+ let len = get_len_ic 'l' 'm' 'L' 'M' c ic in
+ let a = Array.make len (Keys.IntKey 0) in
+ let rec aux j =
+ if j >= len
+ then Keys.ListKey a
+ else
+ let k = decode_key_ic ic in
+ a.(j) <- k;
+ aux (j+1)
+ in
+ aux 0
+ | ('v' | 'w' | 'V' | 'W') as c ->
+ let num = get_len_ic 'v' 'w' 'V' 'W' c ic in
+ Keys.VariableKey num
+ | _ -> assert false
+
(*
let km1 = Keys.IntKey (-1)
let k1 = Keys.IntKey 123
@@ -245,7 +287,6 @@ let tstdi di = di = snd (decode_dataimpl (encode_dataimpl di) 0)
let good = List.for_all tstdi alldi
*)
-(* a b c d e f g h i j l m p q s t v w x y *)
let encode_datas = function
| Datas.Data di -> "e"^(encode_dataimpl di)
@@ -321,6 +362,8 @@ let kl1 = [k1;k2]
let good = tst2 (kl1,d1)
*)
+(* 2 Aa Bb Cc Dd e f Gg Hh Ii Jj k Ll Mm Nn Oo Pp Qq Rr Ss Tt Uu Vv Ww Xx Yy Zz *)
+
(*
let db = Dbm.opendbm ("/home/norman/.mlstate/"^(Filename.basename Sys.argv.(0))^"/db_light") [Dbm.Dbm_rdwr] 0O664;;
let db = Dbm.opendbm "/tmp/opadb1" [Dbm.Dbm_rdwr] 0O664;;
View
3 database/light/encode_light.mli
@@ -15,8 +15,11 @@
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
+val put_len : char -> char -> char -> char -> int -> string
+val get_len_ic : char -> char -> char -> char -> char -> in_channel -> int
val encode_key : Keys.t -> string
val decode_key : string -> int -> int * Keys.t
+val decode_key_ic : in_channel -> Keys.t
val encode_path : Path.t -> string
val decode_path : string -> int -> int * Path.t
val encode_dataimpl : DataImpl.data -> string
View
227 database/light/mem_tree_light.ml
@@ -0,0 +1,227 @@
+(*
+ 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/>.
+*)
+
+(* Simple image of the DB tree in memory without data *)
+
+#<Debugvar:DEBUG_DB>
+
+module String = Base.String
+let eprintf fmt = Printf.eprintf fmt
+let sprintf fmt = Printf.sprintf fmt
+let fprintf fmt = Printf.fprintf fmt
+
+type mem_tree = {
+ msts : (Keys.t, mem_tree) Hashtbl.t;
+ mutable mkey : Keys.t;
+ mutable mdata : bool;
+}
+
+let make key = { msts = Hashtbl.create 10; mkey = key; mdata = false; }
+
+let rec fold ff def mtree path =
+ Hashtbl.fold (fun k mt def ->
+ let spath = Path.add path k in
+ fold ff def mt spath) mtree.msts (ff path mtree.mkey mtree.mdata def)
+
+let find_mtree mtree path =
+ let rec aux here mtree kl =
+ match kl with
+ | [] -> Some mtree
+ | k::rest ->
+ try
+ let st = Hashtbl.find mtree.msts k in
+ aux (Path.add here k) st rest
+ with Not_found -> None
+ in
+ aux Path.root mtree (Path.to_list path)
+
+let find_mtree_data mtree path =
+ Option.map (fun mtree -> mtree.mdata) (find_mtree mtree path)
+
+let find_mtree_sts mtree path =
+ Option.map (fun mtree -> Hashtbl.fold (fun _ mt a -> mt::a) mtree.msts []) (find_mtree mtree path)
+
+let find_mtree_sks mtree path =
+ Option.map (fun mtree -> Hashtbl.fold (fun _ mt a -> mt.mkey::a) mtree.msts []) (find_mtree mtree path)
+
+(*
+let refresh_mtree mtree path mdata =
+ let rec aux here mtree = function
+ | [] ->
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : refresh_mtree: path=%s old mdata=%b new mdata=%b"
+ (Path.to_string path) mtree.mdata mdata#<End>;
+ mtree.mdata <- mdata
+ | k::rest ->
+ (try
+ let st = Hashtbl.find mtree.msts k in
+ aux (Path.add here k) st rest
+ with Not_found -> assert false)
+ in
+ aux Path.root mtree (Path.to_list path)
+*)
+
+let add_mtree mtree path data =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : add_mtree: path=%s" (Path.to_string path)#<End>;
+ let rec aux here mtree = function
+ | [] -> mtree.mdata <- (data <> Datas.UnsetData)
+ | k::rest ->
+ (try
+ let st = Hashtbl.find mtree.msts k in
+ aux (Path.add here k) st rest
+ with Not_found ->
+ let st = make k in
+ Hashtbl.add mtree.msts k st;
+ aux (Path.add here k) st rest)
+ in
+ aux Path.root mtree (Path.to_list path)
+
+(* Not needed, it had to be wrapped with Db_light.remove_tree...
+let remove_mtree mtree path =
+ #<If$minlevel 10>Logger.log ~color:`yellow "DB-LIGHT : remove_mtree: path=%s" (Path.to_string path)#<End>;
+ let rec aux here mtree kl =
+ match kl with
+ | [] -> false
+ | [k] ->
+ (Logger.log ~color:`yellow "DB-LIGHT : remove_mtree: here=%s removing key %s"
+ (Path.to_string (Path.add here k)) (Keys.to_string k);
+ Hashtbl.remove mtree.msts k;
+ true)
+ | k::rest ->
+ (try
+ let here = Path.add here k in
+ let st = Hashtbl.find mtree.msts k in
+ let stsks = Hashtbl.fold (fun k _ ks -> k::ks) st.msts [] in
+ Logger.log ~color:`yellow "DB-LIGHT : remove_mtree: here=%s stsks=[%s]"
+ (Path.to_string here) (String.concat_map "; " Keys.to_string stsks);
+ let removed = aux here st rest in
+ let stsks = Hashtbl.fold (fun k _ ks -> k::ks) st.msts [] in
+ Logger.log ~color:`yellow "DB-LIGHT : remove_mtree: here=%s k=%s removed=%b stsks=[%s] st.mdata=%b"
+ (Path.to_string here) (Keys.to_string k) removed
+ (String.concat_map "; " Keys.to_string stsks) st.mdata;
+ if removed && Hashtbl.length st.msts = 0 && not st.mdata
+ then (Logger.log ~color:`yellow "DB-LIGHT : remove_mtree: here=%s removing key %s"
+ (Path.to_string here) (Keys.to_string k);
+ Hashtbl.remove mtree.msts k);
+ removed
+ with Not_found -> false)
+ in
+ aux Path.root mtree (Path.to_list path)
+*)
+
+let rec copymt mt =
+ let ht = Hashtbl.create (Hashtbl.length mt.msts) in
+ Hashtbl.iter (fun k mt -> Hashtbl.add ht k (copymt mt)) mt.msts;
+ { msts = ht; mkey = mt.mkey; mdata = mt.mdata }
+
+let rec comparemt mt1 mt2 =
+ let cmpht ht1 ht2 =
+ Hashtbl.fold
+ (fun k mt1 eq ->
+ eq &&
+ (try
+ let mt2 = Hashtbl.find ht2 k in
+ comparemt mt1 mt2
+ with Not_found -> false)) ht1 true
+ in
+ mt1.mkey = mt2.mkey &&
+ mt1.mdata = mt2.mdata &&
+ cmpht mt1.msts mt2.msts &&
+ cmpht mt2.msts mt1.msts
+
+let output_mt oc tree =
+ let rec aux tree =
+ let sts = Hashtbl.fold (fun _ st acc -> st::acc) tree.msts [] in
+ fprintf oc "%s%s%s"
+ (if tree.mdata then "N" else "O")
+ (Encode_light.encode_key tree.mkey)
+ (Encode_light.put_len 'r' 'z' 'R' 'Z' (List.length sts));
+ List.iter aux sts
+ in
+ aux tree
+
+let input_mt ic =
+ let rec aux tree =
+ let has_data = match input_char ic with | 'N' -> true | 'O' -> false | _ -> assert false in
+ tree.mdata <- has_data;
+ let n = Encode_light.decode_key_ic ic in
+ tree.mkey <- n;
+ match input_char ic with
+ | ('r' | 'z' | 'R' | 'Z') as c ->
+ let len = Encode_light.get_len_ic 'r' 'z' 'R' 'Z' c ic in
+ let rec aux2 i =
+ if i >= len
+ then n
+ else
+ let st = make (Keys.StringKey "") in
+ let k = aux st in
+ Hashtbl.add tree.msts k st;
+ aux2 (i+1)
+ in
+ aux2 0
+ | _ -> assert false
+ in
+ let mtree = make (Keys.StringKey "") in
+ ignore (aux mtree);
+ (*eprintf "mtree=%s\n%!" (string_of_mtree mtree);*)
+ mtree
+
+let rec string_of_mtree0 indent mtree =
+ Hashtbl.fold
+ (fun _k v acc -> sprintf "%s\n%s%s" acc indent (string_of_mtree0 (indent^" ") v))
+ mtree.msts (sprintf "%s%s -> %s" indent (Keys.to_string mtree.mkey) (if mtree.mdata then "*" else ""))
+let string_of_mtree = string_of_mtree0 ""
+
+(*
+let _K_a = Keys.StringKey "a";;
+let _K_b = Keys.StringKey "b";;
+let _K_c = Keys.StringKey "c";;
+let _K_d = Keys.StringKey "d";;
+let _K_e = Keys.StringKey "e";;
+let _K_f = Keys.StringKey "f";;
+let a = Path.of_list [_K_a];;
+let abc = Path.of_list [_K_a; _K_b; _K_c];;
+let abd = Path.of_list [_K_a; _K_b; _K_d];;
+let def = Path.of_list [_K_d; _K_e; _K_f];;
+let mtree = make (Keys.StringKey "");;
+let mt1 = copymt mtree;;
+add_mtree mtree a (Datas.Data (DataImpl.Int 1));;
+let mt2 = copymt mtree;;
+add_mtree mtree abc (Datas.Data (DataImpl.Int 123));;
+let mt3 = copymt mtree;;
+add_mtree mtree abd (Datas.Data (DataImpl.Int 124));;
+let mt4 = copymt mtree;;
+add_mtree mtree def (Datas.Data (DataImpl.Int 456));;
+let mt5 = copymt mtree;;
+let file = "mem_tree_light_test";;
+let test_ot file mtree =
+ let oc = open_out file in
+ output_mt oc mtree;
+ close_out oc;;
+let test_it file =
+ let ic = open_in file in
+ let mtree = input_mt ic in
+ close_in ic;
+ mtree;;
+let tstmt mt =
+ test_ot file mt;
+ let mt2 = test_it file in
+ comparemt mt mt2;;
+let allmt = [mt1;mt2;mt3;mt4;mt5];;
+let good = List.for_all tstmt allmt;;
+eprintf "good=%b\n%!" good;;
+*)
View
38 database/light/mem_tree_light.mli
@@ -0,0 +1,38 @@
+(*
+ 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/>.
+*)
+
+(* Simple image of the DB tree in memory without data *)
+type mem_tree = {
+ msts : (Keys.t, mem_tree) Hashtbl.t;
+ mutable mkey : Keys.t;
+ mutable mdata : bool;
+}
+val make : Keys.t -> mem_tree
+val fold : (Path.t -> Keys.t -> bool -> 'a -> 'a) -> 'a -> mem_tree -> Path.t -> 'a
+val find_mtree : mem_tree -> Path.t -> mem_tree option
+val find_mtree_data : mem_tree -> Path.t -> bool option
+val find_mtree_sts : mem_tree -> Path.t -> mem_tree list option
+val find_mtree_sks : mem_tree -> Path.t -> Keys.t list option
+(*val refresh_mtree : mem_tree -> Path.t -> bool -> unit*)
+val add_mtree : mem_tree -> Path.t -> Datas.ns -> unit
+(*val remove_mtree : mem_tree -> Path.t -> bool*)
+val copymt : mem_tree -> mem_tree
+val comparemt : mem_tree -> mem_tree -> bool
+val output_mt : out_channel -> mem_tree -> unit
+val input_mt : in_channel -> mem_tree
+val string_of_mtree : mem_tree -> string
View
49 database/light/session_light.ml
@@ -195,6 +195,11 @@ let sprintf fmt = Printf.sprintf fmt
let close_db ?(donothing=false) t =
let _ = donothing in
let file = Io_light.get_location t.file_manager in
+ let mtree_file = file^"_mtree" in
+ let oc = open_out mtree_file in
+ Mem_tree_light.output_mt oc (Db_light.get_mtree t.db_ref);
+ close_out oc;
+ Logger.log "close_db: mtree_file=%s" mtree_file;
let _position = position file in
Logger.info "DB-LIGHT : Closing the database at %s" file;
Io_light.close t.file_manager;
@@ -203,6 +208,20 @@ let sprintf fmt = Printf.sprintf fmt
let restart_db_from_last t =
let db = t.db_ref in
+ let mtree_file = Io_light.get_location t.file_manager^"_mtree" in
+ Logger.log "restart_db_from_last: mtree_file=%s" mtree_file;
+ let has_mtree =
+ try
+ let ic = open_in mtree_file in
+ let mtree = Mem_tree_light.input_mt ic in
+ Db_light.set_mtree t.db_ref mtree;
+ close_in ic;
+ true
+ with Sys_error _ -> false
+ in
+ Logger.log "restart_db_from_last: has_mtree=%b" has_mtree;
+ if t.with_ondemand && not has_mtree
+ then Logger.warning "DB-LIGHT : Warning: unable to read mem_tree file, rebuilding from Dbm";
(match Io_light.get_dbm t.file_manager with
| Some dbm ->
Dbm.iter (fun pathstr datastr ->
@@ -241,7 +260,32 @@ let sprintf fmt = Printf.sprintf fmt
#<If>Logger.log ~color:`magenta "DB-LIGHT : Dbm file lock hostname %s" datastr#<End>
| _ ->
if t.with_ondemand
- then ()
+ then
+ (if not has_mtree
+ then
+ (let path = snd (Encode_light.decode_path pathstr 0) in
+ let node = snd (Encode_light.decode_node datastr 0) in
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : set mtree %s -> %s"
+ (Path.to_string path)
+ (Datas.to_string node.Node_light.content)#<End>;
+ Mem_tree_light.add_mtree (Db_light.get_mtree t.db_ref) path node.Node_light.content)
+ else
+ (if !(Db_light.verify)
+ then
+ let path = snd (Encode_light.decode_path pathstr 0) in
+ let node = snd (Encode_light.decode_node datastr 0) in
+ match Mem_tree_light.find_mtree_data (Db_light.get_mtree t.db_ref) path with
+ | Some true ->
+ if node.Node_light.content = Datas.UnsetData
+ then Logger.debug "DB-LIGHT : (verify fail) path %s data in mtree but not in Dbm file"
+ (Path.to_string path)
+ | Some false ->
+ if node.Node_light.content <> Datas.UnsetData
+ then Logger.debug "DB-LIGHT : (verify fail) path %s data in Dbm file but not in mtree"
+ (Path.to_string path)
+ | None ->
+ Logger.debug "DB-LIGHT : (verify fail) path %s data in Dbm file but node not in mtree"
+ (Path.to_string path)))
else
let path = snd (Encode_light.decode_path pathstr 0) in
let datas = snd (Encode_light.decode_datas datastr 0) in
@@ -251,7 +295,7 @@ let sprintf fmt = Printf.sprintf fmt
| Datas.Data dataImpl -> ignore (Db_light.update_index t.db_ref [(path,dataImpl)])
(* FIXME: Links!!! *)
| _ -> ());
- ignore (Db_light.update t.db_ref path datas))
+ ignore (Db_light.update ~no_write:true t.db_ref path datas))
dbm
| None -> ());
db
@@ -480,6 +524,7 @@ let sprintf fmt = Printf.sprintf fmt
#<If> Logger.info "DB-LIGHT : Failed a commit." #<End>
end;
pop_trans_prepare t;
+ if !(Db_light.verify) then Db_light.verify_database t.db_ref;
success
| None ->
Logger.error "DB-LIGHT : Inconsistent state: it should be locked before commit.";
View
2 database/light/transaction_light.ml
@@ -135,7 +135,7 @@ let stat tr path =
let path, kind =
let rec aux path =
let (node, _) = Db_light.get_node_of_path tr.tr_db path in
- #<If>Logger.log ~color:`green "Transaction_light.stat: path=%s node=%s\n"
+ #<If>Logger.log ~color:`green "Transaction_light.stat: path=%s node=%s"
(Path.to_string path) (Datas.to_string (Node_light.get_content node))#<End>;
match Node_light.get_content node with
| Datas.Data _ -> path, `Data

0 comments on commit a57e447

Please sign in to comment.