path: root/lib/RNT.ml

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 Sess = K.Session.Make (S)

module Error = struct
  open Condition

  let of_kernel 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"
      ("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}
  | 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

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 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
  | Relation {heading; tuples} ->
      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
  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

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 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

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} )