Browse files

[feature] Badop_light: First version.

  • Loading branch information...
1 parent 4f62032 commit 7e07d58e89827e70234f3f455bbf702fc87bdc58 @nrs135 nrs135 committed with Louis Gesbert Jun 14, 2011
View
8 database.mllib
@@ -75,3 +75,11 @@ database/db3/structs/SigListMap
database/db3/structs/RaListMap
database/db3/structs/SimpleListMap
database/db3/structs/TabMap
+# Badop light
+database/Badop_light
+database/light/Node_light
+database/light/Session_light
+database/light/Transaction_light
+database/light/Db_light
+database/light/Io_light
+database/light/Encode_light
View
8 database/_tags
@@ -1,16 +1,18 @@
# -*- conf -*- (for emacs)
# subdirs
-<{badop,db3}>: traverse
+<{badop,db3,light}>: traverse
<**/*.{ml,mli,byte,native}>: use_libbase, use_libruntime, use_libnet, use_appruntime, use_libsecurity, use_libtools, use_buildinfos
<gml_parser.{ml,mli,byte,native}>: use_libtrx
+<light/*.{ml,mli,byte,native}>: use_dbm
+
<badop_{protocol,server,client}.ml>: rectypes
-<database_server.{byte,native}>: use_ssl, use_ulex, use_libtrx, thread, use_unix, use_bigarray, use_str, use_zip, use_syslog, use_database
+<database_server.{byte,native}>: use_ssl, use_ulex, use_libtrx, thread, use_unix, use_bigarray, use_str, use_zip, use_dbm, use_database
-<database_tool.{ml,byte,native}>: use_libqmlcompil, use_buildinfos, use_compilerlib, use_passlib, use_database, use_ssl, use_ulex, use_libtrx, thread, use_unix, use_bigarray, use_str, use_zip, use_syslog, use_graph, use_opacapi
+<database_tool.{ml,byte,native}>: use_libqmlcompil, use_buildinfos, use_compilerlib, use_passlib, use_dbm, use_database, use_ssl, use_ulex, use_libtrx, thread, use_unix, use_bigarray, use_str, use_zip, use_syslog, use_graph, use_opacapi
# ppdebug
<*.ml>: with_mlstate_debug
View
5 database/badop.ml
@@ -126,10 +126,15 @@ type local_options =
readonly : bool; (** open the database on readonly mode *)
}
+type light_options =
+ { lpath : string; (** path *)
+ }
+
type options =
| Options_Local of local_options
| Options_Client of Scheduler.t * (Unix.inet_addr * int) * (unit -> [ `retry of Time.t | `abort ])
(** scheduler, server, on_disconnect *)
+ | Options_Light of light_options
| Options_Debug of string * options (** debug line prefix, backend options *)
| Options_Dispatcher of int * options list (** flat-replication factor, backends options *)
View
2 database/badop/badop_structure.ml
@@ -131,7 +131,7 @@ module Node_property = struct
| ConflictOnWrite -> "Conflict on write"
| TakeLast -> "Take last"
| TakeMin -> "Take min"
- | TakeMax -> "Take min"
+ | TakeMax -> "Take max"
| Add -> "Add"
let node_config nc =
View
159 database/badop_light.ml
@@ -0,0 +1,159 @@
+(*
+ 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/>.
+*)
+
+module D = Badop_lib
+module Node_property = Badop_structure.Node_property
+
+type 'a answer = [ `Answer of 'a | `Absent | `Linkto of Badop.path ]
+(** This module provides a simple db, no specific results to handle *)
+
+type database = { session: Session_light.t; file: string; mutable node_config : Node_property.config }
+type transaction = { db: database; tr: Transaction_light.t }
+
+let (|>) x f = f x
+
+let open_database options k =
+ let options =
+ match options with
+ | Badop.Options_Light options -> options
+ | _ -> assert false in
+ let open_db p =
+ Session_light.open_db p
+ in
+ let path = options.Badop.lpath in
+ open_db path |> fun (db,_) -> { session = db; file = path; node_config = [] } |> k
+
+let close_database db k =
+ Session_light.close_db db.session |> k
+
+let status db k = Badop.Local db.file |> k
+
+module Tr = struct
+ let start db k =
+ { db = db; tr = Session_light.new_trans db.session } |> k
+
+ let start_at_revision db _rev k =
+ { db = db; tr = Session_light.new_trans (*~read_only:(true, Some rev)*) db.session } |> k
+
+ let prepare trans k =
+ (* Executes [k] as soon as prepare finished, asynchronously, nonblocking.
+ When prepare is postponed and stored on the FIFO,
+ the continuation is stored as well. The exceptions from [k]
+ are never caught here. *)
+ if Transaction_light.modified trans.tr then
+ Session_light.try_trans_prepare trans.db.session trans.tr
+ (fun (tr, b) -> ({db = trans.db; tr = tr}, b) |> k)
+ else
+ (* Non-modifying trans, so nothing to do; commit will be void, too. *)
+ ({db = trans.db; tr = trans.tr}, true) |> k
+
+ let commit trans k =
+ if Transaction_light.modified trans.tr then
+ (* Assumption: [trans] is prepared by [execute_trans_prepare].
+ Here some continuations of [prepare] may be executed, but only in case
+ when some transactions are on the FIFO and are being prepared
+ after the actual commit is completed. *)
+ Session_light.really_commit trans.db.session trans.tr |> k
+ else
+ true |> k
+
+ let abort trans k = Session_light.abort_or_rollback trans.db.session trans.tr |> k
+end
+
+type revision = Revision.t
+
+(** All the operations that query the db *)
+type 'which read_op = ('which,revision) Badop.generic_read_op
+
+let read trans path op k = match op with
+ | Badop.Stat (D.Query () as q) ->
+ (try `Answer (Badop.Stat (D.Dialog_aux.respond q (Session_light.stat trans.tr path)))
+ with Db_light.UnqualifiedPath -> `Absent) |> k
+ | Badop.Contents (D.Query () as q) ->
+ (try `Answer (Badop.Contents (D.Dialog_aux.respond q (Session_light.get trans.db.session trans.tr path)))
+ with Db_light.UnqualifiedPath -> `Absent) |> k
+ | Badop.Children (D.Query range as q) ->
+ (try
+ `Answer
+ (Badop.Children
+ (D.Dialog_aux.respond q
+ (Session_light.get_children trans.db.session trans.tr range path)))
+ with Db_light.UnqualifiedPath -> `Absent) |> k
+ | Badop.Revisions (D.Query _range as q) ->
+ (try
+ `Answer
+ (Badop.Revisions
+ (D.Dialog_aux.respond q
+ ((* current revision *)
+ [Session_light.get_rev trans.db.session]
+ |> List.map (fun rev -> rev, Session_light.get_timestamp trans.db.session))))
+ with Db_light.UnqualifiedPath -> `Absent) |> k
+ | Badop.Search (D.Query (words, _range_FIXME) as q) ->
+ (try
+ `Answer
+ (Badop.Search
+ (D.Dialog_aux.respond q
+ (Session_light.full_search trans.tr words path)))
+ (* FIXME: limit number of results *)
+ with Db_light.UnqualifiedPath -> `Absent) |> k
+ | _ -> assert false (* _ (Response _) can't happen (ensured by typing) *)
+
+(** All the operations that write to the db *)
+type 'which write_op = ('which,transaction,revision) Badop.generic_write_op
+
+let write trans path op k = match op with
+ | Badop.Set (D.Query data as q) ->
+ Badop.Set (D.Dialog_aux.respond q { trans with tr = Session_light.set trans.tr path data }) |> k
+ | Badop.Clear (D.Query () as q) ->
+ Badop.Clear
+ (D.Dialog_aux.respond q
+ (try
+ { trans with tr = Session_light.remove trans.tr path }
+ with Db_light.UnqualifiedPath -> trans)) |> k
+ | Badop.Link (D.Query linkpath as q) ->
+ Badop.Link
+ (D.Dialog_aux.respond q
+ { trans with tr = Session_light.set_link trans.tr path linkpath }) |> k
+ | Badop.Copy (D.Query (copypath,copyrev) as q) ->
+ Badop.Copy
+ (D.Dialog_aux.respond q
+ { trans with tr = Session_light.set_copy trans.db.session trans.tr path (copypath, copyrev) }) |> k
+ | _ -> assert false (* _ (Response _) can't happen (ensured by typing) *)
+
+let write_list trans path_op_list k =
+ let wr trans (path, op) k =
+ write trans path op (fun resp -> Badop.Aux.result_transaction resp |> k)
+ in
+ Cps.List.fold wr trans path_op_list k
+
+let node_properties db config k =
+ (match db.node_config with
+ | [] ->
+ (*#<If:BADOP_DEBUG$minlevel 10>
+ Printf.printf "Set node config\n%s\n%!" (Node_property.StringOf.config config) #<End>;*)
+ db.node_config <- config
+ | nc ->
+ if nc <> config then
+ ((*#<If:BADOP_DEBUG$minlevel 5> Printf.eprintf "Try to set another config, refuse\n%!" #<End>;*)
+ failwith "Badop local: Invalid config"));
+ () |> k
+
+module Debug = struct
+ let revision_to_string = Revision.to_string
+ let path_to_string = Path.to_string
+end
View
34 database/badop_meta.ml
@@ -41,6 +41,10 @@ let default_local_options =
dot = false;
readonly = false;
}
+let default_light_options =
+ { Badop.
+ lpath = default_file ~name:"db_light" ();
+ }
let default =
(module Badop_local : Badop.S), (Badop.Options_Local default_local_options)
@@ -54,6 +58,10 @@ let get_local_options = function
| Badop.Options_Local o -> o
| _ -> raise Not_found
+let get_light_options = function
+ | Badop.Options_Light o -> o
+ | _ -> raise Not_found
+
let consume_option name =
let rec aux acc lst =
@@ -141,6 +149,32 @@ let options_parser_with_default ?name (_default_m, default_o) =
"Use a local database at given path%s. Use additional flag 'restore' to try and recover a corrupted database, \
or 'dot' to have a database dot output each commit. You can specify several flags, separated by ','." default_str)
;
+ ["--db-light"],
+ A.func (A.option A.string)
+ (fun (_,o) str_opt ->
+ if o <> default_o
+ then prerr_endline ("Warning: database options before --db-light will be ignored"^spec_msg);
+ let path,_flags = match str_opt with
+ | Some str -> Base.String.split_char_last ':' str
+ | None -> "", ""
+ in
+ let path = match path with
+ | "" ->
+ (match o with Badop.Options_Light({ Badop.lpath = path; _ }) -> path | _ -> default_file ?name ())
+ | p -> (match name with None -> p | Some n -> Filename.concat p n)
+ in
+ let lpath = path^"_light" in
+ Logger.log ~color:`red "path: %s" path;
+ (module Badop_light : Badop.S),
+ Badop.Options_Light { Badop. lpath }),
+ "[<path>][:<flags>]",
+ (let default_str = match default_o with
+ | Badop.Options_Light({ Badop.lpath = lpath }) ->
+ Printf.sprintf " (default: %s_light)" lpath
+ | _ -> ""
+ in
+ Printf.sprintf
+ "Use a light database at given path.%s"
]
@
#<If:BADOP_DEBUG> [
View
581 database/light/db_light.ml
@@ -0,0 +1,581 @@
+(*
+ 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/>.
+*)
+#<Debugvar:DEBUG_DB>
+
+(* depends *)
+module List = BaseList
+module String = BaseString
+let sprintf fmt = Printf.sprintf fmt
+let printf fmt = Printf.printf fmt
+let rev = Revision.make 0
+
+(* -- *)
+
+(* Exceptions *)
+
+exception UnqualifiedPath
+exception Merge
+
+(* Datatypes *)
+
+type index = ((Path.t * float) list) StringMap.t
+
+type tree = {
+ sts : (Keys.t, tree) Hashtbl.t;
+ uid : Uid.t;
+ key : Keys.t;
+ mutable node : Node_light.t;
+ mutable up : tree ref;
+}
+
+type t = {
+ mutable version : string;
+ mutable tcount : Eid.t ;
+ mutable next_uid : Uid.t;
+ mutable index : index;
+ tree : tree;
+}
+
+(* Constructors *)
+
+let make_node t key data =
+ t.next_uid <- Uid.succ t.next_uid;
+ let tree = { sts = Hashtbl.create 10;
+ uid = t.next_uid;
+ key = key;
+ node = Node_light.create ~content:data ();
+ up = ref (Obj.magic 0);
+ } in
+ tree.up := tree;
+ tree
+
+let make_t () =
+ let t = { version = "<new>";
+ tcount = Eid.make 0;
+ next_uid = Uid.make 0;
+ tree = { sts = Hashtbl.create 10;
+ uid = Uid.make 0;
+ key = Keys.StringKey "";
+ node = Node_light.create ();
+ up = ref (Obj.magic 0) };
+ index = StringMap.empty;
+ } in
+ t.tree.up := t.tree;
+ t
+
+let sts_of_list l =
+ let ht = Hashtbl.create 10 in
+ List.iter (fun (k,v) -> Hashtbl.add ht k v) l;
+ ht
+
+(* Basic database operations *)
+
+let set_version t version = t.version <- version
+
+let update_data tree data =
+ let old_data = tree.node.Node_light.content in
+ (match tree.node.Node_light.content, data with
+ | Datas.UnsetData, Datas.UnsetData -> ()
+ | _, Datas.UnsetData -> ()
+ | Datas.UnsetData, _ -> tree.node.Node_light.content <- data
+ | _, _ -> tree.node.Node_light.content <- data);
+ #<If$minlevel 3>Logger.log ~color:`cyan "update_data: data=%s old_data=%s new_data=%s"
+ (Datas.to_string data)
+ (Datas.to_string old_data)
+ (Datas.to_string tree.node.Node_light.content)#<End>
+
+let add_tree t path data =
+ #<If>Logger.log ~color:`cyan "add_tree: path=%s data=%s" (Path.to_string path) (Datas.to_string data)#<End>;
+ let rec aux pt tree = function
+ | [] ->
+ tree.up := pt;
+ update_data tree data
+ | k::rest ->
+ (try
+ let st = Hashtbl.find tree.sts k in
+ aux tree st rest
+ with Not_found ->
+ let st = make_node t k Datas.UnsetData in
+ st.up <- ref tree;
+ Hashtbl.add tree.sts k st;
+ aux tree st rest)
+ in
+ aux t.tree t.tree (Path.to_list path);
+ t.tcount <- Eid.succ t.tcount
+
+let remove_tree t path =
+ #<If>Logger.log ~color:`cyan "remove_tree: path=%s" (Path.to_string path)#<End>;
+ let rec aux tree = function
+ | [] -> false
+ | [k] ->
+ (try
+ let st = Hashtbl.find tree.sts k in
+ if Hashtbl.length st.sts = 0
+ then (#<If$minlevel 2>
+ Logger.log ~color:`cyan "remove_tree(rmv): path=%s data=%s"
+ (Path.to_string path) (Datas.to_string st.node.Node_light.content)#<End>;
+ Hashtbl.remove tree.sts k)
+ else (#<If$minlevel 2>
+ Logger.log ~color:`cyan "remove_tree(set): path=%s data=%s"
+ (Path.to_string path) (Datas.to_string st.node.Node_light.content)#<End>;
+ st.node.Node_light.content <- Datas.UnsetData);
+ true
+ with Not_found -> false)
+ | k::rest ->
+ (try
+ let st = Hashtbl.find tree.sts k in
+ let removed = aux st rest in
+ if removed && Hashtbl.length st.sts = 0 && st.node.Node_light.content = Datas.UnsetData then Hashtbl.remove tree.sts k;
+ removed
+ with Not_found -> false)
+ in
+ let removed = aux t.tree (Path.to_list path) in
+ (match removed, Eid.pred t.tcount with
+ | true, Some eid -> t.tcount <- eid
+ | _, _ -> ());
+ removed
+
+(* Node-level navigation:
+ Note that we can't export this yet because the Badop.S sig doesn't support this.
+*)
+
+exception At_root
+exception At_leaf
+
+let node_uid node = node.uid
+let node_key node = node.key
+let node_node node = node.node
+let node_up node = !(node.up)
+
+let node_is_root node = !(node.up) == node
+
+let node_is_leaf node = Hashtbl.length node.sts = 0
+
+let up_node node = if node_is_root node then raise At_root else !(node.up)
+
+let up_node_n node n =
+ let rec aux tree = function
+ | 0 -> tree
+ | n -> aux (up_node tree) (n-1)
+ in
+ aux node n
+
+let up_node_opt node = try Some (up_node node) with At_root -> None
+
+let down_path tree path =
+ let rec aux tree = function
+ | [] -> tree
+ | k::rest -> aux (Hashtbl.find tree.sts k) rest
+ in
+ aux tree (Path.to_list path)
+
+let down_node node key = if node_is_leaf node then raise At_leaf else Hashtbl.find node.sts key
+
+let down_node_opt node key = try Some (down_node node key) with | Not_found -> None | At_leaf -> None
+
+let find_node t path = down_path t.tree path
+
+let find_node_opt t path = try Some (find_node t path) with Not_found -> None
+
+let find_data t path = (down_path t.tree path).node.Node_light.content
+
+let find_data_opt t path = try Some (find_data t path) with Not_found -> None
+
+let path_from_node node =
+ let rec aux node l =
+ if node_is_root node
+ then Path.of_list (List.rev l)
+ else aux !(node.up) (node.key::l)
+ in
+ aux node []
+
+let string_of_node { sts=_; uid; key; node; up } =
+ sprintf "%d(^%d): %s -> %s"
+ (Uid.value uid) (Uid.value ((!up).uid)) (Keys.to_string key) (Datas.to_string node.Node_light.content)
+
+let rec string_of_tree0 indent node =
+ let s = sprintf "%s%s\n" indent (string_of_node node) in
+ Hashtbl.fold
+ (fun k v acc ->
+ 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);;
+
+(* the root of the database *)
+let root_eid = Eid.make 0
+let start = root_eid
+
+
+ (******************)
+ (* screen display *)
+ (******************)
+
+ let print_index db =
+ let index = db.index in
+ if StringMap.is_empty index then "Empty"
+ else
+ StringMap.fold (fun name path_list acc ->
+ sprintf "%s%s : %s\n" acc name
+ (Base.List.to_string (fun (p, _) -> sprintf "%s " (Path.to_string p))
+ path_list))
+ index ""
+
+ let print_db db =
+ let tcount = sprintf "tcount = %s" (Eid.to_string db.tcount) in
+ let next_uid = sprintf "next_uid = %s" (Uid.to_string db.next_uid) in
+ let index = sprintf "index = %s" (print_index db) in
+ sprintf "db : \n%s\n%s\n%s\n%s" tcount next_uid index (string_of_tree db.tree)
+
+
+ (**********************)
+ (* db fields accessors*)
+ (**********************)
+
+ let get_rev _db = Revision.make 0
+ let get_tcount db = db.tcount
+ let get_next_uid db = db.next_uid
+ let is_empty db = (Eid.value db.tcount = 0)
+
+ let get_index db = db.index
+
+
+ (*****************************)
+ (* navigation through the db *)
+ (*****************************)
+
+ let get_tree_of_path db path =
+ try find_node db path
+ with Not_found -> raise UnqualifiedPath
+
+ let get_node_of_path db path =
+ try ((find_node db path).node,rev)
+ with Not_found -> raise UnqualifiedPath
+
+ (************************************)
+ (* database creation and rebuilding *)
+ (************************************)
+
+ let make = make_t
+
+ let set_rev db _rev = db
+
+ (******************)
+ (* basic DB reads *)
+ (******************)
+
+ (* may raise UnqualifiedPath *)
+ let rec get db path =
+ Logger.info "Db_light.get: path=%s%!" (Path.to_string path);
+ let node, _rev = get_node_of_path db path in
+ match Node_light.get_content node with
+ | Datas.Data d -> d
+ | Datas.Link l
+ | Datas.Copy (None, l) -> get db l
+ | Datas.Copy (Some _, p) -> get db p
+ | Datas.UnsetData -> DataImpl.empty
+
+ let get_data (db:t) node =
+ let _ = db in
+ match Node_light.get_content node with
+ | Datas.Data d -> d
+ | Datas.UnsetData -> DataImpl.empty
+ | _ -> assert false
+
+ let in_range (start_opt, len) key (pllen:int) =
+ let res =
+ (len == 0 || abs len > pllen) &&
+ (match start_opt with
+ | Some start ->
+ if len < 0
+ then ((*printf "%s <= %s -> %b\n%!" (Keys.to_string start) (Keys.to_string key) (Keys.compare start key <= 0);*)
+ Keys.compare start key <= 0)
+ else ((*printf "%s >= %s -> %b\n%!" (Keys.to_string start) (Keys.to_string key) (Keys.compare start key >= 0);*)
+ Keys.compare start key >= 0)
+ | None -> true)
+ in
+ (*printf "in_range: key=%s pllen=%d res=%b\n%!" (Keys.to_string key) pllen res;*)
+ res
+
+ let get_ch db tree range_opt path max_depth allow_empty =
+ let range = match range_opt with Some range -> range | None -> (None,0) in
+ let rec aux tree path len start depth =
+ (*printf "get_ch: path=%s len=%d\n%!" (Path.to_string path) len;*)
+ let inrange, tree, start =
+ if Path.to_list path = []
+ then (true, db.tree, ([], len))
+ else (in_range range (Path.last path) len, tree, start)
+ in
+ if inrange
+ then
+ Hashtbl.fold
+ (fun key sn (pl,pllen) ->
+ let spath = Path.add path key in
+ let start = if allow_empty || Node_light.is_occupied sn.node then ([spath],pllen+1) else ([],pllen) in
+ let spl,spllen =
+ if depth < max_depth
+ then aux sn spath pllen start (depth+1)
+ else ([],pllen)
+ in
+ (pl@spl,spllen)) tree.sts start
+ else
+ ([],len)
+ in
+ aux tree path 0 ([],0) 0
+
+ (* may raise UnqualifiedPath *)
+ let rec get_children db range_opt path =
+ let tree = get_tree_of_path db path in
+ match Node_light.get_content tree.node with
+ | Datas.Link p
+ | Datas.Copy (_, p) -> get_children db range_opt p
+ | _ -> fst (get_ch db tree range_opt path 1 true)
+
+
+ (********************)
+ (* basics DB writes *)
+ (********************)
+
+ let update db path data = add_tree db path data; db
+
+ let remove db path = ignore (remove_tree db path); db
+
+ (* index management *)
+
+ let update_index db update_list =
+ #<If$minlevel 3>
+ Logger.log ~color:`cyan
+ "update_index: [%s]"
+ (String.concat_map "; "
+ (fun (p,d) -> sprintf "(%s,%s)" (Path.to_string p) (DataImpl.to_string d)) update_list)
+ #<End>;
+ let new_index =
+ List.fold_left
+ (fun acc (path, data) ->
+ let map = DataImpl.index_fun data in
+ let count = StringMap.fold (fun _k v acc -> acc + v) map 0 in
+ StringMap.fold
+ (fun name score acc ->
+ let score = (float_of_int score) /. (float_of_int count) in
+ let new_path_list =
+ match StringMap.find_opt name acc with
+ | Some pl -> (path, score) :: pl
+ | None -> [path, score]
+ in
+ StringMap.add name new_path_list acc
+ ) map acc
+ ) db.index update_list
+ in
+ {db with index = new_index}
+
+ let remove_from_index db remove_list =
+ #<If$minlevel 3>
+ Logger.log ~color:`cyan
+ "remove_from_index: [%s]"
+ (String.concat_map "; "
+ (fun (p,d) -> sprintf "(%s,%s)" (Path.to_string p) (DataImpl.to_string d)) remove_list)
+ #<End>;
+ let new_index =
+ List.fold_left
+ (fun index (path, data) ->
+ let map = DataImpl.index_fun data in
+ StringMap.fold
+ (fun str _ index ->
+ let new_list =
+ match StringMap.find_opt str index with
+ | Some l -> List.remove_assoc path l
+ | None -> []
+ in
+ match new_list with
+ | [] -> StringMap.remove str index
+ | _ -> StringMap.add str new_list index
+ ) map index
+ ) db.index remove_list
+ in
+ {db with index = new_index}
+
+
+
+ (******************************************************)
+ (* full search managment (only for current revision) *)
+ (******************************************************)
+
+ (** Takes a list of decreasing-relevance lists of results; merges them to turn
+ individual searches to an AND search, ordered by decreasing minimal
+ rank. Lists should not contain duplicates. *)
+ let merge_search_results ll =
+ let n = List.length ll in
+ let occur = Hashtbl.create 23 in
+ (* table from key to number of occurences. When that number equals n, we got a result *)
+ let results = ref [] in
+ let add key =
+ let nb_occur = try Hashtbl.find occur key + 1 with Not_found -> 1 in
+ if nb_occur < n then Hashtbl.replace occur key nb_occur else
+ (results := key::!results; Hashtbl.remove occur key)
+ in
+ let rec aux ll =
+ let nempty, ll = Base.List.fold_left_map
+ (fun nempty -> function key::r -> add key; nempty, r | [] -> nempty+1, [])
+ 0 ll in
+ if nempty < n then aux ll
+ in
+ aux ll;
+ List.rev !results
+
+ let full_search db words path =
+ let (|>) a f = f a in
+ let results =
+ Base.List.filter_map
+ (fun word ->
+ StringMap.find_opt word db.index
+ |> Option.map
+ (Base.List.filter_map
+ (fun (p,r) -> Path.remaining path p |> Option.map (fun p -> List.hd p, r))))
+ words
+ in
+ let results =
+ List.tail_map
+ (fun l -> l
+ |> List.sort
+ (fun (k1, r1) (k2, r2) -> let c = Pervasives.compare r1 r2 in if c <> 0 then - c else - Keys.compare k1 k2)
+ |> List.tail_map fst
+ |> Base.List.uniq)
+ results
+ in
+ merge_search_results results
+
+
+ (* Links *)
+
+ let set_link db path link =
+ let node = get_tree_of_path db path in
+ node.node.Node_light.content <- Datas.Link link;
+ db
+
+ (* Copies *)
+
+ (* Just behave like links for now... *)
+ let set_copy db path link =
+ let tree = get_tree_of_path db path in
+ (*let copy = get_tree_of_path db link in
+ tree.node.Node_light.content <- Node_light.get_content copy.node;*)
+ tree.node.Node_light.content <- Datas.Copy (Some rev, link);
+ 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>;*)
+ match path_end with
+ | [] -> ([], node)
+ | k :: rest ->
+ try
+ match Node_light.get_content node.node with
+ | Datas.Link _
+ | Datas.Copy _ -> (path_end, node)
+ | _ ->
+ let node = Hashtbl.find node.sts k in
+ follow_path db node rest
+ with Not_found -> raise UnqualifiedPath
+
+ let follow_link db path =
+ Logger.info "Db_light.follow_link: path=%s" (Path.to_string path);
+ 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
+ match Node_light.get_content node.node with
+ | Datas.Link l ->
+ (* Links possible both on [l] and [path_end], hence the [concat]. *)
+ let new_path = Path.concat l (Path.of_list path_end) in
+ aux db new_path
+ | Datas.Copy (_, l) ->
+ let new_path = Path.concat l (Path.of_list path_end) in
+ aux db new_path
+ | _ ->
+ assert (path_end = []);
+ (path, node)
+ in
+ aux db path
+
+(*end*)
+
+(*
+let tt_ref = ref (make_t ())
+
+let _ =
+ let tt = make_t () in
+ let _K_a = Keys.StringKey "a" in
+ let _K_b = Keys.StringKey "b" in
+ let _K_c = Keys.StringKey "c" in
+ let _K_d = Keys.StringKey "d" in
+ let _K_e = Keys.StringKey "e" in
+ let _K_f = Keys.StringKey "f" in
+ let _K_x = Keys.StringKey "x" in
+ let _K_y = Keys.StringKey "y" in
+ let _K_z = Keys.StringKey "z" in
+ let a = Path.of_list [_K_a] in
+ let ab = Path.of_list [_K_a; _K_b] in
+ let abc = Path.of_list [_K_a; _K_b; _K_c] in
+ let abd = Path.of_list [_K_a; _K_b; _K_d] in
+ let def = Path.of_list [_K_d; _K_e; _K_f] in
+ let xyz = Path.of_list [_K_x; _K_y; _K_z] in
+ add_tree tt abc (Datas.Data (DataImpl.Int 123));
+ print_t tt;
+ add_tree tt abd (Datas.Data (DataImpl.Int 124));
+ print_t tt;
+ add_tree tt a (Datas.Data (DataImpl.Int 1));
+ print_t tt;
+ add_tree tt def (Datas.Data (DataImpl.Int 456));
+ tt_ref := tt;
+ print_t tt;
+ printf "get_eid(tt)=%d\n" (Eid.value tt.tcount);
+ printf "find_data(abc)=%s\n" (Option.to_string Datas.to_string (find_data_opt tt abc));
+ printf "find_node(abc)=%s\n" (Option.to_string (fun tree -> Uid.to_string tree.uid) (find_node_opt tt abc));
+ printf "node_is_root(tt.tree)=%b\n" (node_is_root tt.tree);
+ printf "node_is_root(find_node(abc))=%b\n" (node_is_root (Option.get (find_node_opt tt abc)));
+ let node_ab = find_node_opt tt ab in
+ printf "node_ab=%s\n" (Option.to_string string_of_node node_ab);
+ printf "down_node(node_ab,\"c\")=%s\n" (Option.to_string string_of_node (down_node_opt (Option.get node_ab) _K_c));
+ printf "up_node(node_ab)=%s\n" (Option.to_string string_of_node (up_node_opt (Option.get node_ab)));
+ printf "up_node(tt.tree)=%s\n" (Option.to_string string_of_node (up_node_opt tt.tree));
+ printf "find_data(abd)=%s\n" (Option.to_string Datas.to_string (find_data_opt tt abd));
+ printf "find_data(a)=%s\n" (Option.to_string Datas.to_string (find_data_opt tt a));
+ printf "find_data(def)=%s\n" (Option.to_string Datas.to_string (find_data_opt tt def));
+ printf "find_data(xyz)=%s\n" (Option.to_string Datas.to_string (find_data_opt tt xyz));
+ printf "get_children(root)=[%s]\n"
+ (List.to_string (fun p -> Path.to_string p^"; ") (get_children tt (Some (None,0)) (Path.of_list [])));
+ printf "get_children(a)=[%s]\n"
+ (List.to_string (fun p -> Path.to_string p^"; ") (get_children tt (Some (None,0)) a));
+ printf "get_children(a,<=c)=[%s]\n"
+ (List.to_string (fun p -> Path.to_string p^"; ") (get_children tt (Some (Some _K_c,0)) a));
+ printf "get_children(a,3)=[%s]\n"
+ (List.to_string (fun p -> Path.to_string p^"; ") (get_children tt (Some (None,3)) a));
+ printf "get_children(ab,>=b)=[%s]\n"
+ (List.to_string (fun p -> Path.to_string p^"; ") (get_children tt (Some (Some _K_b,-3)) ab));
+ ignore (remove_tree tt abc);
+ print_t tt;
+ ignore (remove_tree tt abd);
+ print_t tt;
+ ignore (remove_tree tt a);
+ print_t tt;
+ ignore (remove_tree tt def);
+ print_t tt
+*)
+
View
135 database/light/db_light.mli
@@ -0,0 +1,135 @@
+(*
+ 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/>.
+*)
+exception UnqualifiedPath
+exception Merge
+
+type t
+type tree
+(*type node_map*)
+type index = ((Path.t * float) list) StringMap.t
+
+(* access to node *)
+val node_uid : tree -> Uid.t
+val node_key : tree -> Keys.t
+val node_node : tree -> Node_light.t
+val node_up : tree -> tree
+
+(* screen printting - debug only *)
+val print_db : t -> string
+
+(* the root of the database *)
+val root_eid:Eid.t
+
+(* access to the db field *)
+val get_rev : t -> Revision.t
+val get_tcount : t -> Eid.t
+val get_next_uid : t -> Uid.t
+val is_empty : t -> bool
+(*val get_uid_map : t -> Uid.t RevisionMap.t EidMap.t
+val get_node_map : t -> node_map
+val get_noweak_node_map : t -> Node.t UidMap.t
+val get_last_nodes : t -> Node.t UidMap.t*)
+val get_index : t -> index
+
+val set_version : t -> string -> unit
+
+(* navigation through the db *)
+(*val get_uid_of_eid : t -> Revision.t -> Eid.t -> Uid.t
+val get_node_of_uid : t -> Uid.t -> Node_light.t*)
+val get_node_of_path : t -> (*Revision.t ->*) Path.t -> Node_light.t * Revision.t
+(*val get_node_of_eid : t -> Revision.t -> Eid.t -> Node_light.t
+val get_eid_of_path : t -> Revision.t -> Path.t -> Eid.t * Revision.t
+val is_new_uid : t -> Uid.t -> bool*)
+val get_tree_of_path : t -> Path.t -> tree
+
+(* cleaning *)
+(*val clean_tmp_maps : t -> t*)
+
+(* creation / rebuilding of a database *)
+(*val make_node_map_from_weak : (Uid.t, Node_light.t) WeakCacheMap.t -> node_map
+val make_node_map_from_uidmap : Node_light.t UidMap.t -> node_map*)
+val make : (*?weak:(Uid.t -> Node_light.t) ->*) unit -> t
+(*val restart :
+ ?index:index ->
+ Revision.t -> Eid.t -> Uid.t ->
+ (Uid.t RevisionMap.t EidMap.t) ->
+ node_map ->
+ t*)
+
+(* basic db writing *)
+(*val update_db : t -> Revision.t -> (Eid.t * Uid.t) list -> (Uid.t * Node_light.t) list -> t*)
+val update : t -> Path.t -> Datas.t -> t
+val remove : t -> Path.t -> t
+val set_rev : t -> Revision.t -> t
+
+(* basic db reading *)
+val get : t -> (*Revision.t ->*) Path.t -> DataImpl.t
+val get_data : t -> Node_light.t -> DataImpl.t
+(*val get_children :
+ t -> Revision.t -> (Keys.t option * int) option
+ -> Path.t -> (Path.t * Revision.t) list
+*)
+val get_children : t -> (Keys.t option * int) option -> Path.t -> Path.t list
+(*
+val get_descendants : t -> Path.t -> (Path.t * DataImpl.t) list
+val get_all_rev_of_path : t -> Path.t -> Revision.t list
+val get_last_rev_of_path : t -> Revision.t -> Path.t -> Revision.t*)
+(* Index management *)
+val update_index : t -> (Path.t * DataImpl.t) list -> t
+val remove_from_index : t -> (Path.t * DataImpl.t) list -> t
+val full_search : t -> string list -> Path.t -> Keys.t list
+
+(* Links *)
+val set_link : t -> Path.t -> Path.t -> t
+
+(* Copies *)
+val set_copy : t -> Path.t -> Path.t -> t
+
+(** [follow_path db rev node path_end] follows a path until copy or link
+ is encountered, if any.
+
+ @param db the database to inspect
+ @param rev everything will be read in this revision
+ @param node the node to start traversing at
+ @param path_end the path to walk along (as a [Keys.t list])
+
+ @return The node at which a copy or link was encountered
+ and the remaining suffix of the path.
+*)
+val follow_path :
+ (*t -> Revision.t -> Node_light.t -> Keys.t list -> Keys.t list * Node_light.t*)
+ t -> tree -> Keys.t list -> Keys.t list * tree
+
+(*
+(** [follow_link db original_rev path] returns unwound path as it was
+ at db revision [original_rev]. The result is independent on any
+ changes to the databse after [original_rev]. There is no escape
+ to the current revision via links (as would be the case if
+ the old revision came from a Copy node). If there is escape via link,
+ it's to [original_rev]. All copies are followed, just as links are.
+
+ @param db the database to inspect
+ @param original_rev everything will be read in this revision
+ @param path the path to traverse and unwind from root to the end
+
+ @return The path unwound at [original_rev].
+*)
+val follow_link : t -> Revision.t -> Path.t -> Path.t * Node_light.t
+*)
+
+val follow_link : t -> Path.t -> Path.t * tree
View
271 database/light/encode_light.ml
@@ -0,0 +1,271 @@
+(*
+ 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/>.
+*)
+(* Encode_light:
+ Slightly faster and slightly more compact than Marshal but without sharing.
+*)
+
+module String = Base.String
+let sprintf = Printf.sprintf
+
+let ei8 i =
+ let s = String.create 1 in
+ s.[0] <- Char.chr (i land 0xff);
+ s
+
+let ei16 i =
+ let s = String.create 2 in
+ s.[0] <- Char.chr ((i lsr 8 ) land 0xff);
+ s.[1] <- Char.chr (i land 0xff);
+ s
+
+let ei32 i =
+ let s = String.create 4 in
+ s.[0] <- Char.chr ((i lsr 24) land 0xff);
+ s.[1] <- Char.chr ((i lsr 16) land 0xff);
+ s.[2] <- Char.chr ((i lsr 8 ) land 0xff);
+ s.[3] <- Char.chr (i land 0xff);
+ s
+
+let ei64 i =
+ let s = String.create 8 in
+ s.[0] <- Char.chr ((i lsr 56) land 0xff);
+ s.[1] <- Char.chr ((i lsr 48) land 0xff);
+ s.[2] <- Char.chr ((i lsr 40) land 0xff);
+ s.[3] <- Char.chr ((i lsr 32) land 0xff);
+ s.[4] <- Char.chr ((i lsr 24) land 0xff);
+ s.[5] <- Char.chr ((i lsr 16) land 0xff);
+ s.[6] <- Char.chr ((i lsr 8 ) land 0xff);
+ s.[7] <- Char.chr (i land 0xff);
+ s
+
+let ef f =
+ let s = String.create 8 in
+ let b = Int64.bits_of_float f in
+ s.[0] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 56) 0xffL));
+ s.[1] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 48) 0xffL));
+ s.[2] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 40) 0xffL));
+ s.[3] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 32) 0xffL));
+ s.[4] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 24) 0xffL));
+ s.[5] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 16) 0xffL));
+ s.[6] <- Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 8 ) 0xffL));
+ s.[7] <- Char.chr (Int64.to_int (Int64.logand ( b ) 0xffL));
+ s
+
+let di8 s i =
+ (((Char.code s.[i]) ) land 0xff)
+
+let di16 s i =
+ (((Char.code s.[i]) lsl 8) land 0xff00) lor
+ (((Char.code s.[i+1]) ) land 0x00ff)
+
+let di32 s i =
+ (((Char.code s.[i]) lsl 24) land 0xff000000) lor
+ (((Char.code s.[i+1]) lsl 16) land 0x00ff0000) lor
+ (((Char.code s.[i+2]) lsl 8) land 0x0000ff00) lor
+ (((Char.code s.[i+3]) ) land 0x000000ff)
+
+let di64 s i =
+ (((Char.code s.[i]) lsl 56) land 0x7f00000000000000) lor
+ (((Char.code s.[i+1]) lsl 48) land 0x00ff000000000000) lor
+ (((Char.code s.[i+2]) lsl 40) land 0x0000ff0000000000) lor
+ (((Char.code s.[i+3]) lsl 32) land 0x000000ff00000000) lor
+ (((Char.code s.[i+4]) lsl 24) land 0x00000000ff000000) lor
+ (((Char.code s.[i+5]) lsl 16) land 0x0000000000ff0000) lor
+ (((Char.code s.[i+6]) lsl 8) land 0x000000000000ff00) lor
+ (((Char.code s.[i+7]) ) land 0x00000000000000ff)
+
+let df s i =
+ Int64.float_of_bits
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i])) 56) 0xff00000000000000L)
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i+1])) 48) 0x00ff000000000000L)
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i+2])) 40) 0x0000ff0000000000L)
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i+3])) 32) 0x000000ff00000000L)
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i+4])) 24) 0x00000000ff000000L)
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i+5])) 16) 0x0000000000ff0000L)
+ (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code s.[i+6])) 8) 0x000000000000ff00L)
+ (Int64.logand ( (Int64.of_int (Char.code s.[i+7])) ) 0x00000000000000ffL))))))))
+
+(*
+let tst8 i = i = di8 (ei8 i) 0
+let tst16 i = i = di16 (ei16 i) 0
+let tst32 i = i = di32 (ei32 i) 0
+let tst64 i = i = di64 (ei64 i) 0
+let tstf f = f = dif (eif f) 0
+*)
+
+let put_len c1 c2 c3 c4 i =
+ if i <= 0xff then sprintf "%c%s" c1 (ei8 i)
+ else if i <= 0xffff then sprintf "%c%s" c2 (ei16 i)
+ else if i <= 0xffffffff then sprintf "%c%s" c3 (ei32 i)
+ else sprintf "%c%s" c4 (ei64 i)
+
+let rec encode_key = function
+ | Keys.IntKey i -> put_len 'i' 'j' 'I' 'J' i
+ | Keys.StringKey s -> (put_len 's' 't' 'S' 'T' (String.length s))^s
+ | Keys.ListKey r -> String.concat_map ~left:(put_len 'l' 'm' 'L' 'M' (Array.length r)) "" encode_key (Array.to_list r)
+ | Keys.VariableKey i -> put_len 'v' 'w' 'V' 'W' i
+
+let get_len c1 c2 c3 c4 s i c =
+ if c = c1
+ then i+2, di8 s (i+1)
+ else if c = c2
+ then i+3, di16 s (i+1)
+ else if c = c3
+ then i+5, di32 s (i+1)
+ else if c = c4
+ then i+9, di64 s (i+1)
+ else assert false
+
+let rec decode_key s i =
+ match s.[i] with
+ | ('i' | 'j' | 'I' | 'J') as c ->
+ let i, num = get_len 'i' 'j' 'I' 'J' s i c in
+ i, Keys.IntKey num
+ | ('s' | 't' | 'S' | 'T') as c ->
+ let i, len = get_len 's' 't' 'S' 'T' s i c in
+ (i+len, Keys.StringKey (String.sub s i len))
+ | ('l' | 'm' | 'L' | 'M') as c ->
+ let i, len = get_len 'l' 'm' 'L' 'M' s i c in
+ let a = Array.make len (Keys.IntKey 0) in
+ let rec aux i j =
+ if j >= len
+ then i, Keys.ListKey a
+ else
+ let i, k = decode_key s i in
+ a.(j) <- k;
+ aux i (j+1)
+ in
+ aux i 0
+ | ('v' | 'w' | 'V' | 'W') as c ->
+ let i, num = get_len 'v' 'w' 'V' 'W' s i c in
+ i, Keys.VariableKey num
+ | _ -> assert false
+
+(*
+let k1 = Keys.IntKey 123
+let k2 = Keys.IntKey 0x100
+let k3 = Keys.IntKey 0x10000
+let k4 = Keys.IntKey 0x100000000
+let k5 = Keys.StringKey "abc"
+let k6 = Keys.StringKey (String.make 256 'x')
+let k7 = Keys.VariableKey 123
+let k8 = Keys.VariableKey 0x100
+let k9 = Keys.VariableKey 0x10000
+let k10 = Keys.VariableKey 0x100000000
+let k11 = Keys.ListKey (Array.of_list [k1;k2;k3;k4;k5;k6;k7;k8;k9;k10])
+let k12 = Keys.ListKey (Array.of_list [k11;k11])
+let tstk k = k = snd (decode_key (encode_key k) 0)
+let allk = [k1;k2;k3;k4;k5;k6;k7;k8;k9;k10;k11;k12]
+let good = List.for_all tstk allk
+*)
+
+let encode_path (path:Path.t) =
+ let kl = Path.to_list path in
+ String.concat_map ~left:(put_len 'p' 'q' 'P' 'Q' (List.length kl)) "" encode_key kl
+
+let decode_path s i =
+ let i, len = get_len 'p' 'q' 'P' 'Q' s i s.[i] in
+ let rec aux i j l =
+ if j >= len
+ then i, Path.of_list (List.rev l)
+ else
+ let i, k = decode_key s i in
+ aux i (j+1) (k::l)
+ in
+ aux i 0 []
+
+(*
+let p1 = Path.of_list [k1;k2]
+let k256 = List.init 256 (fun _ -> k1)
+let tstp kl = let p = Path.of_list kl in p = snd (decode_path (encode_path p) 0)
+let good = List.for_all tstp (List.map (fun x -> [x]) (allk@k256))
+*)
+
+let encode_dataimpl = function
+ | DataImpl.Int i -> put_len 'a' 'd' 'A' 'D' i
+ | DataImpl.Text s -> (put_len 'x' 'y' 'X' 'Y' (String.length s))^s
+ | DataImpl.Binary s -> (put_len 'b' 'c' 'B' 'C' (String.length s))^s
+ | DataImpl.Float f -> sprintf "f%s" (ef f)
+ | DataImpl.Unit -> "u"
+
+let decode_dataimpl s i =
+ match s.[i] with
+ | ('a' | 'd' | 'A' | 'D') as c ->
+ let i, num = get_len 'a' 'd' 'A' 'D' s i c in
+ i, DataImpl.Int num
+ | ('x' | 'y' | 'X' | 'Y') as c ->
+ let i, len = get_len 'x' 'y' 'X' 'Y' s i c in
+ (i+len, DataImpl.Text (String.sub s i len))
+ | ('b' | 'c' | 'B' | 'C') as c ->
+ let i, len = get_len 'b' 'c' 'B' 'C' s i c in
+ (i+len, DataImpl.Binary (String.sub s i len))
+ | 'f' ->
+ let f = df s (i+1) in
+ (i+9, DataImpl.Float f)
+ | 'u' ->
+ (i+1, DataImpl.Unit)
+ | _ -> assert false
+
+(*
+let di1 = DataImpl.Int 123
+let di2 = DataImpl.Int 0x100
+let di3 = DataImpl.Int 0x10000
+let di4 = DataImpl.Int 0x100000000
+let di5 = DataImpl.Text "abc"
+let di6 = DataImpl.Text (String.make 256 'x')
+let di7 = DataImpl.Binary (String.make 10 '\001')
+let di8 = DataImpl.Binary (String.make 256 '\002')
+let di9 = DataImpl.Float 123.456
+let di10 = DataImpl.Float 123.456e10
+let di11 = DataImpl.Float 123.456e-10
+let di11 = DataImpl.Unit
+let alldi = [di1;di2;di3;di4;di5;di6;di7;di8;di9;di10;di11]
+let tstdi di = di = snd (decode_dataimpl (encode_dataimpl di) 0)
+let good = List.for_all tstdi alldi
+*)
+
+(* a b c d f i j l m p q s t v w x y *)
+
+let encode_datas = function
+ | Datas.Data di -> "e"^(encode_dataimpl di)
+ | Datas.Link p -> "n"^(encode_path p)
+ | Datas.Copy (_,p) -> "o"^(encode_path p)
+ | Datas.UnsetData -> "U"
+
+let decode_datas s i =
+ match s.[i] with
+ | 'e' -> let i, di = decode_dataimpl s (i+1) in i, Datas.Data di
+ | 'n' -> let i, p = decode_path s (i+1) in i, Datas.Link p
+ | 'o' -> let i, p = decode_path s (i+1) in i, Datas.Copy (None,p)
+ | 'U' -> i+1, Datas.UnsetData
+ | _ -> assert false
+
+(*
+let d1 = Datas.Data di1
+let d2 = Datas.Data di5
+let d3 = Datas.Link (Path.of_list [k1;k2])
+let d4 = Datas.Copy (None,Path.of_list [k5;k5])
+let d5 = Datas.UnsetData
+let alld = [d1;d2;d3;d4;d5]
+let tstd d = d = snd (decode_datas (encode_datas d) 0)
+let good = List.for_all tstd alld
+let db = Dbm.opendbm ("/home/norman/.mlstate/"^(Filename.basename Sys.argv.(0))^"/db_light") [Dbm.Dbm_rdwr] 0O664;;
+Dbm.iter (fun k d -> print_endline (String.escaped (Printf.sprintf "%s -> %s" k d))) db;;
+Dbm.close db;;
+*)
+
View
246 database/light/io_light.ml
@@ -0,0 +1,246 @@
+(*
+ 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/>.
+*)
+module List = BaseList
+module Hashtbl = BaseHashtbl
+let sprintf fmt = Printf.sprintf fmt
+let fprintf fmt = Printf.fprintf fmt
+
+#<Debugvar:DEBUG_DB>
+
+let version = "0.0"
+
+type mode = Create | Append | ReadOnly
+
+type t = {
+ location : string;
+ mode : mode;
+ mutable dbm : Dbm.t option;
+ mutable link_count : int;
+ mutable has_lock : bool;
+}
+
+let dbtbl = ((Hashtbl.create 10) : (string,t) Hashtbl.t)
+
+let is_open t = Option.is_some t.dbm
+let is_closed t = not (is_open t)
+
+(*
+#use "../db3/stress.ml";;
+let db = ref (None:Backend.database option);;
+open_database options (fun dbdb -> db := (Some dbdb));;
+close_database (Option.get (!db)) nilcont;;
+*)
+
+let really_remove_lock_file t =
+ let lock_file_name = t.location^"_lock" in
+ if Sys.file_exists lock_file_name
+ then (try
+ let ic = open_in lock_file_name in
+ let (pid,hostname) = Scanf.fscanf ic "%d\n%s\n" (fun i s -> (i,s)) in
+ close_in ic;
+ if pid = Unix.getpid() && hostname = Unix.gethostname()
+ then (#<If>Logger.log ~color:`magenta "DB-LIGHT : removing lock file: %s" lock_file_name #<End>;
+ (match t.dbm with
+ | Some dbm ->
+ (try
+ Dbm.remove dbm "lock_pid";
+ Dbm.remove dbm "lock_hostname"
+ with Dbm.Dbm_error "dbm_delete" -> ())
+ | None -> ());
+ t.has_lock <- false;
+ Unix.unlink lock_file_name)
+ with exn ->
+ #<If>Logger.log ~color:`red "DB-LIGHT : Warning exception removing lock file: %s"
+ (Printexc.to_string exn)#<End>)
+ else ()
+
+let close t =
+ #<If>Logger.log ~color:`magenta "Close Dbm %s (lc:%d)" t.location t.link_count#<End>;
+ if t.link_count > 0
+ then (t.link_count <- t.link_count - 1;
+ if t.link_count = 0
+ then (really_remove_lock_file t;
+ ignore (Option.map Dbm.close t.dbm);
+ t.dbm <- None))
+
+let critical_error t errstr =
+ Logger.critical "%s" errstr;
+ really_remove_lock_file t;
+ while t.link_count > 0 do close t done;
+ exit 1
+
+let make_lock_file t =
+ let lock_file_name = t.location^"_lock" in
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : making lock file: %s" lock_file_name #<End>;
+ if Sys.file_exists lock_file_name
+ then critical_error t "DB-LIGHT : Attempt to create existing lock file"
+ else (try
+ let pid = Unix.getpid () in
+ let hostname = Unix.gethostname () in
+ let fd = Unix.openfile lock_file_name [Unix.O_WRONLY; Unix.O_CREAT] File.default_rights in
+ let msg = sprintf "%d\n%s\n" pid hostname in
+ ignore (Unix.write fd msg 0 (String.length msg));
+ Unix.close fd;
+ (match t.dbm with
+ | Some dbm ->
+ Dbm.replace dbm "lock_pid" (string_of_int pid);
+ Dbm.replace dbm "lock_hostname" hostname
+ | None -> ());
+ t.has_lock <- true
+ with exn ->
+ critical_error t (sprintf "DB-LIGHT : Can't create lock file %s" (Printexc.to_string exn)))
+
+let remove_lock_file t =
+ let lock_file_name = t.location^"_lock" in
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : removing lock file: %s" lock_file_name#<End>;
+ if Sys.file_exists lock_file_name
+ then (try
+ (match t.dbm with
+ | None -> ()
+ | Some dbm ->
+ (try
+ Dbm.remove dbm "lock_pid";
+ Dbm.remove dbm "lock_hostname"
+ with Dbm.Dbm_error "dbm_delete" -> ()));
+ Unix.unlink lock_file_name;
+ t.has_lock <- false
+ with exn ->
+ critical_error t (sprintf "DB-LIGHT : Can't remove lock file %s" (Printexc.to_string exn)))
+ else ()
+
+let read_lock_file t =
+ let lock_file_name = t.location^"_lock" in
+ if Sys.file_exists lock_file_name
+ then (try
+ let ic = open_in lock_file_name in
+ let (pid,hostname) = Scanf.fscanf ic "%d\n%s\n" (fun i s -> (i,s)) in
+ close_in ic;
+ Some (hostname,pid)
+ with exn ->
+ (#<If>Logger.log ~color:`red "DB-LIGHT : Warning exception reading lock file: %s"
+ (Printexc.to_string exn)#<End>;
+ None))
+ else None
+
+let check_other_used t =
+ let lock_file_name = t.location^"_lock" in
+ let error () =
+ critical_error t
+ (sprintf "The DB-LIGHT database%s is currently used by anoter application or was not closed properly.\n\
+ If you are sure that no other application is using the db, you can remove file '%s'."
+ (if t.location = "" then "" else " "^t.location) lock_file_name)
+ in
+ if Sys.file_exists lock_file_name then
+ (if Sys.os_type = "Unix" then
+ (match read_lock_file t with
+ | Some (host,pid) ->
+ if host = (Unix.gethostname ()) then
+ (let procfile = sprintf "/proc/%d/status" pid in
+ if not (Sys.file_exists procfile) then
+ (#<If> Logger.log ~color:`yellow "DB-LIGHT : REMOVE lock file %s, process died" lock_file_name #<End>;
+ Sys.remove lock_file_name;
+ make_lock_file t)
+ else error())
+ else error()
+ | None ->
+ Sys.remove lock_file_name;
+ make_lock_file t)
+ else error())
+ else make_lock_file t
+
+let reopen t =
+ match t.dbm with
+ | Some _ ->
+ #<If>Logger.log ~color:`yellow "Reopen: Attempt to re-open already open Dbm file %s" t.location#<End>;
+ t.link_count <- t.link_count + 1
+ | None ->
+ (try
+ check_other_used t;
+ let dir_file = t.location^".dir" in
+ if Sys.file_exists dir_file
+ then (#<If>Logger.log ~color:`magenta "Reopening Dbm file %s" t.location#<End>;
+ t.link_count <- t.link_count + 1;
+ t.dbm <- Some (Dbm.opendbm t.location (match t.mode with
+ | ReadOnly -> [Dbm.Dbm_rdonly]
+ | _ -> [Dbm.Dbm_rdwr]) File.default_rights))
+ else (#<If>Logger.log ~color:`yellow "Reopen: Dbm file has disappeared, recreating %s" t.location#<End>;
+ t.link_count <- t.link_count + 1;
+ t.dbm <- Some (Dbm.opendbm t.location (match t.mode with
+ | ReadOnly -> [Dbm.Dbm_rdonly;Dbm.Dbm_create]
+ | _ -> [Dbm.Dbm_rdwr;Dbm.Dbm_create]) File.default_rights))
+ with exn ->
+ failwith (sprintf "Can't reopen Dbm file %s %s" t.location (Printexc.to_string exn)))
+
+let make mode file =
+ let cfile = File.explicit_path file None in
+ match Hashtbl.find_opt dbtbl cfile with
+ | Some t ->
+ #<If>Logger.log ~color:`magenta "Returning existing Dbm data %s" cfile#<End>;
+ if is_open t
+ then (t.link_count <- t.link_count + 1; t)
+ else (reopen t; t)
+ | None ->
+ let t = { dbm = None; location = cfile; mode = mode; link_count = 0; has_lock = false; } in
+ check_other_used t;
+ let dir_file = cfile^".dir" in
+ let pag_file = cfile^".pag" in
+ let dbm =
+ try
+ (match mode with
+ | Create ->
+ if Sys.file_exists dir_file
+ then (#<If>Logger.log ~color:`yellow "New db, purge: deleting file %s" dir_file#<End>;
+ (try Sys.remove dir_file
+ with exn -> #<If>Logger.log ~color:`yellow "Error deleting file %s %s"
+ dir_file (Printexc.to_string exn)#<End>; ());
+ (try Sys.remove pag_file
+ with exn -> #<If>Logger.log ~color:`yellow "Error deleting file %s %s"
+ pag_file (Printexc.to_string exn) #<End>; ()));
+ #<If>Logger.log ~color:`magenta "Opened new Dbm file %s" dir_file#<End>;
+ let dbm = Dbm.opendbm cfile [Dbm.Dbm_rdwr;Dbm.Dbm_create] File.default_rights in
+ Dbm.add dbm "version" version;
+ Dbm.add dbm "timestamp" (Date.rfc1123 (Time.localtime (Time.now())));
+ dbm
+ | Append ->
+ #<If>Logger.log ~color:`magenta "Opened Dbm file for RdWr %s" dir_file#<End>;
+ Dbm.opendbm file [Dbm.Dbm_rdwr] File.default_rights
+ | ReadOnly ->
+ #<If>Logger.log ~color:`magenta "Opened Dbm file for Read %s" dir_file#<End>;
+ Dbm.opendbm file [Dbm.Dbm_rdonly] File.default_rights)
+ with exn ->
+ failwith (sprintf "Can't open Dbm file %s %s" file (Printexc.to_string exn))
+ in
+ t.dbm <- Some dbm;
+ t.link_count <- t.link_count + 1;
+ Hashtbl.add dbtbl cfile t;
+ t
+
+let get_timestamp t =
+ match t.dbm with
+ | Some dbm ->
+ (try Date.of_string (Dbm.find dbm "timestamp")
+ with Not_found -> Time.now ())
+ | None ->
+ Time.now ()
+
+let get_location t = t.location
+let get_dbm t = t.dbm
+let get_link_count t = t.link_count
+let get_has_lock t = t.has_lock
+
+
View
55 database/light/node_light.ml
@@ -0,0 +1,55 @@
+(*
+ 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/>.
+*)
+
+type t = {
+ mutable content : Datas.t ;
+}
+
+(*******************)
+(* Screen printing *)
+(*******************)
+
+let print_full n = Printf.sprintf "content=%s" (Datas.to_string n.content)
+
+let to_string node = Printf.sprintf "{%s}" (print_full node)
+
+(************************)
+(* Access to the fields *)
+(************************)
+
+let get_content node = node.content
+
+let is_occupied node =
+ match node.content with
+ | Datas.UnsetData -> false
+ | _ -> true
+
+(************************)
+(* Creation and updates *)
+(************************)
+
+let create ?content () =
+ let content =
+ match content with
+ | Some d -> d
+ | _ -> Datas.empty
+ in
+ { content = content }
+
+
+
View
30 database/light/node_light.mli
@@ -0,0 +1,30 @@
+(*
+ 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/>.
+*)
+type t = {
+ mutable content : Datas.t ;
+}
+
+val to_string : t -> string
+
+(* creation and updates *)
+val create : ?content:Datas.t -> unit -> t
+val is_occupied : t -> bool
+
+(* access to the fields *)
+val get_content : t -> Datas.t
+
View
453 database/light/session_light.ml
@@ -0,0 +1,453 @@
+(*
+ 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 *)
+
+(* shorthands *)
+module DT = DbTypes
+let sprintf = Printf.sprintf
+
+(* debug *)
+#<Debugvar:DEBUG_DB>
+
+(* -- *)
+
+
+ (* shorthands *)
+ type 'a intmap = 'a IntMap.t
+ module List = BaseList
+ module Tr = Transaction_light
+
+ (* The queue of transaction numbers, stored in order of appearance,
+ helps in choosing the next prepare to do (the longest waiting).
+ TODO: it's imperative; perhaps do this functionally? *)
+ type tr_FIFO = (Tr.t * (Tr.t * bool -> unit)) Queue.t
+
+ let is_empty_FIFO queue = Queue.is_empty queue
+
+ let create_FIFO () = Queue.create ()
+
+ let add_FIFO trans k queue = Queue.add (trans, k) queue
+
+ let take_FIFO queue = Queue.take queue
+
+ type lock = (Tr.t * Db_light.t) option
+ (* It stores a transaction and the new db after applying it,
+ which will become official if the commit of the
+ transaction is requested and succeeds. Whichever part of the code
+ releases the lock is responsible for taking the oldest transaction
+ from the waiting FIFO and preparing it. *)
+
+ type t = { mutable trans_num : int (* counter for fresh transaction serial numbers *)
+ ; mutable db_ref : Db_light.t (* the reference db passed to new transactions *)
+ ; with_dot : bool (* Not used *)
+ ; is_weak : bool (* Not used *)
+ ; file_manager : Io_light.t
+ ; mutable session_lock : lock
+ ; waiting_FIFO : tr_FIFO
+ (* The queue stores the waiting transactions with their revisions,
+ as well as the continuations to execute asynchronously,
+ when prepare of the transactions is over
+ (usually the continuation will execute a commit operation
+ or send a confirmation to the client, which may then request
+ the commit operation). *)
+ }
+
+ (* exceptions *)
+ exception Open of (t option * string)
+ exception DiskError of string
+
+
+ (*******************)
+ (* ecriture disque *)
+ (*******************)
+
+ let write_trans dbm trans =
+ List.iter (fun (path,query) ->
+ match query with
+ | Tr.Set datas ->
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : updating path %s to %s"
+ (Path.to_string path) (Datas.to_string datas)#<End>;
+ Dbm.replace dbm (Encode_light.encode_path path) (Encode_light.encode_datas datas)
+ | Tr.Remove path ->
+ (* TODO: subtrees!!! *)
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : (qm) removing path %s" (Path.to_string path)#<End>;
+ try Dbm.remove dbm (Encode_light.encode_path path)
+ with Dbm.Dbm_error "dbm_delete" -> ()
+ ) (List.rev trans.Tr.tr_query_map);
+ List.iter (fun path ->
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : (rl) removing path %s" (Path.to_string path)#<End>;
+ try Dbm.remove dbm (Encode_light.encode_path path)
+ with Dbm.Dbm_error "dbm_delete" -> ()
+ ) (List.rev trans.Tr.tr_remove_list)
+
+ let disk_writing t trans =
+ match Io_light.get_dbm t.file_manager with
+ | Some dbm ->
+ (try
+ Dbm.replace dbm "timestamp" (Date.rfc1123 (Time.localtime (Time.now())));
+ write_trans dbm trans
+ with e -> (
+ let cause = Printexc.to_string e in
+ let bt = Printexc.get_backtrace() in
+ #<If>Logger.log ~color:`red "DB-LIGHT : error during disk writing for\n%s\n%s" cause bt#<End>;
+ raise (DiskError (sprintf "%s\n%s" cause bt))))
+ | None ->
+ #<If>Logger.log ~color:`red "DB-LIGHT : warning Dbm closed during disk writing transaction #%d"
+ (Tr.get_num trans)#<End>
+
+ (************************)
+ (* timestamps managment *)
+ (************************)
+
+ let get_timestamp t =
+ let timestamp = Io_light.get_timestamp t.file_manager in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : get timestamp = %s" (Date.rfc1123 (Time.localtime timestamp))#<End>;
+ timestamp
+
+
+ (************************************)
+ (* ouverture / fermeture de session *)
+ (************************************)
+
+ let position file =
+ if Filename.is_relative file
+ then sprintf "%s/" (Unix.getcwd ())
+ else ""
+
+ let init_db mode file =
+ let rep = Filename.dirname file in
+ let _ =
+ try
+ if not (File.check_create_path rep) then
+ raise (Open (None, (sprintf "%s: unable to create path" rep)))
+ with
+ | Unix.Unix_error (r, f, p) ->
+ let s = sprintf "%s %s => %s" f p (Unix.error_message r) in
+ raise (Open (None,s))
+ | e -> raise (Open (None, Printexc.to_string e)) in
+ let db = Db_light.make () in
+ { trans_num = 0
+ ; db_ref = db
+ ; with_dot = false
+ ; is_weak = false
+ ; file_manager = Io_light.make mode file
+ ; session_lock = None
+ ; waiting_FIFO = create_FIFO ()
+ }
+
+ let make ?dot ?weak file =
+ let _ = (dot,weak) in
+ Logger.info "make: file=%s" file;
+ let t = init_db Io_light.Create file in
+ let _position = position file in
+ let _dot, with_dot = (*match dot with
+ | Some true -> "with", true
+ | Some false | None ->*) "without", false in
+ let _disk, _weak, is_weak = (*match weak with
+ | Some true -> "reading on disk", Some (read_node_from_disk t), true
+ | Some false | None ->*) "ram only", None, false in
+ #<If>Logger.log "Opening a new DB %s dot files, %s at %s%s by %s"
+ _dot _disk _position file (Sys.executable_name)#<End>;
+ let db = Db_light.make () in
+ {t with db_ref = db
+ ; is_weak = is_weak
+ ; with_dot = with_dot }
+
+ let close_db ?(donothing=false) t =
+ let _ = donothing in
+ let file = Io_light.get_location t.file_manager in
+ let _position = position file in
+ Logger.info "Closing the database at %s" file;
+ Io_light.close t.file_manager;
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : '%s%s' closed(%b)"
+ _position file (Io_light.is_closed t.file_manager)#<End>
+
+ let restart_db_from_last t =
+ let db = Db_light.make () in
+ (match Io_light.get_dbm t.file_manager with
+ | Some dbm ->
+ Dbm.iter (fun pathstr datastr ->
+ match pathstr with
+ | "version" ->
+ if Io_light.version <> datastr
+ then Logger.log ~color:`red "Warning: Dbm file version %s does not match DB %s"
+ datastr Io_light.version;
+ #<If>Logger.log ~color:`magenta "Dbm file version %s" datastr#<End>;
+ Db_light.set_version db datastr
+ | "timestamp" ->
+ #<If>Logger.log ~color:`magenta "Dbm file timestamp %s" datastr#<End>;()
+ | "lock_pid" ->
+ #<If>Logger.log ~color:`magenta "Dbm file lock PID %s" datastr#<End>;()
+ | "lock_hostname" ->
+ #<If>Logger.log ~color:`magenta "Dbm file lock hostname %s" datastr#<End>;()
+ | _ ->
+ let path = snd (Encode_light.decode_path pathstr 0) in
+ let datas = snd (Encode_light.decode_datas datastr 0) in
+ #<If>Logger.log ~color:`magenta "DB-LIGHT : set %s -> %s"
+ (Path.to_string path) (Datas.to_string datas)#<End>;
+ (match datas with Datas.Data dataImpl -> ignore (Db_light.update_index db [(path,dataImpl)]) | _ -> ());
+ ignore (Db_light.update db path datas))
+ dbm
+ | None -> ());
+ db
+
+ let restart_db ?dot ?weak ?restore ?openat_rev file =
+ let _ = dot, weak, restore, openat_rev in
+ let t = init_db Io_light.Append file in
+ let _position = position file in
+ let _dot, with_dot = (*match dot with
+ | Some true -> "with", true
+ | Some false | None ->*) "without", false in
+ let _disk, _weak, is_weak = (*match weak with
+ | Some true -> "reading on disk", Some (read_node_from_disk t), true
+ | Some false | None ->*) "ram only", None, false in
+ #<If>Logger.log "Opening an existing DB %s dot files, %s at %s%s by %s"
+ _dot _disk _position file (Sys.executable_name)#<End>;
+ let t = { t with is_weak = is_weak; with_dot = with_dot; } in
+ let db =
+ try restart_db_from_last t
+ with exn ->
+ #<If>Logger.log "restart_db: Can't open Dbm %s %s" file (Printexc.to_string exn)#<End>;
+ raise (Open (None, "Corrupted files"))
+ in
+ t.db_ref <- db;
+ t
+
+ let open_db_aux ?dot ?weak ?rev ?restore file =
+ let _ = (rev, restore) in
+ let _starting_time = Unix.gettimeofday() in
+ let pretty_location = #<If:TESTING> "" #<Else> " at "^file #<End> in
+ if file = "" then raise (Open (None, "empty name"))
+ else
+ let is_new, session =
+ if Sys.file_exists (file^".dir")
+ then (Logger.info "Opening database%s" pretty_location;
+ false, restart_db ?dot ?weak ?restore file)
+ else (Logger.notice "Initialising empty database%s" pretty_location;
+ true, make ?dot ?weak file)
+ in
+ #<If>Logger.log "time to open = %f" (Unix.gettimeofday() -. _starting_time)#<End>;
+ session, is_new
+
+ let open_db ?dot ?weak ?rev ?restore file =
+ try open_db_aux ?dot ?weak ?rev ?restore file
+ with Open (db, s) ->
+ (Option.iter (fun db -> close_db ~donothing:true db) db;
+ Logger.critical "Error during database opening :\n%s" s;
+ exit 1)
+
+
+ let is_empty t = Db_light.is_empty t.db_ref
+
+ let get_rev t = Db_light.get_rev t.db_ref
+
+
+ (*******************)
+ (* les transactions*)
+ (*******************)
+
+ let is_closed_db t = not (Io_light.is_open t.file_manager)
+
+ let new_trans ?read_only t =
+ assert (not (is_closed_db t));
+ let trans_num = (succ t.trans_num) mod max_int in
+ t.trans_num <- trans_num;
+ #<If>
+ Logger.log ~color:`white
+ "Initialisation of a new transaction%swith number #%d on a DB"
+ (match read_only with
+ | Some (true, _) -> " read only "
+ | _ -> " ")
+ trans_num
+ #<End>;
+ Tr.init t.db_ref ?read_only trans_num
+
+ let abort_of_unprepared t _trans =
+ assert (t.session_lock = None);
+ (* No transaction is prepared at this time, so the one from
+ argument must be unprepared, so do nothing. GC will take care
+ of cleaning it. *)
+ #<If>
+ Logger.log ~color:`red
+ "Abort of unprepared transaction or of the continuation of committed transaction #%d."
+ (Tr.get_num _trans)
+ #<End>;
+ (* Not removed from init_map, because at the higher level
+ it may be wiped up and rebuilt differently, so it still exists. *)
+ ()
+
+ let _prepare_commit db_ref trans =
+ #<If>Logger.log ~color:`white "Preparing commit of transaction #%d on a DB." (Tr.get_num trans)#<End>;
+ Tr.commit trans db_ref
+
+ (* Never runs the continuation [k]. *)
+ let prepare_commit t trans k =
+ match t.session_lock with
+ | None ->
+ #<If>Logger.log ~color:`cyan "Preparing transaction #%d (no FIFO)." (Tr.get_num trans)#<End>;
+ let db = _prepare_commit t.db_ref trans in
+ t.session_lock <- Some (trans, db);
+ Some (trans, k)
+ | Some _ ->
+ #<If>Logger.info "Previous prepared transaction not committed yet. Stashed transaction #%d on the waiting FIFO."
+ (Tr.get_num trans) #<End>;
+ (* Assumption: this won't raise exceptions. If the data structure
+ gets complicated and exceptions are possible, change
+ [abort_of_unprepared] in the next function, because here
+ the transaction is prepared (partially). *)
+ add_FIFO trans k t.waiting_FIFO;
+ None
+
+ (* Calls a continuation, but never catches its exceptions. *)
+ let rec try_prepare_commit t trans k =
+ try
+ prepare_commit t trans k
+ with
+ | Db_light.Merge
+ | Db_light.UnqualifiedPath | DiskError _ ->
+ (* The preparation may be half-done, so we rollback to revert it. *)
+ abort_of_unprepared t trans;
+ k (trans, false);
+ (* This trans is in conflict, so it won't get committed,
+ so the commit function won't pop from the FIFO, when it finishes.
+ So try another one from the waiting list, until one merges OK. *)
+ pop_trans_k t
+ | e ->
+ (* The preparation may be half-done, so we rollback to revert it
+ and reraise the exception in a saner internal state. *)
+ (* do not reraise the excpetion, coonsider that the transaction failed
+ * apply the continuation with [false], and continue popping *)
+ (Logger.error "Error During db transaction : %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ());
+ abort_of_unprepared t trans;
+ k (trans, false);
+ pop_trans_k t)
+
+ and pop_trans_k t =
+ if is_empty_FIFO t.waiting_FIFO then begin
+ #<If> Logger.log ~color:`red "Nothing popped from FIFO." #<End>;
+ None
+ end else begin
+ let (trans, k) = take_FIFO t.waiting_FIFO in
+ #<If>
+ Logger.log ~color:`red
+ "Commit of transaction #%d popped from FIFO; %d commits waiting."
+ (Tr.get_num trans) (Queue.length t.waiting_FIFO)
+ #<End>;
+ try_prepare_commit t trans k
+ end
+
+ (* Calls a continuation, but never catches its exceptions. *)
+ let try_trans_prepare t trans k =
+ match try_prepare_commit t trans k with
+ | None -> ()
+ | Some (trans2, k2) -> k2 (trans2, true)
+
+ (* Calls a continuation, but never catches its exceptions. *)
+ let pop_trans_prepare t =
+ match pop_trans_k t with
+ | None -> ()
+ | Some (trans, k) -> k (trans, true)
+
+ let abort_or_rollback t trans =
+ #<If>
+ Logger.log ~color:`red
+ "Rollback of prepared or abort of unprepared or of the continuation of committed transaction #%d."
+ (Tr.get_num trans)
+ #<End>;
+ match t.session_lock with
+ | None ->
+ abort_of_unprepared t trans
+ | Some (transl, _db) ->
+ if Tr.get_num transl <> Tr.get_num trans then begin
+ (* The transaction is not the one prepared. For now, to keep
+ rollbacks deterministic from the point of view of a single thread,
+ we do nothing, so the transaction will be prepaired in the future
+ and commited, if the commit request is, e.g., in the prepare
+ callback continuation. If needed, as an optimiztion,
+ the commit may be removed from the waiting list together with
+ the callback, but we are in trouble if the commit request was not
+ in the callback, but in another thread and so it will crash.
+ In other words, we for now we treat this as abort, not rollback. *)
+ #<If>
+ Logger.log ~color:`red
+ "Abort of unprepared transaction #%d (while another, prepared transaction waits for commit)."
+ (Tr.get_num trans)
+ #<End>;
+ (* Not removed from init_map, because at the higher level
+ it may be wiped up and rebuilt differently, so it still exists. *)
+ end else begin
+ (* Release the lock. *)
+ t.session_lock <- None;
+ pop_trans_prepare t;
+ #<If>
+ Logger.log ~color:`red
+ "Rollback of prepared transaction #%d"
+ (Tr.get_num trans)
+ #<End>;
+ end
+
+ let really_commit t trans =
+ match t.session_lock with
+ | Some (transl, db) ->
+ let success =
+ try
+ assert (Tr.get_num transl = Tr.get_num trans);
+ t.db_ref <- db;
+ disk_writing t trans;
+ (* Release the lock. *)
+ t.session_lock <- None;
+ true
+ with
+ | Db_light.UnqualifiedPath | DiskError _ -> false
+ in
+ if success then begin
+ #<If> Logger.info "Finished a commit." #<End>
+ end else begin
+ #<If> Logger.info "Failed a commit." #<End>
+ end;
+ pop_trans_prepare t;
+ success
+ | None ->
+ Logger.error "Inconsistent state: it should be locked before commit.";
+ assert false
+
+ (* reading from DB *)
+
+ let get _t tr path = Tr.get tr path
+
+ let get_children _t trans range path =
+ List.sort compare (Tr.get_children trans range path)
+
+ let stat trans path = Tr.stat trans path
+
+ let full_search tr slist path = Tr.full_search tr slist path
+
+
+ (* writing to DB *)
+
+ let set trans path data = Tr.set trans path data
+
+ let remove trans path = Tr.remove trans path
+
+ let set_link trans path link = Tr.set_link trans path link
+
+ let set_copy _t trans path (target_path, target_rev) =
+ Tr.set_copy trans path (target_path, target_rev)
+
+
+
View
401 database/light/transaction_light.ml
@@ -0,0 +1,401 @@
+(*
+ 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 *)
+
+(* shorthands *)
+module DT = DbTypes
+module List = BaseList
+let sprintf = Printf.sprintf
+let eprintf = Printf.eprintf
+
+(* debug *)
+#<Debugvar:DEBUG_DB>
+
+(* -- *)
+
+type query =
+ | Set of Datas.t
+ | Remove of Path.t
+
+let string_of_query = function
+ | Set d -> sprintf "set %s" (Datas.to_string d)
+ | Remove k -> sprintf "remove %s" (Path.to_string k)
+
+let string_of_query_list list =
+ List.to_string (fun q -> sprintf "%s " (string_of_query q)) list
+
+let string_of_query_map qm =
+ List.to_string (fun (p,q) -> sprintf "(%s,%s); " (Path.to_string p) (string_of_query q)) qm
+
+type t = {
+ tr_num : int ;
+ tr_db : Db_light.t ;
+ (** the db the transaction refers to *)
+
+ tr_query_map : (Path.t * query) list;
+ (** the map of queries against the db *)
+
+ tr_remove_list : Path.t list ;
+ (** the list of deleted paths in the transaction *)
+
+ tr_index_set : (Path.t * DataImpl.t) list ;
+ (* for search index update *)
+ (** auxiliary index *)
+
+ tr_index_remove : (Path.t * DataImpl.t) list ;
+ (* for search index *)
+ (** auxiliary index *)
+
+ tr_op_counter : int ;
+}
+
+(*******************************)
+(* transaction's fields access *)
+(*******************************)
+
+let get_num tr = tr.tr_num
+let get_db tr = tr.tr_db
+let get_query_map tr = tr.tr_query_map
+
+(*********************)
+(* DB reading access *)
+(*********************)
+
+let full_search tr slist path =
+ #<If>
+ Logger.log ~color:`yellow "DB-LIGHT : full search for %s at %s"
+ (BaseList.to_string (fun s -> sprintf "%s "s)slist)
+ (Path.to_string path)
+ #<End>;
+ Db_light.full_search tr.tr_db slist path
+
+exception Data_not_found
+
+let rec find_data_in_query_list = function
+ | [] -> raise Data_not_found
+ | Set (Datas.Data d) :: _ -> d
+ | Set (Datas.Link _) :: _ -> assert false
+ | Set (Datas.Copy (_, _)) :: _ -> assert false
+ | _ :: tl -> find_data_in_query_list tl
+
+exception Removed
+
+(* Raises [Not_found] if data absent from query, [Removed] if removed. *)
+let get_query_at tr path =
+ let query_list =
+ List.fold_left
+ (fun query_list (p,q) ->
+ if Path.compare path p = 0
+ then (p,q)::query_list
+ else query_list) [] tr.tr_query_map
+ in
+ if query_list = []
+ then
+ if List.mem path tr.tr_remove_list
+ then raise Removed
+ else raise Not_found;
+ query_list
+
+let rec find_set_data_in_query_list = function
+ | [] -> None
+ | Set (Datas.Data d) :: _ -> Some d
+ | Set (Datas.UnsetData) :: _ -> Some DataImpl.empty
+ | _ :: tl -> find_set_data_in_query_list tl
+
+(* Main objective: copies have to be fully transparent.
+ We run path unwinding in the [stop_at_copy:false] mode to report paths that
+ end in a non-existing node (dangling Links at the end are OK, though,
+ and the revision returned for them is None). *)
+let stat tr path =
+ let path, kind =
+ let rec aux path =
+ let (node, _) = Db_light.get_node_of_path tr.tr_db path in
+ match Node_light.get_content node with
+ | Datas.Data _ -> path, `Data
+ | Datas.Link p -> p, `Link
+ | Datas.Copy (_, p) -> aux p
+ | Datas.UnsetData -> path, `Unset
+ in
+ aux path
+ in
+ (path, Some (Revision.make 0), kind)
+
+let get tr path =
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : get data at %s" (Path.to_string path)#<End>;
+ let (_path, node) = Db_light.follow_link tr.tr_db path in
+ Db_light.get_data tr.tr_db (Db_light.node_node node)
+
+(* may raise Removed and Not_found *)
+let virtual_get_children tr path = List.map fst (get_query_at tr path)
+
+let get_children tr range path =
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : get children at %s" (Path.to_string path)#<End>;
+ try
+ let virtual_children = virtual_get_children tr path in
+ let virtual_children = List.sort compare virtual_children in
+ try
+ let real_children = Db_light.get_children tr.tr_db None path in
+ let real_children = List.filter
+ (fun p -> not (List.mem p tr.tr_remove_list)) real_children
+ in
+ let l =
+ BaseList.uniq (List.merge (fun p1 p2 -> Path.compare p1 p2)
+ virtual_children real_children)
+ in
+ (* If we got there, it's the 1% of cases where
+ the queried children are affected by the current transaction. *)
+ BaseList.filterbounds range (fun p -> Path.last p) l
+ with Db_light.UnqualifiedPath ->
+ (* That's even more rare --- the father node has just been created. *)
+ BaseList.filterbounds range (fun p -> Path.last p) virtual_children
+ with
+ | Removed -> []
+ | Not_found ->
+ (* Common case: no children added nor removed in current transaction. *)
+ Db_light.get_children tr.tr_db (Some range) path
+