Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 7c62863b04
Fetching contributors…

Cannot retrieve contributors at this time

521 lines (455 sloc) 18.069 kb
open Db_exn
(** Database tables, columns and rows are all indexed by string, each
using a specialised StringMap *)
module StringMap = struct
include Map.Make(struct
type t = string
let compare = Pervasives.compare
end)
let update key default f t =
let v = try find key t with Not_found -> default in
add key (f v) t
end
module type VAL = sig
type v
end
(** A specialised StringMap whose range type is V.v, and which keeps a record of when records are created/updated *)
module Map2 = functor(V: VAL) -> struct
type x = {
created : int64;
updated : int64;
v : V.v }
type map_t = x StringMap.t
let empty = StringMap.empty
let fold f = StringMap.fold (fun key x -> f key x.created x.updated x.v)
let add generation key value = StringMap.add key {created=generation; updated=generation; v=value}
let find key map = (StringMap.find key map).v
let mem = StringMap.mem
let iter f = StringMap.iter (fun key x -> f key x.v)
let remove = StringMap.remove
let update_generation generation key default f row =
StringMap.update key {created=generation; updated=generation; v=default} (fun x -> {x with updated=generation; v=f x.v}) row
let update generation key default f row =
let updatefn () = StringMap.update key {created=generation; updated=generation; v=default} (fun x -> {x with updated=generation; v=f x.v}) row in
if mem key row
then
let old = find key row in
let newv = f old in
if newv == old
then row
else updatefn ()
else
updatefn ()
let fold_over_recent since f = StringMap.fold (fun x y z -> if y.updated > since then f y.created y.updated 0L x y.v z else z)
end
module StringStringMap = Map2(struct type v = string end)
module type ROW = sig
type t
val add: int64 -> string -> string -> t -> t
val add_defaults: int64 -> Schema.Table.t -> t -> t
val empty : t
val fold : (string -> int64 -> int64 -> string -> 'b -> 'b) -> t -> 'b -> 'b
val find : string -> t -> string
val mem : string -> t -> bool
val iter : (string -> string -> unit) -> t -> unit
val remove : string -> t -> t
val update : int64 -> string -> string -> (string -> string) -> t -> t
val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> string -> 'b -> 'b) -> t -> 'b -> 'b
end
module Row : ROW = struct
include StringStringMap
type t=map_t
let find key t =
try find key t
with Not_found -> raise (DBCache_NotFound ("missing field", key, ""))
let add_defaults g (schema: Schema.Table.t) t =
List.fold_left (fun t c ->
if not(mem c.Schema.Column.name t)
then match c.Schema.Column.default with
| Some default -> add g c.Schema.Column.name default t
| None -> raise (DBCache_NotFound ("missing field", c.Schema.Column.name, ""))
else t) t schema.Schema.Table.columns
end
module StringRowMap = Map2(struct type v = Row.t end)
module type TABLE = sig
type t
val add: int64 -> string -> Row.t -> t -> t
val empty : t
val fold : (string -> int64 -> int64 -> Row.t -> 'b -> 'b) -> t -> 'b -> 'b
val find_exn : string -> string -> t -> Row.t
val find : string -> t -> Row.t
val mem : string -> t -> bool
val iter : (string -> Row.t -> unit) -> t -> unit
val remove : int64 -> string -> t -> t
val update_generation : int64 -> string -> Row.t -> (Row.t -> Row.t) -> t -> t
val update : int64 -> string -> Row.t -> (Row.t -> Row.t) -> t -> t
val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b
val rows : t -> Row.t list
end
module Table : TABLE = struct
type t = { rows : StringRowMap.map_t;
deleted_len : int;
deleted : (int64 * int64 * string) list }
let add g key value t = {t with rows=StringRowMap.add g key value t.rows}
let empty = {rows=StringRowMap.empty; deleted_len = 1; deleted=[(0L,0L,"")] }
let fold f t acc = StringRowMap.fold f t.rows acc
let find_exn tbl key t =
try StringRowMap.find key t.rows
with Not_found -> raise (DBCache_NotFound ("missing row", tbl, key))
let find key t = StringRowMap.find key t.rows
let mem key t = StringRowMap.mem key t.rows
let iter f t = StringRowMap.iter f t.rows
let remove g key t =
let upper_length_deleted_queue = 512 in
let lower_length_deleted_queue = 256 in
let created = (StringMap.find key t.rows).StringRowMap.created in
let new_element = (created,g,key) in
let new_len,new_deleted =
if t.deleted_len + 1 < upper_length_deleted_queue
then t.deleted_len + 1, (new_element::t.deleted)
else lower_length_deleted_queue + 1, (new_element::(Listext.List.take lower_length_deleted_queue t.deleted))
in
{rows = StringRowMap.remove key t.rows;
deleted_len = new_len;
deleted = new_deleted}
let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows }
let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows}
let fold_over_recent since f errf t acc =
let acc = StringRowMap.fold_over_recent since (fun c u d x _ z -> f c u d x z) t.rows acc in
let rec fold_over_deleted deleted acc =
match deleted with
| (created,destroyed,r)::xs ->
let new_acc =
if (destroyed > since) && (created <= since)
then (f created 0L destroyed r acc)
else acc
in
if destroyed <= since then new_acc else fold_over_deleted xs new_acc
| [] ->
errf ();
acc
in fold_over_deleted t.deleted acc
let rows t =
fold (fun _ _ _ r rs -> r :: rs) t []
end
module StringTableMap = Map2(struct type v = Table.t end)
module type TABLESET = sig
type t
val add: int64 -> string -> Table.t -> t -> t
val empty : t
val fold : (string -> int64 -> int64 -> Table.t -> 'b -> 'b) -> t -> 'b -> 'b
val find : string -> t -> Table.t
val mem : string -> t -> bool
val iter : (string -> Table.t -> unit) -> t -> unit
val remove : string -> t -> t
val update : int64 -> string -> Table.t -> (Table.t -> Table.t) -> t -> t
val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> Table.t -> 'b -> 'b) -> t -> 'b -> 'b
end
module TableSet : TABLESET = struct
include StringTableMap
type t=map_t
let find key t =
try find key t
with Not_found -> raise (DBCache_NotFound ("missing table", key, ""))
end
type common_key =
| Ref of string
| Uuid of string
let string_of_common_key = function
| Ref x -> x
| Uuid x -> x
module KeyMap = struct
include Map.Make(struct
type t = common_key
let compare = Pervasives.compare
end)
let add_unique tblname fldname k v t =
if mem k t
then raise (Uniqueness_constraint_violation ( tblname, fldname, string_of_common_key k ))
else add k v t
end
module Manifest = struct
type t = {
schema : (int * int) option;
generation_count : Generation.t
}
let empty = {
schema = None; generation_count = Generation.null_generation
}
let make schema_major_vsn schema_minor_vsn gen_count = {
schema = Some (schema_major_vsn, schema_minor_vsn);
generation_count = gen_count
}
let generation x = x.generation_count
let update_generation f x = {
x with generation_count = f x.generation_count
}
let next = update_generation (Int64.add 1L)
let schema x = match x.schema with
| None -> 0, 0
| Some (x, y) -> x, y
let update_schema f x = {
x with schema = f x.schema
}
end
(** The core database updates (RefreshRow and PreDelete is more of an 'event') *)
type update =
| RefreshRow of string (* tblname *) * string (* objref *)
| WriteField of string (* tblname *) * string (* objref *) * string (* fldname *) * string (* oldval *) * string (* newval *)
| PreDelete of string (* tblname *) * string (* objref *)
| Delete of string (* tblname *) * string (* objref *) * (string * string) list (* values *)
| Create of string (* tblname *) * string (* objref *) * (string * string) list (* values *)
module Database = struct
type t = {
tables: TableSet.t;
manifest : Manifest.t;
schema: Schema.t;
keymap: (string * string) KeyMap.t;
callbacks: (string * (update -> t -> unit)) list
}
let update_manifest f x =
{ x with manifest = f x.manifest }
let manifest x = x.manifest
let increment = update_manifest Manifest.next
let tableset x = x.tables
let schema x = x.schema
let update f x =
{ x with tables = f x.tables }
let set_generation g =
update_manifest (Manifest.update_generation (fun _ -> g))
let update_tableset f x =
{ x with tables = f x.tables }
let update_keymap f x =
{ x with keymap = f x.keymap }
let register_callback name f x =
{ x with callbacks = (name, f) :: x.callbacks }
let unregister_callback name x =
{ x with callbacks = List.filter (fun (x, _) -> x <> name) x.callbacks }
let notify e db =
List.iter (fun (name, f) ->
try
f e db
with e ->
Printf.printf "Caught %s from database callback '%s'\n%!" (Printexc.to_string e) name;
()
) db.callbacks
let reindex x =
let g = x.manifest.Manifest.generation_count in
(* Recompute the keymap *)
let keymap =
TableSet.fold
(fun tblname _ _ tbl acc ->
Table.fold
(fun rf _ _ row acc ->
let acc = KeyMap.add_unique tblname Db_names.ref (Ref rf) (tblname, rf) acc in
if Row.mem Db_names.uuid row
then KeyMap.add_unique tblname Db_names.uuid (Uuid (Row.find Db_names.uuid row)) (tblname, rf) acc
else acc
)
tbl acc)
x.tables KeyMap.empty in
(* For each of the one-to-many relationships, recompute the many end *)
let tables =
Schema.StringMap.fold
(fun one_tblname rels tables ->
List.fold_left (fun tables (one_fldname, many_tblname, many_fldname) ->
(* VBD.VM : Ref(VM) -> VM.VBDs : Set(Ref(VBD)) *)
let one_tbl = TableSet.find one_tblname tables in
let many_tbl = TableSet.find many_tblname tables in
(* Initialise all VM.VBDs = [] (otherwise VMs with no
VBDs may be missing a VBDs field altogether on
upgrade) *)
let many_tbl' = Table.fold
(fun vm _ _ row acc ->
let row' = Row.add g many_fldname (SExpr.string_of (SExpr.Node [])) row in
Table.add g vm row' acc)
many_tbl Table.empty in
(* Build up a table of VM -> VBDs *)
let vm_to_vbds = Table.fold
(fun vbd _ _ row acc ->
let vm = Row.find one_fldname row in
let existing = if Schema.StringMap.mem vm acc then Schema.StringMap.find vm acc else [] in
Schema.StringMap.add vm (vbd :: existing) acc)
one_tbl Schema.StringMap.empty in
let many_tbl'' = Schema.StringMap.fold
(fun vm vbds acc ->
if not(Table.mem vm acc)
then acc
else
let row = Table.find vm acc in
let vbds' = SExpr.string_of (SExpr.Node (List.map (fun x -> SExpr.String x) vbds)) in
let row' = Row.add g many_fldname vbds' row in
Table.add g vm row' acc)
vm_to_vbds many_tbl' in
TableSet.add g many_tblname many_tbl'' tables)
tables rels)
x.schema.Schema.one_to_many
x.tables in
{ x with keymap = keymap; tables = tables }
let table_of_ref rf db = fst (KeyMap.find (Ref rf) db.keymap)
let lookup_key key db =
if KeyMap.mem (Ref key) db.keymap
then Some (KeyMap.find (Ref key) db.keymap)
else None
let make schema = {
tables = TableSet.empty;
manifest = Manifest.empty;
schema = schema;
keymap = KeyMap.empty;
callbacks = [];
}
end
(* Helper functions to deal with Sets and Maps *)
let add_to_set key t =
let existing = Db_action_helper.parse_sexpr t in
let processed = Db_action_helper.add_key_to_set key existing in
SExpr.string_of (SExpr.Node processed)
let remove_from_set key t =
let existing = Db_action_helper.parse_sexpr t in
let processed = List.filter (function SExpr.String x -> x <> key | _ -> true) existing in
SExpr.string_of (SExpr.Node processed)
let set_of_string t =
List.map
(function SExpr.String x -> x
| x -> failwith (Printf.sprintf "Unexpected sexpr: %s" t))
(Db_action_helper.parse_sexpr t)
let string_of_set t = SExpr.string_of (SExpr.Node (List.map (fun x -> SExpr.String x) t))
exception Duplicate
let add_to_map key value t =
let existing = Db_action_helper.parse_sexpr t in
let kv = SExpr.Node [ SExpr.String key; SExpr.String value ] in
let duplicate = List.fold_left (||) false
(List.map (function SExpr.Node (SExpr.String k :: _) when k = key -> true
| _ -> false) existing) in
if duplicate then raise Duplicate;
let processed = kv::existing in
SExpr.string_of (SExpr.Node processed)
let remove_from_map key t =
let existing = Db_action_helper.parse_sexpr t in
let processed = List.filter (function SExpr.Node [ SExpr.String x; _ ] -> x <> key
| _ -> true) existing in
SExpr.string_of (SExpr.Node processed)
let (++) f g x = f (g x)
let id x = x
let is_valid tblname objref db =
Table.mem objref (TableSet.find tblname (Database.tableset db))
let get_field tblname objref fldname db =
Row.find fldname (Table.find_exn tblname objref (TableSet.find tblname (Database.tableset db)))
let unsafe_set_field g tblname objref fldname newval =
(Database.update
++ (TableSet.update g tblname Table.empty)
++ (Table.update g objref Row.empty)
++ (Row.update g fldname ""))
(fun _ -> newval)
let update_one_to_many g tblname objref f db =
if not (is_valid tblname objref db) then db else
List.fold_left (fun db (one_fld, many_tbl, many_fld) ->
(* the value one_fld_val is the Ref _ *)
let one_fld_val = get_field tblname objref one_fld db in
let valid = try ignore(Database.table_of_ref one_fld_val db); true with _ -> false in
if valid
then unsafe_set_field g many_tbl one_fld_val many_fld (f objref (get_field many_tbl one_fld_val many_fld db)) db
else db
) db (Schema.one_to_many tblname (Database.schema db))
let update_many_to_many g tblname objref f db =
if not (is_valid tblname objref db) then db else
List.fold_left (fun db (this_fld, other_tbl, other_fld) ->
let this_fld_val = get_field tblname objref this_fld db in
let this_fld_refs = set_of_string this_fld_val in
(* for each of this_fld_refs, apply f *)
List.fold_left (fun db other_ref ->
let valid = try ignore(Database.table_of_ref other_ref db); true with _ -> false in
if valid
then
let other_field = get_field other_tbl other_ref other_fld db in
unsafe_set_field g other_tbl other_ref other_fld (f objref other_field) db
else db)
db this_fld_refs
) db (Schema.many_to_many tblname (Database.schema db))
let set_field tblname objref fldname newval db =
if fldname = Db_names.ref
then failwith (Printf.sprintf "Cannot safely update field: %s" fldname);
let need_other_table_update =
let schema = Database.schema db in
match (Schema.one_to_many tblname schema, Schema.many_to_many tblname schema) with
| [],[] ->
false
| o2m,m2m ->
List.exists (fun (fld,tbl,otherfld) -> fld = fldname) o2m
|| List.exists (fun (fld,tbl,otherfld) -> fld = fldname) m2m
in
if need_other_table_update then begin
let g = Manifest.generation (Database.manifest db) in
(Database.increment
++ (update_one_to_many g tblname objref add_to_set)
++ (update_many_to_many g tblname objref add_to_set)
++ ((Database.update
++ (TableSet.update g tblname Table.empty)
++ (Table.update g objref Row.empty)
++ (Row.update g fldname "")) (fun _ -> newval))
++ (update_one_to_many g tblname objref remove_from_set)
++ (update_many_to_many g tblname objref remove_from_set)) db
end else begin
let g = Manifest.generation (Database.manifest db) in
(Database.increment
++ ((Database.update
++ (TableSet.update g tblname Table.empty)
++ (Table.update g objref Row.empty)
++ (Row.update g fldname ""))
(fun _ -> newval))) db
end
let update_generation tblname objref db =
let g = Manifest.generation (Database.manifest db) in
(* We update the generation twice so that we can return the lower count
for the "event.inject" API to guarantee that the token from a later
event.from will always compare as strictly greater. See the definition
of the event token datatype. *)
(Database.increment ++ Database.increment
++ ((Database.update
++ (TableSet.update g tblname Table.empty)
++ (Table.update_generation g objref Row.empty)) id
)) db
let add_row tblname objref newval db =
let g = db.Database.manifest.Manifest.generation_count in
(Database.increment
(* Update foreign Set(Ref _) fields *)
(* NB this requires the new row to exist already *)
++ (update_one_to_many g tblname objref add_to_set)
++ (update_many_to_many g tblname objref add_to_set)
++ ((Database.update ++ (TableSet.update g tblname Table.empty) ++ (Table.update g objref newval))
(fun _ -> newval))
++ (Database.update_keymap (KeyMap.add_unique tblname Db_names.ref (Ref objref) (tblname, objref)))
++ (Database.update_keymap (fun m ->
if Row.mem Db_names.uuid newval
then KeyMap.add_unique tblname Db_names.uuid (Uuid (Row.find Db_names.uuid newval)) (tblname, objref) m
else m))) db
let remove_row tblname objref db =
let uuid =
try
Some (Row.find Db_names.uuid (Table.find objref (TableSet.find tblname (Database.tableset db))))
with _ -> None in
let g = db.Database.manifest.Manifest.generation_count in
(Database.increment
++ ((Database.update ++ (TableSet.update g tblname Table.empty))
(Table.remove g objref))
(* Update foreign (Set(Ref _)) fields *)
(* NB this requires the original row to still exist *)
++ (update_one_to_many g tblname objref remove_from_set)
++ (update_many_to_many g tblname objref remove_from_set)
++ (Database.update_keymap (KeyMap.remove (Ref objref)))
++ (Database.update_keymap (fun m ->
match uuid with
| Some u -> KeyMap.remove (Uuid u) m
| None -> m))) db
type where_record = {
table: string; (** table from which ... *)
return: string; (** we'd like to return this field... *)
where_field: string; (** where this other field... *)
where_value: string; (** contains this value *)
} with rpc
type structured_op_t =
| AddSet
| RemoveSet
| AddMap
| RemoveMap
with rpc
Jump to Line
Something went wrong with that request. Please try again.