From 8c56a2250888c529fd14cf97c07317776bb0690d Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 21 May 2026 00:28:51 +0000 Subject: Sketches of a condition system --- lib/condition.ml | 32 ++++++++++++++++++++++++++++++++ lib/envelope.ml | 16 ---------------- lib/listener.ml | 37 +++++++++++++++++++++++++++++-------- lib/manipulation.ml | 25 +++++++++++++++++-------- 4 files changed, 78 insertions(+), 32 deletions(-) create mode 100644 lib/condition.ml delete mode 100644 lib/envelope.ml (limited to 'lib') diff --git a/lib/condition.ml b/lib/condition.ml new file mode 100644 index 0000000..72eb773 --- /dev/null +++ b/lib/condition.ml @@ -0,0 +1,32 @@ + +class type serializable = object + method as_sexp : Sexplib.Sexp.t +end + +class literal (expr : Sexplib.Sexp.t) : serializable = object + method as_sexp = expr +end + +let of_sexp (expr : Sexplib.Sexp.t) = new literal expr +let of_string (s : string) = new literal (Sexplib.Sexp.Atom s) + +type condition = { name : string; properties : (string, serializable) BatMap.t } + +let condition name ?parent props = + { name; + 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 to_sexp { name; properties } = + let open Sexplib.Sexp in + let properties' = + BatMap.to_seq properties + |> BatSeq.map (fun (k, v) -> List [Atom k; v#as_sexp]) + |> BatList.of_seq in + List (Atom name :: properties') 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/listener.ml b/lib/listener.ml index 262a2b9..4b1a0c5 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -9,6 +9,26 @@ functor module Sess = Session.Make (NT) module B = Branch.Make (NT) + module Error = struct + open Condition + + let syntax_error msg = + condition "syntax-error" + ("message" |=| (of_string msg)) + + let unrecognized_sublanguage tag = + condition "unrecognized-sublanguage" + ("tag" |=| (of_string tag)) + + let sublanguage_error expr = (* FIXME: do away with this *) + condition "sublanguage-error" + ("error" |=| (of_sexp expr)) + + let malformed_expression expr = + condition "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 +70,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 +89,18 @@ 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)) + Error.sublanguage_error (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 +118,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 +172,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 (Error.syntax_error (Nt.string_of_error 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 (Error.syntax_error (Nt.string_of_error e)) | Ok sess -> let state = ref { claims; session = sess } in (try diff --git a/lib/manipulation.ml b/lib/manipulation.ml index 55b1c32..f0b5d1c 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -15,7 +15,16 @@ (** 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.condition + + module Error = struct + open Condition + + (* TODO: more specific errors *) + let storage_error message = + condition "storage-error" + ("message" |=| (of_string message)) + end let ( let* ) = Result.bind @@ -27,7 +36,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 +47,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 +77,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 +96,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 +108,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 -- cgit v1.2.3