1 files changed, 39 insertions, 6 deletions

diff --git a/lib/RNT.ml b/lib/RNT.ml
index 173d09a..353621f 100644
--- a/lib/RNT.ml
+++ b/lib/RNT.ml
@@ -10,13 +10,21 @@ 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 Sess = K.Session.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 report = C.Condition.to_string_hum c in
+    let report =
+      match BatString.Exceptionless.split report ~by:"\n\nBacktrace:" with
+      | Some (report, _) -> report
+      | None -> report
+    in
+    condition "kernel-condition"
+      (BatString.nreplace ~str:(BatString.trim report) ~sub:"\n\t" ~by:"; ")
+      empty
 
   let invalid_path path =
     condition "invalid-path" "A path must start at \\ and have no empty segments"
@@ -55,8 +63,10 @@ type blueprint =
   | Branch
   | Multigroup
   | Relation of {heading: string Utilities.StringMap.t; tuples: Value.t Utilities.StringMap.t list}
+  | Session of string
 
 type plan = Base of path | Project of plan * string list
+type session = {branch: string; snapshot: string}
 
 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
@@ -139,7 +149,12 @@ 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
+let pinned kernel branch =
+  using kernel ["branch"; branch] (fun handle ->
+      let* addressable = P.Handle.require P.Addressable.from handle in
+      Ok {P.Session.branch; snapshot= P.Addressable.address addressable} )
+
+let make ({connection; _} as kernel) path name = function
   | Namespace -> Ok (K.Namespace.make ())
   | Branch -> B.make connection |> lift
   | Multigroup -> M.make connection |> lift
@@ -147,12 +162,14 @@ let make {connection; _} path name = function
       if List.for_all (conforms heading) tuples then
         store_relation connection name heading tuples |> lift
       else Error (Error.heading_mismatch path)
+  | Session branch ->
+      let* state = pinned kernel branch |> lift in
+      Ok (Sess.make connection state)
 
 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} )
+  I.initialize ~evaluators:["fol", FOL.make ()] connection
+  |> Result.map (fun root -> {connection; root})
   |> Result.map_error (fun c -> S.disconnect connection; Error.of_kernel c)
 
 let shutdown {connection; _} = S.disconnect connection
@@ -184,6 +201,22 @@ let remove kernel path =
   let* removed = lift removed in
   if removed then Ok () else Error (Error.conflict path)
 
+let with_session kernel path f =
+  let* segments = segments_of path in
+  using kernel segments (fun handle ->
+      let* session = P.Session.require handle in
+      Ok (f session) )
+  |> lift
+
+let session kernel path =
+  with_session kernel path P.Session.state
+  |> Result.map (fun {P.Session.branch; snapshot} ->
+      {branch; snapshot= C.Hash.to_hum_string snapshot} )
+
+let pin kernel path branch =
+  let* state = pinned kernel branch |> lift in
+  with_session kernel path (fun session -> P.Session.pin session state)
+
 let release = P.Handle.release
 let identity handle = P.Handle.hash handle |> C.Hash.to_hum_string