new shrunk API for RNT on sakura

1 files changed, 231 insertions, 0 deletions

diff --git a/lib/RNT.ml b/lib/RNT.ml
new file mode 100644
index 0000000..173d09a
--- /dev/null
+++ b/lib/RNT.ml
@@ -0,0 +1,231 @@
+open Utilities.Result
+module S = Rnt.Backend.Storage.LMDB
+module C = Rnt.Concepts
+module P = Rnt.Protocols
+module K = Rnt.Kernel
+module FOL = Rnt.Evaluators.FOL
+module I = K.Initialization.Make (S)
+module B = K.Branch.Make (S)
+module M = K.Multigroup.Make (S)
+module SI = K.Storage.Make (S)
+module SR = K.SubstantialRelation.Make (S)
+module T = K.Tuple.Make (S)
+
+module Error = struct
+  open Condition
+
+  let of_kernel c =
+    condition "kernel-condition" "RNT signalled a condition"
+      ("report" |=| Value.String (C.Condition.to_string_hum c))
+
+  let invalid_path path =
+    condition "invalid-path" "A path must start at \\ and have no empty segments"
+      ("path" |=| Value.String path)
+
+  let unnamed path =
+    condition "unnamed-object" "The path does not name an object under a container"
+      ("path" |=| Value.String path)
+
+  let conflict path =
+    condition "binding-conflict"
+      "The path did not hold what was expected when the change was applied"
+      ("path" |=| Value.String path)
+
+  let unavailable path =
+    condition "unavailable-object" "The object refused a new reference"
+      ("path" |=| Value.String path)
+
+  let heading_mismatch path =
+    condition "heading-mismatch" "A tuple does not conform to the heading of its relation"
+      ("path" |=| Value.String path)
+
+  let not_a_relation name =
+    condition "not-a-relation" "The object does not describe itself as a relation"
+      ("object" |=| Value.String name)
+end
+
+type kernel = {connection: S.connection; root: P.Handle.t}
+type handle = P.Handle.t
+type path = string
+type tuple = {type_: string; attributes: Value.t Utilities.StringMap.t}
+type batch = {tuples: tuple list; exhausted: bool}
+
+type blueprint =
+  | Namespace
+  | Branch
+  | Multigroup
+  | Relation of {heading: string Utilities.StringMap.t; tuples: Value.t Utilities.StringMap.t list}
+
+type plan = Base of path | Project of plan * string list
+
+let lift r = Result.map_error Error.of_kernel r
+let value_of : C.Value.value -> Value.t = function String s -> String s | Integer n -> Integer n
+
+let kernel_value_of : Value.t -> C.Value.value = function
+  | String s -> String s
+  | Integer n -> Integer n
+
+let tuple_of ({type_; attributes} : C.Tuple.t) =
+  { type_;
+    attributes=
+      BatMap.String.fold
+        (fun name value -> Utilities.StringMap.add name (value_of value))
+        attributes Utilities.StringMap.empty }
+
+let segments_of path =
+  match String.split_on_char '\\' path with
+  | [""; ""] -> Ok []
+  | "" :: (_ :: _ as segments) when not (List.mem "" segments) -> Ok segments
+  | _ -> Error (Error.invalid_path path)
+
+let named path =
+  let* segments = segments_of path in
+  match List.rev segments with
+  | name :: parent -> Ok (List.rev parent, name)
+  | [] -> Error (Error.unnamed path)
+
+let using {root; _} segments f =
+  match segments with
+  | [] -> f root
+  | _ ->
+      let* handle = K.Path.lookup root (List.fold_right K.Path.( @/ ) segments K.Path.this) in
+      Fun.protect ~finally:(fun () -> P.Handle.release handle) (fun () -> f handle)
+
+let rec update kernel segments name reference value =
+  using kernel segments (fun target ->
+      match P.Registry.from target, List.rev segments with
+      | Some registry, _ -> P.Registry.update registry name reference value
+      | None, [] -> P.Handle.require P.Registry.from target |> Result.map (Fun.const false)
+      | None, last :: parent ->
+          let* directory = P.Handle.require P.Directory.from target in
+          let* present = P.Directory.find directory name in
+          Option.iter P.Handle.release present;
+          if Option.is_some present <> Option.is_some reference then Ok false
+          else
+            let* associative = P.Handle.require P.Associative.from target in
+            let* derived = P.Associative.update associative name value in
+            update kernel (List.rev parent) last (Some target) (Some (P.Handle.from derived)) )
+
+let store_relation connection name heading tuples =
+  SI.with_transaction connection (fun tx ->
+      let* schematics =
+        C.Encoding.Bencode.(
+          Dict (Utilities.StringMap.bindings heading |> List.map (fun (a, d) -> a, String d))
+          |> to_blob )
+        |> SI.store_blob tx
+      in
+      let* _ = SR.TupleSet.empty_under tx in
+      let* node =
+        SR.TupleSet.with_batch tx (fun () ->
+            List.fold_left
+              (fun node attributes ->
+                let* node = node in
+                let tuple =
+                  { C.Tuple.type_= name;
+                    attributes=
+                      Utilities.StringMap.fold
+                        (fun a v -> BatMap.String.add a (kernel_value_of v))
+                        attributes BatMap.String.empty }
+                in
+                SR.TupleSet.insert tx (C.Tuple.hash tuple) tuple node )
+              (Ok SR.TupleSet.empty) tuples )
+      in
+      let relation = {SR.schematics; tuples= SR.TupleSet.hash_of node} in
+      let* _ = SI.store_blob tx (SR.encode relation) in
+      Ok relation )
+  |> fmap (SR.load connection)
+
+let conforms heading attributes =
+  Utilities.StringMap.(
+    equal String.equal heading (map (fun v -> T.Attribute.domain (kernel_value_of v)) attributes) )
+
+let make {connection; _} path name = function
+  | Namespace -> Ok (K.Namespace.make ())
+  | Branch -> B.make connection |> lift
+  | Multigroup -> M.make connection |> lift
+  | Relation {heading; tuples} ->
+      if List.for_all (conforms heading) tuples then
+        store_relation connection name heading tuples |> lift
+      else Error (Error.heading_mismatch path)
+
+let initialize configuration =
+  let* connection = S.connect (C.Configuration.term_of_sexp configuration) |> lift in
+  (let* root = I.initialize ~evaluators:["fol", FOL.make ()] connection in
+   let* _ = K.Path.(update root this "session" None (Some (K.Namespace.make ()))) in
+   Ok {connection; root} )
+  |> Result.map_error (fun c -> S.disconnect connection; Error.of_kernel c)
+
+let shutdown {connection; _} = S.disconnect connection
+
+let list kernel path =
+  let* segments = segments_of path in
+  using kernel segments (fun handle ->
+      let* directory = P.Handle.require P.Directory.from handle in
+      P.Directory.list directory )
+  |> lift
+  |> Result.map BatFingerTree.to_list
+
+let lookup kernel path =
+  let* segments = segments_of path in
+  let* handle = using kernel segments (fun handle -> Ok (P.Handle.copy handle)) |> lift in
+  Option.to_result ~none:(Error.unavailable path) handle
+
+let create kernel path blueprint =
+  let* parent, name = named path in
+  let* value = make kernel path name blueprint in
+  let* bound = update kernel parent name None (Some value) |> lift in
+  if bound then Ok () else Error (Error.conflict path)
+
+let remove kernel path =
+  let* parent, name = named path in
+  let* current = lookup kernel path in
+  let removed = update kernel parent name (Some current) None in
+  P.Handle.release current;
+  let* removed = lift removed in
+  if removed then Ok () else Error (Error.conflict path)
+
+let release = P.Handle.release
+let identity handle = P.Handle.hash handle |> C.Hash.to_hum_string
+
+let describe handle =
+  lift
+    (let* schematics = P.Handle.require P.Schematics.from handle in
+     P.Schematics.describe schematics )
+  |> fmap (function
+    | P.Schematics.Relation description ->
+        Ok
+          (BatMap.String.fold
+             (fun name {P.Schematics.domain; _} -> Utilities.StringMap.add name domain)
+             description Utilities.StringMap.empty )
+    | _ -> Error (Error.not_a_relation (P.Handle.to_string handle)) )
+
+let rec fol_plan kernel = function
+  | Base path ->
+      let* relation = lookup kernel path in
+      Ok (FOL.Base relation, [relation])
+  | Project (plan, attributes) ->
+      let* plan, relations = fol_plan kernel plan in
+      Ok (FOL.Project (plan, BatFingerTree.of_list attributes), relations)
+
+let execute kernel plan =
+  let* plan, relations = fol_plan kernel plan in
+  let program = FOL.program plan in
+  Fun.protect
+    ~finally:(fun () -> List.iter P.Handle.release (program :: relations))
+    (fun () ->
+      using kernel ["evaluator"; "fol"] (fun evaluator ->
+          let* evaluator = P.Evaluator.require evaluator in
+          P.Evaluator.invoke evaluator program )
+      |> lift )
+
+let enumerate handle =
+  lift
+    (let* enumerable = P.Enumerable.require handle in
+     P.Enumerable.enumerate enumerable )
+
+let fetch cursor limit =
+  lift
+    (let* scan = P.Cursor.require cursor in
+     P.Cursor.fetch scan limit )
+  |> Result.map (fun ({tuples; exhausted} : P.Cursor.batch) ->
+      {tuples= BatFingerTree.to_list tuples |> List.map tuple_of; exhausted} )