diff options
Diffstat (limited to '')
36 files changed, 452 insertions, 440 deletions
diff --git a/lib/branch.ml b/lib/branch.ml index 8437d55..0b28663 100644 --- a/lib/branch.ml +++ b/lib/branch.ml @@ -3,6 +3,12 @@ bound to that branch. Each mutation names its target mg explicitly. *) module Make (NT : Nt.S) = struct + module Error = struct + open Condition + (* TODO: more structure *) + let not_supported msg = condition "not-supported" msg empty + let handle_error msg = condition "handle-error" msg empty + end let ( let* ) = Result.bind @@ -68,7 +74,7 @@ module Make (NT : Nt.S) = struct match mode with | Live -> Ok () | Detached _ -> - Error (Nt.NotSupported (op ^ ": detached snapshot is read-only")) + Error (Error.not_supported (op ^ ": detached snapshot is read-only")) method private sync_tip () = match mode with @@ -79,10 +85,10 @@ module Make (NT : Nt.S) = struct | Ok h -> tip <- h method private get_mg op (mg_name : string) : - (Management.Multigroup.multigroup, Nt.error) result = + (Management.Multigroup.multigroup, Condition.t) result = match Hashtbl.find_opt mgs mg_name with | Some mg -> Ok mg - | None -> Error (Nt.HandleError + | None -> Error (Error.handle_error (op ^ ": multigroup not found: " ^ mg_name)) method create_relation ~(mg : string) ~(rel_name : string) ~schema = @@ -104,7 +110,7 @@ module Make (NT : Nt.S) = struct let* () = self#assert_live "clear_relation" in let* mg_val = self#get_mg "clear_relation" mg in match mg_val#get_relation rel_name with - | None -> Error (Nt.HandleError ("relation not found: " ^ rel_name)) + | None -> Error (Error.handle_error ("relation not found: " ^ rel_name)) | Some rel -> let* (bh', mg') = NT.clear_relation bh mg_val diff --git a/lib/condition.ml b/lib/condition.ml new file mode 100644 index 0000000..44ef2ff --- /dev/null +++ b/lib/condition.ml @@ -0,0 +1,49 @@ + +class type serializable = object + method as_sexp : Sexplib.Sexp.t + method as_string : string +end + +class literal (expr : Sexplib.Sexp.t) : serializable = object + method as_sexp = expr + method as_string = Sexplib.Sexp.to_string_hum expr +end + +let of_sexp (expr : Sexplib.Sexp.t) = new literal expr +let of_string (s : string) = new literal (Sexplib.Sexp.Atom s) +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; + properties : (string, serializable) BatMap.t } + +let condition name message ?parent props = + { name; + message; + properties = + parent + |> Option.map (fun { properties; _ } -> properties) + |> Option.value ~default:BatMap.empty + |> props } + +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 open Sexplib.Sexp in + let properties' = + properties + |> BatMap.to_seq + |> BatSeq.map (fun (k, v) -> List [Atom k; v#as_sexp]) + |> BatList.of_seq in + List (Atom name :: Atom message :: properties') + +let to_string { name; message; properties } = + let properties' = + properties + |> BatMap.to_seq + |> BatSeq.to_string ~sep:"\n" (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string) + in + name ^ ": " ^ message ^ properties' diff --git a/lib/configuration.ml b/lib/configuration.ml index 3f66ac0..12a3681 100644 --- a/lib/configuration.ml +++ b/lib/configuration.ml @@ -1,7 +1,35 @@ module type CONFIGURABLE = sig type configuration - val parse : Sexplib.Sexp.t -> (configuration, string) result + val parse : Sexplib.Sexp.t -> (configuration, Condition.t) result +end + +module Error = struct + open Condition + let unknown_section key = condition "unknown-section" "Unknown configuration section" + ("key" |=| (of_string key)) + let duplicate_section key = condition "duplicate-section" "Duplicate configuration section" + ("key" |=| (of_string key)) + let empty_section key = condition "empty-section" "Empty configuration section (expected a tagged value)" + ("key" |=| (of_string key)) + let multiple_values_in_section key = condition "multiple-values-in-section" "Configuration section contains multiple values (expected exactly one)" + ("key" |=| (of_string key)) + let invalid_toplevel toplevel = condition "invalid-toplevel" "Configuration must be a (server ...) s-expression" + ("expression" |=| (of_sexp toplevel)) + let malformed_section expr = condition "malformed-section" "Section must be a (tag ...) s-expression" + ("expression" |=| (of_sexp expr)) + let missing_section name = condition "missing-section" "Missing section in configuration" + ("name" |=| (of_string name)) + let invalid_tag section tag valid_options = condition "invalid-tag" "Invalid tag for section" + ("section" |=| (of_string section) & + "tag" |=| (of_string tag) & + "valid-options" |=| (of_list of_string valid_options)) + let failed_to_load_file path msg = condition "failed-to-load-file" "Failed to load configuration file" + ("path" |=| (of_string path) & + "message" |=| (of_string msg)) + let syntax_error path msg = condition "syntax-error" "Failed to parse configuration file" + ("path" |=| (of_string path) & + "message" |=| (of_string msg)) end type t = Sexplib.Sexp.t Utilities.StringMap.t @@ -10,31 +38,27 @@ type t = Sexplib.Sexp.t Utilities.StringMap.t let find_section (key : string) (config : t) : Sexplib.Sexp.t option = Utilities.StringMap.find_opt key config -let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt - (** Check that [key] is expected and not duplicate, then add it. *) let insert_section ~expected acc key body = let ( let* ) = Result.bind in let* () = if Utilities.StringSet.mem key expected then Ok () - else errorf "Unknown configuration section: %s" key + else Error (Error.unknown_section key) in let* () = if Utilities.StringMap.mem key acc then - errorf "Duplicate configuration section: %s" key + Error (Error.duplicate_section key) else Ok () in match body with | [ subtree ] -> Ok (Utilities.StringMap.add key subtree acc) | [] -> - errorf "Configuration section %s is empty (expected a tagged value)" key + Error (Error.empty_section key) | _ -> - errorf - "Configuration section %s has multiple values (expected exactly one)" - key + Error (Error.multiple_values_in_section key) (** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *) -let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, string) result = +let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) result = let open Sexplib.Sexp in match sexp with | List (Atom "server" :: sections) -> @@ -48,39 +72,38 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, string) result = Result.bind (insert_section ~expected acc key body) (fun acc -> go acc rest) | bad :: _ -> - errorf "Malformed configuration section: %s" (to_string bad) + Error (Error.malformed_section bad) in go Utilities.StringMap.empty sections - | _ -> Error "Configuration must be a (server ...) s-expression" + | _ -> Error (Error.invalid_toplevel sexp) (** Read a file from disk and run [parse_server] on it. *) -let load ~expected_keys (path : string) : (t, string) result = +let load ~expected_keys (path : string) : (t, Condition.t) result = match Sexplib.Sexp.load_sexp path with | sexp -> parse_server ~expected_keys sexp | exception Sys_error msg -> - errorf "Failed to load configuration file %s: %s" path msg + Error (Error.failed_to_load_file path msg) | exception Failure msg -> - errorf "Failed to parse configuration file %s: %s" path msg + Error (Error.syntax_error path msg) (** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *) let extract_tagged_section (sexp : Sexplib.Sexp.t) : - (string * Sexplib.Sexp.t, string) result = + (string * Sexplib.Sexp.t, Condition.t) result = let open Sexplib.Sexp in match sexp with | List (Atom tag :: body) -> Ok (tag, List body) - | _ -> errorf "Expected (tag ...) but got: %s" (to_string sexp) + | _ -> Error (Error.malformed_section sexp) (** Look up a section by name, extract its tag, and check the tag is allowed. *) let require_section ~(name : string) ~(valid_tags : string list) (config : t) : - (string * Sexplib.Sexp.t, string) result = + (string * Sexplib.Sexp.t, Condition.t) result = let ( let* ) = Result.bind in let* sexp = find_section name config - |> Option.to_result - ~none:(Printf.sprintf "Missing (%s ...) section in configuration" name) + |> Option.to_result ~none:(Error.missing_section name) in let* tag, body = extract_tagged_section sexp in let* () = - if List.mem tag valid_tags then Ok () else errorf "Unknown %s: %s" name tag + if List.mem tag valid_tags then Ok () else Error (Error.invalid_tag name tag valid_tags) in Ok (tag, body) diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml index a052ba2..c61b02e 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -1,31 +1,21 @@ module Make (NT : Nt.S) = struct - type error = - | ParseError of string - | NtError of Nt.error - | RelationNotFound of string - | MultigroupNotFound of string - | UnqualifiedName of string - - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] - | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] - | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] - | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] + module Error = struct + open Condition + (* TODO: more structure *) + let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) + let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name)) + end let ( let* ) = Result.bind - let wrap_nt r = Result.map_error (fun e -> NtError e) r - let parse_fqn (s : string) : (Qualified_name.t, error) result = - Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) + let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = + Qualified_name.try_parse s let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : - (Management.Multigroup.multigroup, error) result = + (Management.Multigroup.multigroup, Condition.t) result = match ctx.branch#mg_of mg_name with | Some mg -> Ok mg - | None -> Error (MultigroupNotFound mg_name) + | None -> Error (Error.multigroup_not_found mg_name) let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t = function @@ -38,7 +28,7 @@ module Make (NT : Nt.S) = struct prefix. The executor parses the FQN, resolves the mg in the branch cache, advances it through NT, and returns a single-element delta. *) let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : - (Sublanguage_types.transition_delta * string, error) result = + (Sublanguage_types.transition_delta * string, Condition.t) result = let bh = ctx.write_handle in let branch_name = ctx.branch#name in match stmt with @@ -46,7 +36,7 @@ module Make (NT : Nt.S) = struct ctx.branch#add_multigroup ~name; (match ctx.branch#mg_of name with | Some mg -> Ok ([ (name, mg) ], "Multigroup created: " ^ name) - | None -> Error (MultigroupNotFound name)) + | None -> Error (Error.multigroup_not_found name)) | Ast.CreateRelation { name; schema = schema_pairs } -> let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in @@ -58,7 +48,6 @@ module Make (NT : Nt.S) = struct let* _bh, new_mg = NT.create_relation bh mg ~branch_name ~mg_name:fqn.mg ~name:fqn.name ~schema - |> wrap_nt in ctx.branch#set_mg ~name:fqn.mg new_mg; Ok ([ (fqn.mg, new_mg) ], "Relation created: " ^ name) @@ -66,7 +55,7 @@ module Make (NT : Nt.S) = struct let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in let* _bh, new_mg = - NT.retract_relation bh mg ~name:fqn.name |> wrap_nt + NT.retract_relation bh mg ~name:fqn.name in ctx.branch#set_mg ~name:fqn.mg new_mg; Ok ([ (fqn.mg, new_mg) ], "Relation retracted: " ^ name) @@ -74,12 +63,12 @@ module Make (NT : Nt.S) = struct let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in (match mg#get_relation fqn.name with - | None -> Error (RelationNotFound name) + | None -> Error (Error.relation_not_found name) | Some rel -> let* _bh, new_mg = NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg - (rel :> Relation.relation) |> wrap_nt + (rel :> Relation.relation) in ctx.branch#set_mg ~name:fqn.mg new_mg; Ok ([ (fqn.mg, new_mg) ], "Relation cleared: " ^ name)) @@ -94,7 +83,7 @@ module Make (NT : Nt.S) = struct ~schema:Schema.empty ~provenance:None ~lineage:None ~constraints:None in - let* _bh, new_mg = NT.register_domain bh mg domain |> wrap_nt in + let* _bh, new_mg = NT.register_domain bh mg domain in ctx.branch#set_mg ~name:fqn.mg new_mg; Ok ([ (fqn.mg, new_mg) ], "Domain registered: " ^ name) end diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml index 5678b47..a4df914 100644 --- a/lib/ddl/parser.ml +++ b/lib/ddl/parser.ml @@ -1,13 +1,16 @@ -type error = ParseError of string +module Error = struct + open Condition + let parse_error msg = condition "parse-error" msg empty +end let of_sexp sexp = match Ast.statement_of_sexp sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml index a7910c5..33145c4 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -3,20 +3,14 @@ module Make (NT : Nt.S) = struct type configuration = unit type ast = Ast.statement - type error = Exec.error let name = "ddl" let parse _ = Ok () - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = match Exec.execute ctx ast with | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e - - let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml index 3b18f4b..c35f128 100644 --- a/lib/dml/executor.ml +++ b/lib/dml/executor.ml @@ -1,41 +1,30 @@ module Make (NT : Nt.S) = struct module DrlExec = Drl.Executor.Make (NT) - type error = - | ParseError of string - | NtError of Nt.error - | RelationNotFound of string - | MultigroupNotFound of string - | UnqualifiedName of string - | DrlError of DrlExec.error - - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] - | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] - | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] - | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] - | DrlError e -> List [ Atom "drl-error"; DrlExec.sexp_of_error e ] + module Error = struct + open Condition + (* TODO: more structure *) + let parse_error msg = condition "parse-error" msg empty + let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) + let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name)) + end let ( let* ) = Result.bind - let wrap_nt r = Result.map_error (fun e -> NtError e) r - let parse_fqn (s : string) : (Qualified_name.t, error) result = - Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) + let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = + Qualified_name.try_parse s let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : - (Management.Multigroup.multigroup, error) result = + (Management.Multigroup.multigroup, Condition.t) result = match ctx.branch#mg_of mg_name with | Some mg -> Ok mg - | None -> Error (MultigroupNotFound mg_name) + | None -> Error (Error.multigroup_not_found mg_name) let get_rel (ctx : Sublanguage_context.t) (fqn : Qualified_name.t) = let* mg = lookup_mg ctx fqn.mg in match NT.get_relation mg fqn.name with | Some r -> Ok r - | None -> Error (RelationNotFound (Qualified_name.to_string fqn)) + | None -> Error (Error.relation_not_found (Qualified_name.to_string fqn)) let retarget target (t : Tuple.materialized) = { t with Tuple.relation = target } @@ -54,22 +43,19 @@ module Make (NT : Nt.S) = struct (* Drain all tuples from a DRL query using ctx.resolve for path resolution. Cross-multigroup reads work transparently here. *) let drain_query (ctx : Sublanguage_context.t) query = - match DrlExec.compile ctx.resolve query with - | Error e -> Error (DrlError e) - | Ok plan -> - let* stream = - NT.execute_query plan ~rel_name:"dml_drain" - |> wrap_nt - in - let rec drain acc = - match NT.stream_next stream with - | Error _ -> List.rev acc - | Ok None -> List.rev acc - | Ok (Some t) -> drain (t :: acc) - in - let tuples = drain [] in - ignore (NT.stream_close stream); - Ok tuples + let* plan = DrlExec.compile ctx.resolve query in + let* stream = + NT.execute_query plan ~rel_name:"dml_drain" + in + let rec drain acc = + match NT.stream_next stream with + | Error _ -> List.rev acc + | Ok None -> List.rev acc + | Ok (Some t) -> drain (t :: acc) + in + let tuples = drain [] in + ignore (NT.stream_close stream); + Ok tuples let attr_val_eq a b = Stdlib.( = ) a.Attribute.value b.Attribute.value @@ -93,7 +79,7 @@ module Make (NT : Nt.S) = struct (* DML mutates tuples in a single mg per statement. Returns a single-element transition delta keyed by that mg's name. *) let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : - (Sublanguage_types.transition_delta, error) result = + (Sublanguage_types.transition_delta, Condition.t) result = let bh = ctx.write_handle in let branch_name = ctx.branch#name in let after fqn = Result.bind (lookup_mg ctx fqn.Qualified_name.mg) @@ -106,7 +92,6 @@ module Make (NT : Nt.S) = struct let tuple = build_tuple ~relation:rel#name attributes in let* _ = NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple - |> wrap_nt in after fqn | Ast.InsertTuples { relation; tuples } -> @@ -116,7 +101,6 @@ module Make (NT : Nt.S) = struct let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple_list - |> wrap_nt in after fqn | Ast.DeleteTuple { relation; attributes } -> @@ -126,7 +110,6 @@ module Make (NT : Nt.S) = struct let hash = Hashing.hash_tuple tuple in let* () = NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash - |> wrap_nt in after fqn | Ast.Assign { target; body } -> @@ -136,13 +119,12 @@ module Make (NT : Nt.S) = struct let* tuples = drain_query ctx body in let* _bh, new_mg = NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg - (rel :> Relation.relation) |> wrap_nt + (rel :> Relation.relation) in ctx.branch#set_mg ~name:fqn.mg new_mg; let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name (List.map (retarget rel#name) tuples) - |> wrap_nt in Ok [ (fqn.mg, new_mg) ] | Ast.InsertFrom { target; source } -> @@ -152,7 +134,6 @@ module Make (NT : Nt.S) = struct let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name (List.map (retarget rel#name) tuples) - |> wrap_nt in after fqn | Ast.DeleteWhere { target; predicate } -> @@ -175,8 +156,7 @@ module Make (NT : Nt.S) = struct let* () = acc in let hash = Hashing.hash_tuple (retarget rel#name t) in NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name - hash - |> wrap_nt) + hash) (Ok ()) to_delete in after fqn diff --git a/lib/dml/parser.ml b/lib/dml/parser.ml index 5678b47..a4df914 100644 --- a/lib/dml/parser.ml +++ b/lib/dml/parser.ml @@ -1,13 +1,16 @@ -type error = ParseError of string +module Error = struct + open Condition + let parse_error msg = condition "parse-error" msg empty +end let of_sexp sexp = match Ast.statement_of_sexp sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index a67ec66..9648786 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -3,20 +3,14 @@ module Make (NT : Nt.S) = struct type configuration = unit type ast = Ast.statement - type error = Exec.error let name = "dml" let parse _ = Ok () - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = match Exec.execute ctx ast with | Ok delta -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e - - let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index 20b94b9..5f820c8 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -1,19 +1,11 @@ module Make (NT : Nt.S) = struct - type error = - | ParseError of string - | RelationNotFound of string - | NtError of Nt.error - | UnsupportedOperator of string - | UnqualifiedName of string + module Error = struct + open Condition - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] - | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] - | UnsupportedOperator s -> List [ Atom "unsupported-operator"; Atom s ] - | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] + let parse_error error = condition "parse-error" error empty + let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) + let unsupported_operator msg = condition "unsupported-operator" msg empty + end let ( let* ) = Result.bind @@ -22,12 +14,11 @@ module Make (NT : Nt.S) = struct [resolve] maps an FQN to its absolute RNT path. *) let rec compile (resolve : ?branch:string -> Qualified_name.t -> string) - (q : Ast.query) : (Nt.plan_node, error) result = + (q : Ast.query) : (Nt.plan_node, Condition.t) result = match q with | Ast.Base name -> - (match Qualified_name.try_parse name with - | Error s -> Error (UnqualifiedName s) - | Ok fqn -> Ok (Nt.Scan { path = resolve fqn; args = [] })) + let* fqn = Qualified_name.try_parse name in + Ok (Nt.Scan { path = resolve fqn; args = [] }) | Ast.Join (on_attrs, q1, q2) -> let* p1 = compile resolve q1 in let* p2 = compile resolve q2 in @@ -36,21 +27,19 @@ module Make (NT : Nt.S) = struct let* p = compile resolve q in Ok (Nt.Take { limit = n; source = p }) | Ast.Const _ -> - Error (UnsupportedOperator + Error (Error.unsupported_operator "Const: literal relations not yet reachable by VM; use Base") | _ -> - Error (UnsupportedOperator + Error (Error.unsupported_operator "Select/Project/Rename/Union/Diff/Cartesian require VM operators not yet implemented") let page_limit = 16 let execute (ctx : Sublanguage_context.t) (q : Ast.query) : - (Sublanguage_types.result, error) result = + (Sublanguage_types.result, Condition.t) result = let* plan = compile ctx.resolve q in let rel_name = "query_result" in - let* stream = - NT.execute_query plan ~rel_name - |> Result.map_error (fun e -> NtError e) + let* stream = NT.execute_query plan ~rel_name in let rec drain acc count = if count >= page_limit then (List.rev acc, true) diff --git a/lib/drl/parser.ml b/lib/drl/parser.ml index 76d4b4e..be1f1eb 100644 --- a/lib/drl/parser.ml +++ b/lib/drl/parser.ml @@ -1,13 +1,16 @@ -type error = ParseError of string +module Error = struct + open Condition + let parse_error msg = condition "parse-error" msg empty +end let of_sexp sexp = match Ast.query_of_sexp sexp with | q -> Ok q - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.query_of_sexp with | q -> Ok q - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let to_string q = Ast.sexp_of_query q |> Sexplib.Sexp.to_string_hum diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml index ccc0222..64cd8c0 100644 --- a/lib/drl/sublanguage.ml +++ b/lib/drl/sublanguage.ml @@ -3,17 +3,11 @@ module Make (NT : Nt.S) = struct type configuration = unit type ast = Ast.query - type error = Exec.error let name = "drl" let parse _ = Ok () - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = Exec.execute ctx ast - - let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/envelope.ml b/lib/envelope.ml deleted file mode 100644 index 1c20c5b..0000000 --- a/lib/envelope.ml +++ /dev/null @@ -1,16 +0,0 @@ -(** Envelope parser for tagged S-expressions. - - Parses commands of the form (tag payload...) where the tag selects which - sublanguage handles the payload. The tag set is open — future sublanguages - (tcl, ppl, acl) just add new tags. *) - -type tagged = { tag : string; payload : Sexplib.Sexp.t } - -let parse (input : Sexplib.Sexp.t) : (tagged, Error.t) Result.t = - match input with - | Sexplib.Sexp.List (Sexplib.Sexp.Atom tag :: rest) -> - let payload = - match rest with [ single ] -> single | many -> Sexplib.Sexp.List many - in - Ok { tag; payload } - | s -> Error (Error.MalformedExpression s) diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml index 0a77dff..084fb71 100644 --- a/lib/icl/executor.ml +++ b/lib/icl/executor.ml @@ -1,31 +1,19 @@ module Make (NT : Nt.S) = struct - type error = - | ParseError of string - | NtError of Nt.error - | ConversionError of string - | MultigroupNotFound of string - | UnqualifiedName of string - - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] - | ConversionError s -> List [ Atom "conversion-error"; Atom s ] - | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] - | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] + module Error = struct + open Condition + let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name)) + end let ( let* ) = Result.bind - let wrap_nt = Result.map_error (fun e -> NtError e) - let parse_fqn (s : string) : (Qualified_name.t, error) result = - Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) + let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = + Qualified_name.try_parse s let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : - (Management.Multigroup.multigroup, error) result = + (Management.Multigroup.multigroup, Condition.t) result = match ctx.branch#mg_of mg_name with | Some mg -> Ok mg - | None -> Error (MultigroupNotFound mg_name) + | None -> Error (Error.multigroup_not_found mg_name) let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function @@ -52,7 +40,7 @@ module Make (NT : Nt.S) = struct Constraint.forall ~variable ~quantifier (convert_body body) let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : - (Sublanguage_types.transition_delta * string, error) result = + (Sublanguage_types.transition_delta * string, Condition.t) result = match stmt with | Ast.RegisterConstraint { constraint_name; relation_name; body } -> let* fqn = parse_fqn relation_name in @@ -61,7 +49,6 @@ module Make (NT : Nt.S) = struct let* _bh, new_mg = NT.register_constraint ctx.write_handle mg ~constraint_name ~relation_name:fqn.name ~body:runtime_body - |> wrap_nt in ctx.branch#set_mg ~name:fqn.mg new_mg; Ok ([ (fqn.mg, new_mg) ], "Constraint registered: " ^ constraint_name) diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml index 5678b47..a4df914 100644 --- a/lib/icl/parser.ml +++ b/lib/icl/parser.ml @@ -1,13 +1,16 @@ -type error = ParseError of string +module Error = struct + open Condition + let parse_error msg = condition "parse-error" msg empty +end let of_sexp sexp = match Ast.statement_of_sexp sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index ae2c359..19f15ce 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -3,20 +3,14 @@ module Make (NT : Nt.S) = struct type configuration = unit type ast = Ast.statement - type error = Exec.error let name = "icl" let parse _ = Ok () - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = match Exec.execute ctx ast with | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e - - let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/listener.ml b/lib/listener.ml index 262a2b9..ba61a50 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -9,6 +9,21 @@ functor module Sess = Session.Make (NT) module B = Branch.Make (NT) + module Error = struct + open Condition + + let syntax_error msg = + condition "syntax-error" msg empty + + let unrecognized_sublanguage tag = + condition "unrecognized-sublanguage" "Unrecognized sublanguage" + ("tag" |=| (of_string tag)) + + let malformed_expression expr = + condition "malformed-expression" "Malformed expression" + ("expression" |=| (of_sexp expr)) + end + (** Per-connection state: session owns the active branch. The branch's [relation_path] becomes the context resolver, so all sublanguages address the full RNT namespace rather than a @@ -50,7 +65,7 @@ functor let read_command input = try Ok (Sexplib.Sexp.input_sexp input) with Sexplib.Sexp.Parse_error { err_msg; _ } -> - Error (Error.SyntaxError err_msg) + Error (Error.syntax_error err_msg) let sublanguages = List.fold_right @@ -69,18 +84,16 @@ functor let find_language tag = Utilities.StringMap.find_opt tag sublanguages - |> Option.to_result ~none:(Error.UnrecognizedSublanguage tag) + |> Option.to_result ~none:(Error.unrecognized_sublanguage tag) let execute_sublanguage ctx expr (module Language : SubS) = Language.parse_sexp expr |> Utilities.Result.fmap (Language.execute ctx) - |> Result.map_error (fun e -> - Error.SublanguageError (Language.sexp_of_error e)) let execute_command ctx = function | Sexplib.Sexp.(List [ Atom tag; expr ]) -> find_language tag |> Utilities.Result.fmap (execute_sublanguage ctx expr) - | s -> Error (Error.MalformedExpression s) + | s -> Error (Error.malformed_expression s) let tuple_to_sexp (t : Tuple.materialized) = let open Sexplib.Sexp in @@ -98,14 +111,14 @@ functor let send_error out_ch e = output_response out_ch - Sexplib.Sexp.(List [ Atom "error"; Error.sexp_of_error e ]) + Sexplib.Sexp.(List [ Atom "error"; Condition.to_sexp e ]) (* Serializes a sublanguage result. [branch] is the write target whose tip and name surface in Cursor / Transition responses. *) let serialize (branch : B.branch) = let open Sexplib.Sexp in function - | Error e -> List [ Atom "error"; Error.sexp_of_error e ] + | Error e -> List [ Atom "error"; Condition.to_sexp e ] | Ok (Sublanguage_types.Cursor { cursor_id; rows; has_more }) -> let row_sexps = List.map tuple_to_sexp rows in List @@ -152,11 +165,12 @@ functor let output = T.output connection in match NT.authenticate Nt.PlainText with | Error e -> - send_error output (Error.SyntaxError (Nt.string_of_error e)) + (* FIXME: why is this a syntax error? *) + send_error output e | Ok claims -> (match Sess.open_session claims ~branch_name:"master" with | Error e -> - send_error output (Error.SyntaxError (Nt.string_of_error e)) + send_error output e | Ok sess -> let state = ref { claims; session = sess } in (try diff --git a/lib/management/branch.ml b/lib/management/branch.ml index ea9d525..4ba0983 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -12,7 +12,12 @@ let branch_key name = "branch:" ^ name let head_key = "head" let names_key = "branch_names" -module Make (Storage : Physical.S with type error = string) = struct +module Make (Storage : Physical.S) = struct + module Error = struct + open Condition + let branch_not_found name = condition "branch-not-found" "Branch not found" ("name" |=| (of_string name)) + end + let load_names storage = match Storage.load_raw storage names_key with | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list) @@ -56,7 +61,7 @@ module Make (Storage : Physical.S with type error = string) = struct let record = { name; tip } in let bytes = Marshal.to_bytes record [] in Storage.store_raw storage (branch_key name) bytes - | Ok None -> Error ("Branch not found: " ^ name) + | Ok None -> Error (Error.branch_not_found name) | Error e -> Error e let list storage = @@ -70,7 +75,7 @@ module Make (Storage : Physical.S with type error = string) = struct names in Ok branches -(* +(* let branch_relation storage : Relation.t = let schema = Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string" diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml index f115d97..b908302 100644 --- a/lib/management/multigroup.ml +++ b/lib/management/multigroup.ml @@ -13,6 +13,7 @@ class multigroup ~name:(init_name : Conventions.Name.t) = method relations = relations method timestamp = timestamp + (* TODO: a variant returning (Relation.relation, Condition.t) result *) method get_relation rel_name = BatMap.String.find_opt rel_name relations method get_relation_names = BatMap.String.fold (fun n _ acc -> n :: acc) relations [] method has_relation rel_name = BatMap.String.mem rel_name relations diff --git a/lib/management/physical.ml b/lib/management/physical.ml index 0f26bca..7c6f6b2 100644 --- a/lib/management/physical.ml +++ b/lib/management/physical.ml @@ -12,38 +12,37 @@ module type BACKEND = sig include Configuration.CONFIGURABLE type connection - type error - val connect : configuration -> (connection, error) result + val connect : configuration -> (connection, Condition.t) result (** Connect to the storage backend *) val disconnect : connection -> unit (** Disconnect from the backend *) - val get : connection -> Conventions.Hash.t -> (bytes option, error) result + val get : connection -> Conventions.Hash.t -> (bytes option, Condition.t) result (** Get a value by its hash. Returns None if not found. *) - val put : connection -> Conventions.Hash.t -> bytes -> (unit, error) result + val put : connection -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result (** Store a value at its hash *) - val exists : connection -> Conventions.Hash.t -> (bool, error) result + val exists : connection -> Conventions.Hash.t -> (bool, Condition.t) result (** Check if a hash exists *) - val begin_transaction : connection -> (unit, error) result + val begin_transaction : connection -> (unit, Condition.t) result (** Begin a transaction *) - val commit : connection -> (unit, error) result + val commit : connection -> (unit, Condition.t) result (** Commit a transaction *) - val rollback : connection -> (unit, error) result + val rollback : connection -> (unit, Condition.t) result (** Rollback a transaction *) val get_many : - connection -> Conventions.Hash.t list -> (bytes option list, error) result + connection -> Conventions.Hash.t list -> (bytes option list, Condition.t) result (** Batch get multiple values *) val put_many : - connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result + connection -> (Conventions.Hash.t * bytes) list -> (unit, Condition.t) result (** Batch put multiple values *) end @@ -52,43 +51,41 @@ module type S = sig include Configuration.CONFIGURABLE type t - type error - val create : configuration -> (t, error) result + val create : configuration -> (t, Condition.t) result (** Create a storage instance from a backend connection *) val close : t -> unit (** Close the storage *) val store_attribute : - t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result + t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, Condition.t) result (** Store an attribute value, returns its hash *) val load_attribute : t -> Conventions.Hash.t -> - (Conventions.AbstractValue.t option, error) result + (Conventions.AbstractValue.t option, Condition.t) result (** Load an attribute value by hash *) - val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, error) result + val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result (** Store raw bytes at a hash *) - val load_raw : t -> Conventions.Hash.t -> (bytes option, error) result + val load_raw : t -> Conventions.Hash.t -> (bytes option, Condition.t) result (** Load raw bytes by hash *) - val exists : t -> Conventions.Hash.t -> (bool, error) result + val exists : t -> Conventions.Hash.t -> (bool, Condition.t) result (** Check if a hash exists *) - val with_transaction : t -> (unit -> ('a, error) result) -> ('a, error) result + val with_transaction : t -> (unit -> ('a, Condition.t) result) -> ('a, Condition.t) result (** Execute a function within a transaction *) end (** Functor to create storage operations from a backend *) module Make (B : BACKEND) : - S with type error = B.error and type configuration = B.configuration = struct + S with type configuration = B.configuration = struct type configuration = B.configuration type t = B.connection - type error = B.error let parse = B.parse let create config = B.connect config @@ -123,7 +120,7 @@ end (** In-memory backend for testing and development *) module MemoryBackend : - BACKEND with type error = string and type configuration = unit = struct + BACKEND with type configuration = unit = struct type configuration = unit type connection = { @@ -132,15 +129,22 @@ module MemoryBackend : mutable transaction_buffer : (string * bytes) list; } - type error = string + module Error = struct + open Condition + (* TODO: more structure *) + let parse_error msg = condition "parse-error" msg empty + let already_in_transaction = condition "already-in-transaction" "Already inside a transaction" empty + let not_in_transaction = condition "not-in-transaction" "Not inside a transaction" empty + end let parse sexp = match sexp with | Sexplib.Sexp.List [] -> Ok () | _ -> Error - (Printf.sprintf "memory backend takes no configuration, got: %s" - (Sexplib.Sexp.to_string sexp)) + (Error.parse_error + (Printf.sprintf "memory backend takes no configuration, got: %s" + (Sexplib.Sexp.to_string sexp))) let connect () = Ok @@ -166,7 +170,7 @@ module MemoryBackend : let exists conn hash = Ok (Hashtbl.mem conn.data hash) let begin_transaction conn = - if conn.in_transaction then Error "Already in transaction" + if conn.in_transaction then Error Error.already_in_transaction else begin conn.in_transaction <- true; conn.transaction_buffer <- []; @@ -174,7 +178,7 @@ module MemoryBackend : end let commit conn = - if not conn.in_transaction then Error "Not in transaction" + if not conn.in_transaction then Error Error.not_in_transaction else begin List.iter (fun (hash, value) -> Hashtbl.replace conn.data hash value) @@ -185,7 +189,7 @@ module MemoryBackend : end let rollback conn = - if not conn.in_transaction then Error "Not in transaction" + if not conn.in_transaction then Error Error.not_in_transaction else begin conn.in_transaction <- false; conn.transaction_buffer <- []; diff --git a/lib/manipulation.ml b/lib/manipulation.ml index 55b1c32..e62af28 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -15,7 +15,15 @@ (** Functor to create manipulation operations with a storage backend *) module Make (Storage : Management.Physical.S) = struct type storage = Storage.t - type error = Error.t + type error = Condition.t + + module Error = struct + open Condition + + (* TODO: more specific errors *) + let storage_error message = + condition "storage-error" message empty + end let ( let* ) = Result.bind @@ -27,7 +35,7 @@ module Make (Storage : Management.Physical.S) = struct match Storage.store_raw storage relation#hash (Storable.Relation.to_bytes @@ relation#serialize ()) with - | Error _ -> Error (Error.StorageError "Failed to store relation") + | Error _ -> Error (Error.storage_error "Failed to store relation") | Ok () -> Ok () (** Store a database state to storage. @@ -38,13 +46,13 @@ module Make (Storage : Management.Physical.S) = struct match Storage.store_raw storage db#name (Storable.Multigroup.to_bytes @@ db#serialize ()) with - | Error _ -> Error (Error.StorageError "Failed to store multigroup") + | Error _ -> Error (Error.storage_error "Failed to store multigroup") | Ok () -> Ok () (** Load a relation state from storage by hash *) let load_relation (storage : storage) (rel_hash : Conventions.Hash.t) : (Relation.stored option, error) Result.t = match Storage.load_raw storage rel_hash with - | Error _ -> Error (Error.StorageError "Failed to load relation") + | Error _ -> Error (Error.storage_error "Failed to load relation") | Ok None -> Ok None | Ok (Some bytes) -> let _stored = Storable.Relation.of_bytes bytes in @@ -68,7 +76,7 @@ module Make (Storage : Management.Physical.S) = struct let load_multigroup (storage : storage) (mg_hash : Conventions.Hash.t) : (Management.Multigroup.multigroup option, error) Result.t = match Storage.load_raw storage mg_hash with - | Error _ -> Error (Error.StorageError "Failed to load multigroup") + | Error _ -> Error (Error.storage_error "Failed to load multigroup") | Ok None -> Ok None | Ok (Some bytes) -> (* TODO: Properly deserialize multigroup state *) @@ -87,7 +95,7 @@ module Make (Storage : Management.Physical.S) = struct let load_tuple (storage : storage) (tuple_hash : Conventions.Hash.t) : (Tuple.materialized option, error) Result.t = match Storage.load_raw storage tuple_hash with - | Error _ -> Error (Error.StorageError "Failed to load tuple") + | Error _ -> Error (Error.storage_error "Failed to load tuple") | Ok None -> Ok None | Ok (Some tuple_bytes) -> let _stored = Storable.Tuple.of_bytes tuple_bytes in @@ -99,9 +107,9 @@ module Make (Storage : Management.Physical.S) = struct match Storage.load_raw storage attr_hash with | Error _ -> Error - (Error.StorageError ("Failed to load attribute: " ^ name)) + (Error.storage_error ("Failed to load attribute: " ^ name)) | Ok None -> - Error (Error.StorageError ("Attribute not found: " ^ name)) + Error (Error.storage_error ("Attribute not found: " ^ name)) | Ok (Some value_bytes) -> let value : Conventions.AbstractValue.t = Marshal.from_bytes value_bytes 0 @@ -34,19 +34,15 @@ type plan_node = | Join of { left : plan_node; right : plan_node; on_attrs : string list } | Take of { limit : int; source : plan_node } -type error = - | AuthFailed of string - | HandleError of string - | CursorError of string - | NotSupported of string - | InitializationError - -let string_of_error = function - | AuthFailed s -> "AuthFailed: " ^ s - | HandleError s -> "HandleError: " ^ s - | CursorError s -> "CursorError: " ^ s - | NotSupported s -> "NotSupported: " ^ s - | InitializationError -> "InitializationError" +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 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 +end (* -------------------------------------------------------------------------- Backend selector @@ -73,7 +69,7 @@ module Make (B : Backend) = struct Authentication -------------------------------------------------------------------------- *) - let authenticate (method_ : auth_method) : (claims, error) result = + let authenticate (method_ : auth_method) : (claims, Condition.t) result = let method_str = match method_ with | Certificate -> "certificate" | PlainText -> "plain_text" @@ -83,8 +79,8 @@ module Make (B : Backend) = struct in match (rc, claims_opt) with | (0, Some s) -> Ok s - | (_, Some s) -> Error (AuthFailed s) - | _ -> Error (AuthFailed "firewall rejected connection") + | (_, Some s) -> Error (Error.auth_failed s) + | _ -> Error (Error.auth_failed "firewall rejected connection") (* -------------------------------------------------------------------------- Path helpers (shared by branch and relation lifecycle) @@ -114,7 +110,7 @@ module Make (B : Backend) = struct missing, no-ops when present. *) ignore (Nt_ffi.rnt_register_branch path "") - let branch_target_of_handle (bh : branch_handle) : (string, error) result = + let branch_target_of_handle (bh : branch_handle) : (string, Condition.t) result = let (rc, target_opt) = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_branch_target (Nt_ffi.nint_to_ptr bh) pp) @@ -122,10 +118,10 @@ module Make (B : Backend) = struct match (rc, target_opt) with | (0, Some s) -> Ok s | (0, None) -> Ok "" - | _ -> Error (HandleError "branch_target read failed") + | _ -> Error (Error.handle_error "branch_target read failed") let list_relations ~(branch_name : string) ~(mg_name : string) : - ((string * string) list, error) result = + ((string * string) list, Condition.t) result = let path = multigroup_path ~branch_name ~mg_name in let (rc, out_opt) = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_relations path pp) @@ -141,12 +137,12 @@ module Make (B : Backend) = struct in Ok pairs | (0, None) -> Ok [] - | _ -> Error (HandleError + | _ -> Error (Error.handle_error ("list_relations failed: " ^ branch_name ^ "/" ^ mg_name)) let list_branch_multigroups (branch_name : string) : - ((string * string) list, error) result = + ((string * string) list, Condition.t) result = let path = branch_path branch_name in let (rc, out_opt) = Nt_ffi.with_out_string @@ -163,34 +159,34 @@ module Make (B : Backend) = struct in Ok pairs | (0, None) -> Ok [] - | _ -> Error (HandleError + | _ -> Error (Error.handle_error ("list_branch_multigroups failed: " ^ branch_name)) - let session_open () : (string, error) result = + let session_open () : (string, Condition.t) result = let (rc, id_opt) = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_session_open (from_voidp void null) pp) in match (rc, id_opt) with | (0, Some id) -> Ok id - | _ -> Error (HandleError "session_open failed") + | _ -> Error (Error.handle_error "session_open failed") - let session_close (sid : string) : (unit, error) result = + 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 (HandleError "session_close failed") + if rc = 0 then Ok () else Error (Error.handle_error "session_close failed") let session_set_branch (sid : string) (branch_name : string) - (target_hash : string) : (unit, error) result = + (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 (HandleError "session_set_branch failed") + if rc = 0 then Ok () else Error (Error.handle_error "session_set_branch failed") let open_branch (_claims : claims) (name : string) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let path = branch_path name in 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 (HandleError ("branch not found: " ^ name)) + | None -> Error (Error.handle_error ("branch not found: " ^ name)) | Some bh -> let* _tip = branch_target_of_handle bh in let* rel_entries = list_relations ~branch_name:name ~mg_name:name in @@ -218,12 +214,12 @@ module Make (B : Backend) = struct in Ok (bh, mg) - let close_branch (bh : branch_handle) : (unit, error) result = + 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 (HandleError "close_branch failed") + if rc = 0 then Ok () else Error (Error.handle_error "close_branch failed") let list_snapshot_relations (snapshot_hash : string) : - ((string * string) list, error) result = + ((string * string) list, Condition.t) result = let (rc, out_opt) = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_snapshot_relations snapshot_hash pp) @@ -239,7 +235,7 @@ module Make (B : Backend) = struct in Ok pairs | (0, None) -> Ok [] - | _ -> Error (HandleError ("list_snapshot_relations failed: " ^ snapshot_hash)) + | _ -> Error (Error.handle_error ("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,11 +243,11 @@ module Make (B : Backend) = struct responsible for refusing mutations (see Branch.Detached). *) let open_snapshot (_claims : claims) (branch_name : string) (snapshot_hash : string) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = 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 (HandleError ("snapshot not found: " ^ snapshot_hash)) + | None -> Error (Error.handle_error ("snapshot not found: " ^ snapshot_hash)) | Some bh -> let* rel_entries = list_snapshot_relations snapshot_hash in let mg = @@ -280,17 +276,17 @@ module Make (B : Backend) = struct -------------------------------------------------------------------------- *) let open_relation ~(branch_name : string) ~(mg_name : string) - ~(rel_name : string) : (relation_handle, error) result = + ~(rel_name : string) : (relation_handle, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in 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 (HandleError ("relation not found: " ^ rel_name)) + | None -> Error (Error.handle_error ("relation not found: " ^ rel_name)) | Some rh -> Ok rh - let close_relation (rh : relation_handle) : (unit, error) result = + 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 (HandleError "close_relation failed") + if rc = 0 then Ok () else Error (Error.handle_error "close_relation failed") (* -------------------------------------------------------------------------- Query execution via the Tarski VM plan builder @@ -298,12 +294,12 @@ module Make (B : Backend) = struct (* Recursively builds a C-side PlanWrapper from an OCaml plan_node tree. On partial failure the partially-built plan is freed before returning Error. *) - let rec build_plan (plan : plan_node) : (nativeint, error) result = + let rec build_plan (plan : plan_node) : (nativeint, Condition.t) result = match plan with | Scan { path; _ } -> let raw = Nt_ffi.rnt_plan_scan path in (match Nt_ffi.ptr_to_opt raw with - | None -> Error (CursorError ("plan_scan failed for path: " ^ path)) + | None -> Error (Error.cursor_error ("plan_scan failed for path: " ^ path)) | Some p -> Ok p) | Join { left; right; _ } -> let* lp = build_plan left in @@ -316,7 +312,7 @@ module Make (B : Backend) = struct (Nt_ffi.nint_to_ptr lp) (Nt_ffi.nint_to_ptr rp) in (* join takes ownership of both children — no manual free needed *) (match Nt_ffi.ptr_to_opt raw with - | None -> Error (CursorError "plan_join failed") + | None -> Error (Error.cursor_error "plan_join failed") | Some p -> Ok p)) | Take { limit; source } -> let* sp = build_plan source in @@ -325,15 +321,15 @@ module Make (B : Backend) = struct (Unsigned.Size_t.of_int limit) in (* take takes ownership of source — no manual free needed *) (match Nt_ffi.ptr_to_opt raw with - | None -> Error (CursorError "plan_take failed") + | None -> Error (Error.cursor_error "plan_take failed") | Some p -> Ok p) let execute_query (plan : plan_node) ~(rel_name : string) : - (tuple_stream, error) result = + (tuple_stream, Condition.t) result = let* plan_ptr = build_plan plan in let raw = Nt_ffi.rnt_vm_execute_plan (Nt_ffi.nint_to_ptr plan_ptr) in match Nt_ffi.ptr_to_opt raw with - | None -> Error (CursorError "vm_execute_plan failed") + | None -> Error (Error.cursor_error "vm_execute_plan failed") | Some ts_cursor -> Ok { ts_cursor; ts_relation = rel_name; ts_kind = Vm } let parse_kv_tuple (relation : string) (kv : string) : Tuple.materialized = @@ -352,7 +348,7 @@ module Make (B : Backend) = struct { Tuple.relation; attributes } let stream_next (stream : tuple_stream) : - (Tuple.materialized option, error) result = + (Tuple.materialized option, Condition.t) result = let next_fn = match stream.ts_kind with | Simple -> Nt_ffi.rnt_cursor_next | Vm -> Nt_ffi.rnt_vm_cursor_next @@ -366,15 +362,15 @@ module Make (B : Backend) = struct | 1 -> (match kv_opt with | None -> Ok None | Some kv -> Ok (Some (parse_kv_tuple stream.ts_relation kv))) - | _ -> Error (CursorError "cursor_next error") + | _ -> Error (Error.cursor_error "cursor_next error") - let stream_close (stream : tuple_stream) : (unit, error) result = + let stream_close (stream : tuple_stream) : (unit, Condition.t) result = let close_fn = match stream.ts_kind with | Simple -> Nt_ffi.rnt_cursor_close | Vm -> Nt_ffi.rnt_vm_cursor_close in let rc = close_fn (Nt_ffi.nint_to_ptr stream.ts_cursor) in - if rc = 0 then Ok () else Error (CursorError "cursor_close failed") + if rc = 0 then Ok () else Error (Error.cursor_error "cursor_close failed") (* -------------------------------------------------------------------------- Tuple storage helpers @@ -395,16 +391,16 @@ module Make (B : Backend) = struct -------------------------------------------------------------------------- *) let create_multigroup (claims : claims) (name : string) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = 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_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = 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 (HandleError ("register_relation failed: " ^ name)) + if rc <> 0 then Error (Error.handle_error ("register_relation failed: " ^ name)) else let rel_root = let (rc, opt) = @@ -427,7 +423,7 @@ module Make (B : Backend) = struct let retract_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) ~(name : string) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = (* TODO: there is no rnt_unregister_relation today; the OCaml mg drops the relation but RNT continues to carry it in the current snapshot. This drifts the two views — fine while the in-memory mg is the source of @@ -438,23 +434,23 @@ module Make (B : Backend) = struct let clear_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) ~(branch_name : string) ~(mg_name : string) (rel : Relation.relation) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (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 (HandleError ("clear_relation failed: " ^ rel#name)) + if rc <> 0 then Error (Error.handle_error ("clear_relation failed: " ^ rel#name)) else let* _tip = branch_target_of_handle bh in Ok (bh, mg) let register_domain (_bh : branch_handle) (mg : Management.Multigroup.multigroup) (domain : Relation.domain) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = Ok (_bh, mg#add_relation (domain :> Relation.relation)) let create_immutable_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) ~name ~schema ~generator ~membership_criteria ~cardinality ~(producer : Relation.producer option) : - (branch_handle * Management.Multigroup.multigroup * Relation.relation, error) result = + (branch_handle * Management.Multigroup.multigroup * Relation.relation, Condition.t) result = let rel : Relation.relation = match producer with | Some p -> @@ -472,9 +468,9 @@ module Make (B : Backend) = struct let register_constraint (bh : branch_handle) (mg : Management.Multigroup.multigroup) ~constraint_name ~relation_name ~(body : Constraint.t) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = match mg#get_relation relation_name with - | None -> Error (HandleError ("relation not found: " ^ relation_name)) + | None -> Error (Error.handle_error ("relation not found: " ^ relation_name)) | Some rel -> let existing = match rel#constraints with Some cs -> cs | None -> [] @@ -496,7 +492,7 @@ module Make (B : Backend) = struct let insert_tuple ~(branch_name : string) ~(mg_name : string) ~(rel_name : string) (attrs : (string * string) list) : - (string, error) result = + (string, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in let kv_str = List.map (fun (k, v) -> k ^ "=" ^ v ^ "\n") attrs |> String.concat "" in @@ -505,14 +501,14 @@ module Make (B : Backend) = struct in match (rc, hash_opt) with | (0, Some h) -> Ok h - | _ -> Error (HandleError "insert_tuple failed") + | _ -> Error (Error.handle_error "insert_tuple failed") let create_tuple ~branch_name ~mg_name ~rel_name (tuple : Tuple.materialized) : - (string, error) result = + (string, Condition.t) result = insert_tuple ~branch_name ~mg_name ~rel_name (materialized_to_kv tuple) let create_tuples ~branch_name ~mg_name ~rel_name - (tuples : Tuple.materialized list) : (string, error) result = + (tuples : Tuple.materialized list) : (string, Condition.t) result = List.fold_left (fun acc t -> let* _ = acc in @@ -521,13 +517,13 @@ module Make (B : Backend) = struct (Ok "") tuples let retract_tuple ~branch_name ~mg_name ~rel_name (hash : string) : - (unit, error) result = + (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 (HandleError "retract_tuple failed") + if rc = 0 then Ok () else Error (Error.handle_error "retract_tuple failed") let relation_root ~(branch_name : string) ~(mg_name : string) - ~(rel_name : string) : (string, error) result = + ~(rel_name : string) : (string, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in let (rc, root_opt) = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) @@ -535,7 +531,7 @@ module Make (B : Backend) = struct match (rc, root_opt) with | (0, Some r) -> Ok r | (0, None) -> Ok "" - | _ -> Error (HandleError "relation_root query failed") + | _ -> Error (Error.handle_error "relation_root query failed") (* -------------------------------------------------------------------------- Prelude / catalog bootstrap @@ -548,7 +544,7 @@ module Make (B : Backend) = struct commit step. *) let seed_prelude ~(branch_name : string) (branch_handle : branch_handle) (multigroup : Management.Multigroup.multigroup) : - (branch_handle * Management.Multigroup.multigroup, error) result = + (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let mg_name = multigroup#name in let* (branch_handle, multigroup) = List.fold_left @@ -586,14 +582,14 @@ module Make (B : Backend) = struct discarded — each connection's [open_branch] starts from an empty mg and the caller threads catalog state from there. Persistence of the OCaml-side metadata across process restarts is a separate concern. *) - let initialize () : (unit, error) result = + let initialize () : (unit, Condition.t) result = let runtime_count = Nt_ffi.rnt_init B.driver B.init_arg in - let* () = if runtime_count <> 0 then Error InitializationError else Ok () in + let* () = if runtime_count <> 0 then Error Error.initialization_error else Ok () in let path = "/system/branches/master" in 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 (HandleError "init: could not open master branch") + | None -> Error (Error.handle_error "init: could not open master branch") | Some bh -> let* target = branch_target_of_handle bh in let result = @@ -644,45 +640,45 @@ module Make (B : Backend) = struct end module type S = sig - val initialize : unit -> (unit, error) result - val authenticate : auth_method -> (claims, error) result + val initialize : unit -> (unit, Condition.t) result + val authenticate : auth_method -> (claims, Condition.t) result - val session_open : unit -> (string, error) result - val session_close : string -> (unit, error) result - val session_set_branch : string -> string -> string -> (unit, error) result + val session_open : unit -> (string, Condition.t) result + val session_close : string -> (unit, Condition.t) result + val session_set_branch : string -> string -> string -> (unit, Condition.t) result - val open_branch : claims -> string -> (branch_handle * Management.Multigroup.multigroup, error) result - val open_snapshot : claims -> string -> string -> (branch_handle * Management.Multigroup.multigroup, error) result - val close_branch : branch_handle -> (unit, error) result - val branch_target_of_handle : branch_handle -> (string, error) result + val open_branch : claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result + val open_snapshot : claims -> string -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result + val close_branch : branch_handle -> (unit, Condition.t) result + val branch_target_of_handle : branch_handle -> (string, Condition.t) result - val list_relations : branch_name:string -> mg_name:string -> ((string * string) list, error) result - val list_branch_multigroups : string -> ((string * string) list, error) result - val list_snapshot_relations : string -> ((string * string) list, error) result + val list_relations : branch_name:string -> mg_name:string -> ((string * string) list, Condition.t) result + val list_branch_multigroups : string -> ((string * string) list, Condition.t) result + val list_snapshot_relations : string -> ((string * string) list, Condition.t) result - val open_relation : branch_name:string -> mg_name:string -> rel_name:string -> (relation_handle, error) result - val close_relation : relation_handle -> (unit, error) result + val open_relation : branch_name:string -> mg_name:string -> rel_name:string -> (relation_handle, Condition.t) result + val close_relation : relation_handle -> (unit, Condition.t) result - val execute_query : plan_node -> rel_name:string -> (tuple_stream, error) result - val stream_next : tuple_stream -> (Tuple.materialized option, error) result - val stream_close : tuple_stream -> (unit, error) result + val execute_query : plan_node -> rel_name:string -> (tuple_stream, Condition.t) result + val stream_next : tuple_stream -> (Tuple.materialized option, Condition.t) result + val stream_close : tuple_stream -> (unit, Condition.t) result val get_relation : Management.Multigroup.multigroup -> string -> Relation.ephemeral option - val create_multigroup : claims -> string -> (branch_handle * Management.Multigroup.multigroup, error) 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, error) result - val retract_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> (branch_handle * Management.Multigroup.multigroup, error) result - val clear_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> Relation.relation -> (branch_handle * Management.Multigroup.multigroup, error) result - val register_domain : branch_handle -> Management.Multigroup.multigroup -> Relation.domain -> (branch_handle * Management.Multigroup.multigroup, error) result - val create_immutable_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> schema:Schema.t -> generator:Generator.t -> membership_criteria:(Tuple.t -> bool) -> cardinality:Conventions.Cardinality.t -> producer:Relation.producer option -> (branch_handle * Management.Multigroup.multigroup * Relation.relation, error) result - val register_constraint : branch_handle -> Management.Multigroup.multigroup -> constraint_name:string -> relation_name:string -> body:Constraint.t -> (branch_handle * Management.Multigroup.multigroup, error) result + 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 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 + val create_immutable_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> schema:Schema.t -> generator:Generator.t -> membership_criteria:(Tuple.t -> bool) -> cardinality:Conventions.Cardinality.t -> producer:Relation.producer option -> (branch_handle * Management.Multigroup.multigroup * Relation.relation, Condition.t) result + val register_constraint : branch_handle -> Management.Multigroup.multigroup -> constraint_name:string -> relation_name:string -> body:Constraint.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val create_tuple : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized -> (string, error) result - val create_tuples : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized list -> (string, error) result - val retract_tuple : branch_name:string -> mg_name:string -> rel_name:string -> string -> (unit, error) result + val create_tuple : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized -> (string, Condition.t) result + val create_tuples : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized list -> (string, Condition.t) result + val retract_tuple : branch_name:string -> mg_name:string -> rel_name:string -> string -> (unit, Condition.t) result - val insert_tuple : branch_name:string -> mg_name:string -> rel_name:string -> (string * string) list -> (string, error) result - val relation_root : branch_name:string -> mg_name:string -> rel_name:string -> (string, error) result + val insert_tuple : branch_name:string -> mg_name:string -> rel_name:string -> (string * string) list -> (string, Condition.t) result + val relation_root : branch_name:string -> mg_name:string -> rel_name:string -> (string, Condition.t) result end module Sqlite = Make (struct diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml index 0ccaf22..fcd4ec0 100644 --- a/lib/prl/executor.ml +++ b/lib/prl/executor.ml @@ -1,22 +1,14 @@ module Make (NT : Nt.S) = struct - type error = - | ParseError of string - | RuntimeError of string - | NtError of Nt.error - | UnknownPluginSymbol of string - | RelationNotFound of string - - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | RuntimeError s -> List [ Atom "runtime-error"; Atom s ] - | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] - | UnknownPluginSymbol s -> List [ Atom "unknown-plugin-symbol"; Atom s ] - | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + module Error = struct + open Condition + (* TODO: more structure *) + let parse_error msg = condition "parse-error" msg empty + let runtime_error msg = condition "runtime-error" msg empty + let unknown_plugin_symbol name = condition "unknown-plugin-symbol" "Unknown plugin" ("name" |=| (of_string name)) + let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) + end let ( let* ) = Result.bind - let _map_nt r = Result.map_error (fun e -> NtError e) r (* TODO: PRL function predicates are OCaml shared-library callbacks that produce tuples at runtime. To make their output joinable inside the @@ -26,17 +18,17 @@ module Make (NT : Nt.S) = struct yet exist. Disable PRL execution until that bridge is in place. *) let execute (_ctx : Sublanguage_context.t) (_stmt : Ast.statement) : - (Sublanguage_types.result, error) result = - Error (RuntimeError + (Sublanguage_types.result, Condition.t) result = + Error (Error.runtime_error "PRL execution is temporarily disabled pending VM callback-cursor support") let _execute_load_library _ctx _path = - Error (RuntimeError "PRL disabled") + Error (Error.runtime_error "PRL disabled") let _execute_define_function_predicate _ctx (_spec : Ast.function_predicate) = let* _ = Ok () in - Error (RuntimeError "PRL disabled") + Error (Error.runtime_error "PRL disabled") let _execute_list_function_predicates _ctx = - Error (RuntimeError "PRL disabled") + Error (Error.runtime_error "PRL disabled") end diff --git a/lib/prl/parser.ml b/lib/prl/parser.ml index 17102a4..2567eea 100644 --- a/lib/prl/parser.ml +++ b/lib/prl/parser.ml @@ -1,4 +1,7 @@ -type error = ParseError of string +module Error = struct + open Condition + let parse_error msg = condition "parse-error" msg empty +end let of_sexp sexp = let sexp = @@ -6,7 +9,7 @@ let of_sexp sexp = in match Ast.statement_of_sexp sexp with | stmt -> Ok stmt - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) let of_string s = of_sexp (Sexplib.Sexp.of_string s) let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/prl/sublanguage.ml b/lib/prl/sublanguage.ml index 96891a9..387da34 100644 --- a/lib/prl/sublanguage.ml +++ b/lib/prl/sublanguage.ml @@ -3,16 +3,11 @@ module Make (NT : Nt.S) = struct type configuration = unit type ast = Ast.statement - type error = Exec.error let name = "prl" let parse _ = Ok () - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + let parse_sexp sexp = Parser.of_sexp sexp let execute = Exec.execute - let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml index 47134c8..a67f815 100644 --- a/lib/qualified_name.ml +++ b/lib/qualified_name.ml @@ -13,6 +13,12 @@ type t = { mg : string; name : string } +module Error = struct + open Condition + let unqualified_name name = condition "unqualified-name" "A qualified name was expected, but an unqualified one was given" + ("name" |=| (of_string name)) +end + exception Unqualified of string let parse (s : string) : t = @@ -24,8 +30,8 @@ let parse (s : string) : t = if mg = "" || name = "" then raise (Unqualified s) else { mg; name } -let try_parse (s : string) : (t, string) result = - try Ok (parse s) with Unqualified s -> Error s +let try_parse (s : string) : (t, Condition.t) result = + try Ok (parse s) with Unqualified s -> Error (Error.unqualified_name s) let make ~mg ~name = { mg; name } diff --git a/lib/qualified_name.mli b/lib/qualified_name.mli index 196dfbd..0e39ff2 100644 --- a/lib/qualified_name.mli +++ b/lib/qualified_name.mli @@ -11,7 +11,7 @@ val parse : string -> t (** Splits on the first [:]. Raises [Unqualified] when no mg segment is present (i.e. no colon, or empty mg / empty name). *) -val try_parse : string -> (t, string) result +val try_parse : string -> (t, Condition.t) result val make : mg:string -> name:string -> t diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml index 6848091..e40fde6 100644 --- a/lib/scl/executor.ml +++ b/lib/scl/executor.ml @@ -13,28 +13,22 @@ type exec_result = module Make (NT : Nt.S) = struct module DrlExec = Drl.Executor.Make (NT) - type error = - | ParseError of string - | QueryError of DrlExec.error - | CursorError of string - - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | QueryError e -> DrlExec.sexp_of_error e - | CursorError s -> List [ Atom "cursor-error"; Atom s ] + module Error = struct + open Condition + (* TODO: more structure *) + let cursor_error msg = condition "cursor-error" msg empty + end let ( let* ) = Result.bind let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : - (exec_result, error) result = + (exec_result, Condition.t) result = ignore default_batch; match stmt with | Ast.Begin _ -> - Error (CursorError "cursors not yet implemented") + Error (Error.cursor_error "cursors not yet implemented") | Ast.Fetch _ -> - Error (CursorError "cursors not yet implemented") + Error (Error.cursor_error "cursors not yet implemented") | Ast.Close _ -> let* () = Ok () in Ok (Closed ctx.branch#multigroups) diff --git a/lib/scl/parser.ml b/lib/scl/parser.ml index 3e9c4ed..53719ee 100644 --- a/lib/scl/parser.ml +++ b/lib/scl/parser.ml @@ -1,19 +1,22 @@ -type error = ParseError of string +module Error = struct + open Condition + let parse_error msg = condition "parse-error" msg empty +end let validate = function | (Ast.Begin { limit = Some limit; _ } | Ast.Fetch { limit = Some limit; _ }) when limit <= 0 -> - Error (ParseError "The provision of `limit` is expected to be positive.") + Error (Error.parse_error "The provision of `limit` is expected to be positive.") | stmt -> Ok stmt let of_sexp sexp = match Ast.statement_of_sexp sexp with - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) | stmt -> validate stmt let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with - | exception exn -> Error (ParseError (Printexc.to_string exn)) + | exception exn -> Error (Error.parse_error (Printexc.to_string exn)) | stmt -> validate stmt let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index 87e4d42..0793211 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -3,15 +3,11 @@ module Make (NT : Nt.S) = struct type configuration = unit type ast = Ast.statement - type error = Exec.error let name = "scl" let parse _ = Ok () - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = Exec.execute ctx ast @@ -19,6 +15,4 @@ module Make (NT : Nt.S) = struct | Executor.Batch { cursor_id; rows; has_more } -> Sublanguage_types.Cursor { cursor_id; rows; has_more } | Executor.Closed delta -> Sublanguage_types.Transition delta) - - let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml index e8e511c..e5846ed 100644 --- a/lib/sublanguage.ml +++ b/lib/sublanguage.ml @@ -20,12 +20,9 @@ module type S = sig include Configuration.CONFIGURABLE type ast - type error val name : string - val parse_sexp : Sexplib.Sexp.t -> (ast, error) Result.t + val parse_sexp : Sexplib.Sexp.t -> (ast, Condition.t) Result.t - val execute : Sublanguage_context.t -> ast -> (result, error) Result.t - - val sexp_of_error : error -> Sexplib.Sexp.t + val execute : Sublanguage_context.t -> ast -> (result, Condition.t) Result.t end diff --git a/lib/sublanguage_context.ml b/lib/sublanguage_context.ml index c7598f1..aca5790 100644 --- a/lib/sublanguage_context.ml +++ b/lib/sublanguage_context.ml @@ -35,5 +35,5 @@ type t = { branch : branch_view; resolve : ?branch:string -> Qualified_name.t -> string; switch_branch : string -> - (Sublanguage_types.transition_delta, Nt.error) result; + (Sublanguage_types.transition_delta, Condition.t) result; } diff --git a/lib/system.ml b/lib/system.ml index bad6c3b..56a5440 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -9,14 +9,21 @@ type transport_parcel = (module Transport.TRANSPORT with type t = 't) * 't -> transport_parcel -type nt_provider = Sexplib.Sexp.t -> (nt_parcel, string) result -type transport_provider = Sexplib.Sexp.t -> (transport_parcel, string) result +type nt_provider = Sexplib.Sexp.t -> (nt_parcel, Condition.t) result +type transport_provider = Sexplib.Sexp.t -> (transport_parcel, Condition.t) result type registry = { nt : nt_provider Utilities.StringMap.t; transport : transport_provider Utilities.StringMap.t; } +module Error = struct + open Condition + let unknown_backend component tag = condition "unknown-backend" "Unknown backend for component" + ("component" |=| (of_string component) & + "tag" |=| (of_string tag)) +end + let registry : registry = let open Utilities.StringMap in { @@ -44,7 +51,7 @@ let registry : registry = Ok (TransportParcel ((module Transport.TCP), transport))); } -let assemble (config : Configuration.t) : (unit -> unit, string) result = +let assemble (config : Configuration.t) : (unit -> unit, Condition.t) result = let open Utilities.Result in let* nt_tag, nt_body = Configuration.require_section ~name:"nt" @@ -54,7 +61,7 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result = let* nt_provider = Utilities.StringMap.find_opt nt_tag registry.nt |> Option.to_result - ~none:(Printf.sprintf "Unknown NT backend: %s" nt_tag) + ~none:(Error.unknown_backend "nt" nt_tag) in let* packed_nt = nt_provider nt_body in let* transport_tag, transport_body = @@ -66,16 +73,16 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result = let* transport_provider = Utilities.StringMap.find_opt transport_tag registry.transport |> Option.to_result - ~none:(Printf.sprintf "Unknown transport backend: %s" transport_tag) + ~none:(Error.unknown_backend "transport" transport_tag) in let* packed_transport = transport_provider transport_body in let (NtParcel (module NT)) = packed_nt in let (TransportParcel ((module T), transport)) = packed_transport in - let* () = NT.initialize () |> Result.map_error Nt.string_of_error in + let* () = NT.initialize () in let module L = Listener.Make (T) (NT) in Ok (fun () -> L.run transport) -let run_from_config (path : string) : (unit -> unit, string) result = +let run_from_config (path : string) : (unit -> unit, Condition.t) result = let ( let* ) = Result.bind in let* config = Configuration.load ~expected_keys:[ "nt"; "transport" ] path diff --git a/lib/transport.ml b/lib/transport.ml index b541e16..4ed9743 100644 --- a/lib/transport.ml +++ b/lib/transport.ml @@ -20,6 +20,12 @@ module TCP : TRANSPORT = struct type t = Unix.file_descr type connection = Unix.file_descr + module Error = struct + open Condition + (* TODO: more structure *) + let parse_error msg = condition "parse-error" msg empty + end + let sockaddr_of_fields = function | `Inet (addr, port) -> Ok @@ -50,8 +56,8 @@ module TCP : TRANSPORT = struct | bad :: _ -> errorf "transport/tcp: unexpected: %s" (to_string bad) in match sexp with - | List children -> go None None None children - | _ -> Error "transport/tcp: expected a list of fields" + | List children -> go None None None children |> Result.map_error Error.parse_error + | _ -> Error (Error.parse_error "transport/tcp: expected a list of fields") let string_of_sockaddr = function | Unix.ADDR_INET (host, port) -> diff --git a/lib/vcl/executor.ml b/lib/vcl/executor.ml index 5f3dd49..4ac5eff 100644 --- a/lib/vcl/executor.ml +++ b/lib/vcl/executor.ml @@ -1,21 +1,11 @@ module Make (NT : Nt.S) = struct - type error = - | ParseError of string - | NtError of Nt.error - - let sexp_of_error e = - let open Sexplib.Sexp in - match e with - | ParseError s -> List [ Atom "parse-error"; Atom s ] - | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] - let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : - (Sublanguage_types.result, error) result = + (Sublanguage_types.result, Condition.t) result = match stmt with | Ast.Use branch_name -> - match ctx.switch_branch branch_name with - | Ok delta -> Ok (Sublanguage_types.Transition delta) - | Error e -> Error (NtError e) + Result.map + (fun delta -> Sublanguage_types.Transition delta) + (ctx.switch_branch branch_name) let _ = (module NT : Nt.S) end diff --git a/lib/vcl/sublanguage.ml b/lib/vcl/sublanguage.ml index f9ca629..4319eb8 100644 --- a/lib/vcl/sublanguage.ml +++ b/lib/vcl/sublanguage.ml @@ -1,9 +1,13 @@ module Make (NT : Nt.S) = struct + module Error = struct + open Condition + let unrecognized_command expr = condition "unrecognized-command" "Unrecognized command" ("expression" |=| (of_sexp expr)) + end + module Exec = Executor.Make (NT) type configuration = unit type ast = Ast.statement - type error = Exec.error let name = "vcl" let parse _ = Ok () @@ -11,9 +15,7 @@ module Make (NT : Nt.S) = struct let parse_sexp = function | Sexplib.Sexp.(List [ Atom "use"; Atom branch ]) -> Ok (Ast.Use branch) | sexp -> - Error (Exec.ParseError ("unrecognized vcl command: " ^ Sexplib.Sexp.to_string sexp)) + Error (Error.unrecognized_command sexp) let execute = Exec.execute - - let sexp_of_error = Exec.sexp_of_error end |