diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/attribute.ml | 2 | ||||
| -rw-r--r-- | lib/branch.ml | 2 | ||||
| -rw-r--r-- | lib/condition.ml | 14 | ||||
| -rw-r--r-- | lib/conventions.ml | 34 | ||||
| -rw-r--r-- | lib/ddl/executor.ml | 3 | ||||
| -rw-r--r-- | lib/listener.ml | 27 | ||||
| -rw-r--r-- | lib/nt.ml | 56 | ||||
| -rw-r--r-- | lib/sublanguage_context.ml | 31 | ||||
| -rw-r--r-- | lib/tuple.ml | 3 |
9 files changed, 105 insertions, 67 deletions
diff --git a/lib/attribute.ml b/lib/attribute.ml index b828d64..8448bee 100644 --- a/lib/attribute.ml +++ b/lib/attribute.ml @@ -9,3 +9,5 @@ let make_referenced ~value = Referenced { value_hash } let make_materialized ~value = Materialized { value } + +let materialized_equal a b = Conventions.AbstractValue.equal a.value b.value diff --git a/lib/branch.ml b/lib/branch.ml index 0b28663..f606d3f 100644 --- a/lib/branch.ml +++ b/lib/branch.ml @@ -96,7 +96,7 @@ module Make (NT : Nt.S) = struct let* mg_val = self#get_mg "create_relation" mg in let* (bh', mg') = NT.create_relation bh mg_val - ~branch_name:name ~mg_name:mg ~name:rel_name ~schema + ~branch_name:name ~name:rel_name ~schema in bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () diff --git a/lib/condition.ml b/lib/condition.ml index 44ef2ff..83ae9b8 100644 --- a/lib/condition.ml +++ b/lib/condition.ml @@ -11,16 +11,19 @@ end let of_sexp (expr : Sexplib.Sexp.t) = new literal expr let of_string (s : string) = new literal (Sexplib.Sexp.Atom s) +let of_int (n : int) = of_string (Int.to_string n) let of_list (f : 'a -> serializable) (l : 'a list) : serializable = new literal (Sexplib.Sexp.List (List.map (fun e -> (f e)#as_sexp) l)) type t = { name : string; message : string; + backtrace : Printexc.raw_backtrace; properties : (string, serializable) BatMap.t } let condition name message ?parent props = { name; message; + backtrace = Printexc.get_callstack 64; properties = parent |> Option.map (fun { properties; _ } -> properties) @@ -31,7 +34,7 @@ let ( |=| ) name value = (fun p -> BatMap.add name value p) let ( & ) l r = (fun p -> r (l p)) let empty = (fun p -> p) -let to_sexp { name; message; properties } = +let to_sexp { name; message; properties; _ } = let open Sexplib.Sexp in let properties' = properties @@ -40,10 +43,13 @@ let to_sexp { name; message; properties } = |> BatList.of_seq in List (Atom name :: Atom message :: properties') -let to_string { name; message; properties } = +let to_string { name; message; properties; backtrace } = let properties' = properties |> BatMap.to_seq - |> BatSeq.to_string ~sep:"\n" (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string) + |> BatSeq.to_string + ~first:"" ~last:"" ~sep:"\n" + (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string) in - name ^ ": " ^ message ^ properties' + let backtrace' = Printexc.raw_backtrace_to_string backtrace in + name ^ ": " ^ message ^ "\n" ^ properties' ^ "\n\nBacktrace:\n" ^ backtrace' diff --git a/lib/conventions.ml b/lib/conventions.ml index fe85737..9e18762 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -25,19 +25,35 @@ end module AbstractValue = struct type t = Obj.t + type value_type = Int | String | Float | Opaque let hash (elem : t) = Sha256.to_hex (Sha256.string (Bytes.to_string (Marshal.to_bytes elem []))) + let type_of (elem : t) : value_type = + let tag = Obj.tag elem in + if Obj.is_int elem then Int + else if tag = Obj.string_tag then String + else if tag = Obj.double_tag then Float + else Opaque + let sexp_of_t (v : t) = let open Sexplib.Sexp in - if Obj.is_int v then Atom (string_of_int (Obj.obj v : int)) - else - let tag = Obj.tag v in - if tag = Obj.string_tag then Atom (Obj.obj v : string) - else if tag = Obj.double_tag then - let f = (Obj.obj v : float) in - if Float.is_nan f || Float.is_infinite f then Atom "nan" - else Atom (string_of_float f) - else Atom "<opaque>" + match type_of v with + | Int -> Atom (string_of_int (Obj.obj v : int)) + | String -> Atom (Obj.obj v : string) + | Float -> + let f = (Obj.obj v : float) in + if Float.is_nan f || Float.is_infinite f + then Atom "nan" + else Atom (string_of_float f) + | Opaque -> Atom "<opaque>" + + let equal a b = + match (type_of a, type_of b) with + | (Int, Int) -> (Obj.obj a : int) = (Obj.obj b : int) + | (String, String) -> (Obj.obj a : string) = (Obj.obj b : string) + | (Float, Float) -> (Obj.obj a : float) = (Obj.obj b : float) + | (Opaque, Opaque) -> false + | (_, _) -> false end diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml index c61b02e..a47c911 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -46,8 +46,7 @@ module Make (NT : Nt.S) = struct Schema.empty schema_pairs in let* _bh, new_mg = - NT.create_relation bh mg - ~branch_name ~mg_name:fqn.mg ~name:fqn.name ~schema + NT.create_relation bh mg ~branch_name ~name:fqn.name ~schema in ctx.branch#set_mg ~name:fqn.mg new_mg; Ok ([ (fqn.mg, new_mg) ], "Relation created: " ^ name) diff --git a/lib/listener.ml b/lib/listener.ml index ba61a50..b3090a7 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -8,6 +8,7 @@ functor module Sess = Session.Make (NT) module B = Branch.Make (NT) + module SC = Sublanguage_context.Make (NT) module Error = struct open Condition @@ -37,30 +38,8 @@ functor state. Called at the top of every handle_sublanguage so it always reflects the live branch after any prior VCL switch. **) - let make_ctx (state : conn_state) : Sublanguage_context.t = - let br = state.session#branch in - let claims = state.claims in - let session = state.session in - { - Sublanguage_context.write_handle = br#branch_handle; - branch = (br :> Sublanguage_context.branch_view); - resolve = br#path; - switch_branch = fun name -> - match br#close () with - | Error e -> Error e - | Ok () -> - begin match B.open_branch claims name with - | Error e -> - begin match B.open_branch claims "master" with - | Ok mbr -> session#set_branch mbr - | Error _ -> () - end; - Error e - | Ok new_br -> - session#set_branch new_br; - Ok new_br#multigroups - end - } + let make_ctx ({ session; claims } : conn_state) : Sublanguage_context.t = + SC.make_ctx session claims let read_command input = try Ok (Sexplib.Sexp.input_sexp input) @@ -38,7 +38,10 @@ module Error = struct open Condition (* TODO: better error structure *) let auth_failed msg = condition "auth-failed" msg empty - let handle_error msg = condition "handle-error" msg empty + let handle_error rc msg = condition "handle-error" msg ("return-code" |=| (of_int rc)) + let object_not_found kind id = condition "object-not-found" "Object not found" + ("kind" |=| (of_string kind) & + "identifier" |=| (of_string id)) let cursor_error msg = condition "cursor-error" msg empty let not_supported msg = condition "not-supported" msg empty let initialization_error = condition "initialization-error" "Couldn't initialize" empty @@ -118,7 +121,7 @@ module Make (B : Backend) = struct match (rc, target_opt) with | (0, Some s) -> Ok s | (0, None) -> Ok "" - | _ -> Error (Error.handle_error "branch_target read failed") + | _ -> Error (Error.handle_error rc "branch_target read failed") let list_relations ~(branch_name : string) ~(mg_name : string) : ((string * string) list, Condition.t) result = @@ -137,7 +140,7 @@ module Make (B : Backend) = struct in Ok pairs | (0, None) -> Ok [] - | _ -> Error (Error.handle_error + | _ -> Error (Error.handle_error rc ("list_relations failed: " ^ branch_name ^ "/" ^ mg_name)) @@ -159,7 +162,7 @@ module Make (B : Backend) = struct in Ok pairs | (0, None) -> Ok [] - | _ -> Error (Error.handle_error + | _ -> Error (Error.handle_error rc ("list_branch_multigroups failed: " ^ branch_name)) let session_open () : (string, Condition.t) result = @@ -169,16 +172,16 @@ module Make (B : Backend) = struct in match (rc, id_opt) with | (0, Some id) -> Ok id - | _ -> Error (Error.handle_error "session_open failed") + | _ -> Error (Error.handle_error rc "session_open failed") let session_close (sid : string) : (unit, Condition.t) result = let rc = Nt_ffi.rnt_session_close sid in - if rc = 0 then Ok () else Error (Error.handle_error "session_close failed") + if rc = 0 then Ok () else Error (Error.handle_error rc "session_close failed") let session_set_branch (sid : string) (branch_name : string) (target_hash : string) : (unit, Condition.t) result = let rc = Nt_ffi.rnt_session_set_branch sid branch_name target_hash in - if rc = 0 then Ok () else Error (Error.handle_error "session_set_branch failed") + if rc = 0 then Ok () else Error (Error.handle_error rc "session_set_branch failed") let open_branch (_claims : claims) (name : string) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = @@ -186,7 +189,7 @@ module Make (B : Backend) = struct ensure_branch path; let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.handle_error ("branch not found: " ^ name)) + | None -> Error (Error.object_not_found "branch" name) | Some bh -> let* _tip = branch_target_of_handle bh in let* rel_entries = list_relations ~branch_name:name ~mg_name:name in @@ -216,7 +219,7 @@ module Make (B : Backend) = struct let close_branch (bh : branch_handle) : (unit, Condition.t) result = let rc = Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh) in - if rc = 0 then Ok () else Error (Error.handle_error "close_branch failed") + if rc = 0 then Ok () else Error (Error.handle_error rc "close_branch failed") let list_snapshot_relations (snapshot_hash : string) : ((string * string) list, Condition.t) result = @@ -235,7 +238,7 @@ module Make (B : Backend) = struct in Ok pairs | (0, None) -> Ok [] - | _ -> Error (Error.handle_error ("list_snapshot_relations failed: " ^ snapshot_hash)) + | _ -> Error (Error.handle_error rc ("list_snapshot_relations failed: " ^ snapshot_hash)) (* Opens a read-only view pinned to a specific snapshot hash. Returns (bh, mg) where bh is a handle on the snapshot object and mg @@ -247,7 +250,7 @@ module Make (B : Backend) = struct let snap_path = "/system/snapshots/" ^ snapshot_hash in let raw = Nt_ffi.rnt_open_handle snap_path (from_voidp void null) in match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.handle_error ("snapshot not found: " ^ snapshot_hash)) + | None -> Error (Error.object_not_found "snapshot" snapshot_hash) | Some bh -> let* rel_entries = list_snapshot_relations snapshot_hash in let mg = @@ -281,12 +284,12 @@ module Make (B : Backend) = struct ignore (Nt_ffi.rnt_register_relation path); let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.handle_error ("relation not found: " ^ rel_name)) + | None -> Error (Error.object_not_found "relation" rel_name) | Some rh -> Ok rh let close_relation (rh : relation_handle) : (unit, Condition.t) result = let rc = Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr rh) in - if rc = 0 then Ok () else Error (Error.handle_error "close_relation failed") + if rc = 0 then Ok () else Error (Error.handle_error rc "close_relation failed") (* -------------------------------------------------------------------------- Query execution via the Tarski VM plan builder @@ -395,12 +398,12 @@ module Make (B : Backend) = struct open_branch claims name let create_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) - ~(branch_name : string) ~(mg_name : string) ~(name : string) - ~(schema : Schema.t) : + ~(branch_name : string) ~(name : string) ~(schema : Schema.t) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = + let mg_name = mg#name in let path = relation_path ~branch_name ~mg_name ~rel_name:name in let rc = Nt_ffi.rnt_register_relation path in - if rc <> 0 then Error (Error.handle_error ("register_relation failed: " ^ name)) + if rc <> 0 then Error (Error.handle_error rc ("register_relation failed: " ^ name)) else let rel_root = let (rc, opt) = @@ -437,7 +440,7 @@ module Make (B : Backend) = struct (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name:rel#name in let rc = Nt_ffi.rnt_clear_relation path in - if rc <> 0 then Error (Error.handle_error ("clear_relation failed: " ^ rel#name)) + if rc <> 0 then Error (Error.handle_error rc ("clear_relation failed: " ^ rel#name)) else let* _tip = branch_target_of_handle bh in Ok (bh, mg) @@ -470,7 +473,7 @@ module Make (B : Backend) = struct ~(body : Constraint.t) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = match mg#get_relation relation_name with - | None -> Error (Error.handle_error ("relation not found: " ^ relation_name)) + | None -> Error (Error.object_not_found "relation" relation_name) | Some rel -> let existing = match rel#constraints with Some cs -> cs | None -> [] @@ -501,7 +504,7 @@ module Make (B : Backend) = struct in match (rc, hash_opt) with | (0, Some h) -> Ok h - | _ -> Error (Error.handle_error "insert_tuple failed") + | _ -> Error (Error.handle_error rc "insert_tuple failed") let create_tuple ~branch_name ~mg_name ~rel_name (tuple : Tuple.materialized) : (string, Condition.t) result = @@ -520,7 +523,7 @@ module Make (B : Backend) = struct (unit, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in let rc = Nt_ffi.rnt_unlink_tuple path hash in - if rc = 0 then Ok () else Error (Error.handle_error "retract_tuple failed") + if rc = 0 then Ok () else Error (Error.handle_error rc "retract_tuple failed") let relation_root ~(branch_name : string) ~(mg_name : string) ~(rel_name : string) : (string, Condition.t) result = @@ -531,7 +534,7 @@ module Make (B : Backend) = struct match (rc, root_opt) with | (0, Some r) -> Ok r | (0, None) -> Ok "" - | _ -> Error (Error.handle_error "relation_root query failed") + | _ -> Error (Error.handle_error rc "relation_root query failed") (* -------------------------------------------------------------------------- Prelude / catalog bootstrap @@ -551,7 +554,7 @@ module Make (B : Backend) = struct (fun acc (name, schema) -> let* (branch_handle, multigroup) = acc in create_relation branch_handle multigroup - ~branch_name ~mg_name ~name ~schema) + ~branch_name ~name ~schema) (Ok (branch_handle, multigroup)) Prelude.Catalog.catalog_definitions in @@ -589,7 +592,7 @@ module Make (B : Backend) = struct ensure_branch path; let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.handle_error "init: could not open master branch") + | None -> Error (Error.object_not_found "branch" "master") | Some bh -> let* target = branch_target_of_handle bh in let result = @@ -598,9 +601,8 @@ module Make (B : Backend) = struct new Management.Multigroup.multigroup ~name:Prelude.Catalog.prelude_mg in - (match seed_prelude ~branch_name:"master" bh mg with - | Ok _ -> Ok () - | Error e -> Error e) + seed_prelude ~branch_name:"master" bh mg + |> Result.map ignore else Ok () in ignore (Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh)); @@ -666,7 +668,7 @@ module type S = sig val get_relation : Management.Multigroup.multigroup -> string -> Relation.ephemeral option val create_multigroup : claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val create_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> name:string -> schema:Schema.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result + val create_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> name:string -> schema:Schema.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result val retract_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result val clear_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> Relation.relation -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result val register_domain : branch_handle -> Management.Multigroup.multigroup -> Relation.domain -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result diff --git a/lib/sublanguage_context.ml b/lib/sublanguage_context.ml index aca5790..39e6dd3 100644 --- a/lib/sublanguage_context.ml +++ b/lib/sublanguage_context.ml @@ -37,3 +37,34 @@ type t = { switch_branch : string -> (Sublanguage_types.transition_delta, Condition.t) result; } + +module Make (NT : Nt.S) = struct + module Session = Session.Make (NT) + module Branch = Branch.Make (NT) + + let make_ctx + (session : Session.session) + (claims : string) + : t = + let br = session#branch in + { + write_handle = br#branch_handle; + branch = (br :> branch_view); + resolve = br#path; + switch_branch = fun name -> + match br#close () with + | Error e -> Error e + | Ok () -> + begin match Branch.open_branch claims name with + | Error e -> + begin match Branch.open_branch claims "master" with + | Ok mbr -> session#set_branch mbr + | Error _ -> () + end; + Error e + | Ok new_br -> + session#set_branch new_br; + Ok new_br#multigroups + end + } +end diff --git a/lib/tuple.ml b/lib/tuple.ml index 24eecab..ffeb3c9 100644 --- a/lib/tuple.ml +++ b/lib/tuple.ml @@ -32,3 +32,6 @@ let make_materialized ~relation ~attributes = attributes; (* lineage = None *) } + +let materialized_equal a b = + AttributeMap.equal Attribute.materialized_equal a.attributes b.attributes |