New Server & Manipulation refactor

Co-authored-by: Estevan Castilho <tevo@riajuu.net>

1 files changed, 76 insertions, 71 deletions

diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml
index 8c2fbdc..a651067 100644
--- a/lib/dcl/executor.ml
+++ b/lib/dcl/executor.ml
@@ -4,16 +4,24 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
   module MergeOps = Management.Merge.Make (Storage) (Ops)
 
   type error =
-    | ParseError of string
-    | BranchError of string
-    | MergeError of string
+    | ParseError       of string
+    | BranchError      of Error.t
+    | BranchNotFound   of string
+    | NoDatabaseAtHash of Conventions.Hash.t
+    | StorageError     of string
+    | MergeError       of Error.t
+    | Conflict         of string
 
   let sexp_of_error e =
     let open Sexplib.Sexp in
     match e with
-    | ParseError s -> List [ Atom "parse-error"; Atom s ]
-    | BranchError s -> List [ Atom "branch-error"; Atom s ]
-    | MergeError s -> List [ Atom "merge-error"; Atom s ]
+    | ParseError        s -> List [Atom "parse-error";  Atom s]
+    | BranchError       s -> List [Atom "branch-error"; Error.sexp_of_error s]
+    | BranchNotFound    s -> List [Atom "branch-not-found"; Atom s]
+    | NoDatabaseAtHash  s -> List [Atom "no-database-at-hash"; Atom s]
+    | StorageError      s -> List [Atom "storage-error"; Atom s]
+    | MergeError        s -> List [Atom "merge-error";  Error.sexp_of_error s]
+    | Conflict          s -> List [Atom "conflict"; Atom s]
 
   let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy =
     function
@@ -24,71 +32,68 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
   let execute (storage : Storage.t) (db : Management.Database.t)
       (stmt : Ast.statement) : (Management.Database.t * string, error) result =
     match stmt with
-    | Ast.CreateBranch { name; hash } -> (
-        let tip =
-          match hash with Some h -> h | None -> db.Management.Database.hash
-        in
-        match Branch.create storage ~name ~tip with
-        | Error e -> Error (BranchError e)
-        | Ok () -> Ok (db, "Branch " ^ name ^ " created"))
-    | Ast.Checkout branch_name -> (
-        match Branch.get_tip storage branch_name with
-        | Error e -> Error (BranchError e)
-        | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name))
-        | Ok (Some tip) -> (
-            match Branch.checkout storage branch_name with
-            | Error e -> Error (BranchError e)
-            | Ok () -> (
-                match Ops.load_database storage tip with
-                | Error e ->
-                    Error (BranchError (Manipulation.string_of_error e))
-                | Ok None -> Error (BranchError ("No database at hash: " ^ tip))
-                | Ok (Some loaded_db) -> Ok (loaded_db, "HEAD:" ^ branch_name)))
-        )
-    | Ast.GetHead -> (
-        match Branch.get_head storage with
-        | Error e -> Error (BranchError e)
-        | Ok None -> Ok (db, "HEAD is unset")
-        | Ok (Some name) -> Ok (db, "HEAD:" ^ name))
-    | Ast.GetBranchTip name -> (
-        match Branch.get_tip storage name with
-        | Error e -> Error (BranchError e)
-        | Ok None -> Error (BranchError ("Branch not found: " ^ name))
-        | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash))
-    | Ast.UpdateBranchTip { name; hash } -> (
-        match Branch.update_tip storage ~name ~tip:hash with
-        | Error e -> Error (BranchError e)
-        | Ok () -> Ok (db, "Branch " ^ name ^ " updated"))
-    | Ast.Merge { left; right; strategy } -> (
-        match (Branch.get_tip storage left, Branch.get_tip storage right) with
-        | Error e, _ | _, Error e -> Error (BranchError e)
-        | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left))
-        | _, Ok None -> Error (BranchError ("Branch not found: " ^ right))
-        | Ok (Some left_tip), Ok (Some right_tip) -> (
-            let strat = convert_strategy strategy in
-            match
-              MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip
-            with
-            | Error e -> Error (MergeError (Manipulation.string_of_error e))
-            | Ok (Management.Merge.Failed conflicts) ->
-                let msgs =
-                  List.map
-                    (function
-                      | Management.Merge.TupleConflict { relation; hash } ->
-                          "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
-                      | Management.Merge.SchemaConflict r ->
-                          "schema conflict in " ^ r
-                      | Management.Merge.ConstraintConflict r ->
-                          "constraint conflict in " ^ r)
-                    conflicts
-                in
-                Error (MergeError ("Merge failed: " ^ String.concat "; " msgs))
-            | Ok (Management.Merge.Clean merged_db) ->
-                let _ =
-                  Branch.update_tip storage ~name:left
-                    ~tip:merged_db.Management.Database.hash
-                in
-                Ok (merged_db, "Merged:" ^ right ^ "→" ^ left)))
+    | Ast.CreateBranch { name; hash } ->
+      let tip = match hash with
+        | Some h -> h
+        | None   -> db.Management.Database.hash
+      in
+      (match Branch.create storage ~name ~tip with
+       | Error e -> Error (StorageError e)
+       | Ok ()   -> Ok (db, "Branch " ^ name ^ " created"))
+
+    | Ast.Checkout branch_name ->
+      (match Branch.get_tip storage branch_name with
+       | Error e       -> Error (StorageError e)
+       | Ok None       -> Error (BranchNotFound branch_name)
+       | Ok (Some tip) ->
+         (match Branch.checkout storage branch_name with
+          | Error e -> Error (StorageError e)
+          | Ok ()   ->
+            (match Ops.load_database storage tip with
+             | Error e -> Error (BranchError e)
+             | Ok None -> Error (NoDatabaseAtHash tip)
+             | Ok (Some loaded_db) ->
+               Ok (loaded_db, "HEAD:" ^ branch_name))))
+
+    | Ast.GetHead ->
+      (match Branch.get_head storage with
+       | Error e        -> Error (StorageError e)
+       | Ok None        -> Ok (db, "HEAD is unset")
+       | Ok (Some name) -> Ok (db, "HEAD:" ^ name))
+
+    | Ast.GetBranchTip name ->
+      (match Branch.get_tip storage name with
+       | Error e        -> Error (StorageError e)
+       | Ok None        -> Error (BranchNotFound name)
+       | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash))
+
+    | Ast.UpdateBranchTip { name; hash } ->
+      (match Branch.update_tip storage ~name ~tip:hash with
+       | Error e -> Error (StorageError e)
+       | Ok ()   -> Ok (db, "Branch " ^ name ^ " updated"))
+
+    | Ast.Merge { left; right; strategy } ->
+      (match Branch.get_tip storage left, Branch.get_tip storage right with
+       | Error e, _ | _, Error e -> Error (StorageError e)
+       | Ok None, _  -> Error (BranchNotFound left)
+       | _, Ok None  -> Error (BranchNotFound right)
+       | Ok (Some left_tip), Ok (Some right_tip) ->
+         let strat = convert_strategy strategy in
+         (match MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip with
+          | Error e -> Error (MergeError e)
+          | Ok (Management.Merge.Failed conflicts) ->
+            let msgs = List.map (function
+              | Management.Merge.TupleConflict    { relation; hash } ->
+                "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
+              | Management.Merge.SchemaConflict   r -> "schema conflict in " ^ r
+              | Management.Merge.ConstraintConflict r -> "constraint conflict in " ^ r
+            ) conflicts in
+            Error (Conflict ("Merge failed: " ^ String.concat "; " msgs))
+          | Ok (Management.Merge.Clean merged_db) ->
+            let _ = Branch.update_tip storage ~name:left
+                      ~tip:merged_db.Management.Database.hash in
+            Ok (merged_db,
+                "Merged:" ^ right ^ "→" ^ left)))
 end
 
 module Memory = Make (Management.Physical.Memory)