Sketches of a condition system

4 files changed, 78 insertions, 32 deletions

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