path: root/lib/kernel/Branch.ml

module Make (S : Abstract.Storage.STORAGE) = struct
  (* Branch has a name, a set of multigroups, and a backlink to the previous state
     multigroup has a name and a set of schemas
     schema has a name and a set of relations

     /branch/master/multigroup/universe/schema/sky/relation/planet
   *)

  module SI = Storage.Make (S)

  module M = Multigroup.Make (S)
  module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (M)
  module MMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (M)
  module MMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
  module MMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)

  module Error = struct
    open Concepts.Condition

    let incomplete_branch addr =
      condition "incomplete-branch" "A stored branch is missing part of its expected structure. Is your storage corrupted?"
        ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
  end

  type t = {
    multigroups : MultigroupM.address;
    previous : t SI.Pointer.t option
  }

  module rec Representation : Concepts.Encoding.Record.S with type t = t = Concepts.Encoding.Record.Make (Body)
  and Body : Concepts.Encoding.Record.BODY = struct
    type nonrec t = t

    let tag = 'Y'
    let malformed () =
      Concepts.Condition.
      (condition "malformed-branch" "The on-disk representation of a branch did not conform to what was expected. Is your database corrupted?"
         empty)

    let fields { multigroups; previous } =
      let open Concepts.Encoding in
      ["multigroups", Value.bencode_of_hash multigroups;
       "previous", Value.bencode_of_option
                     (fun v -> SI.Pointer.address_of v
                               |> SI.as_hash
                               |> Value.bencode_of_hash)
                     previous]

    let of_fields fields =
      let open Utilities.Result in
      let open Concepts.Encoding in
      let* multigroups = Bencode.field "multigroups" fields |> fmap Value.hash_of_bencode in
      let* previous = Bencode.field "previous" fields
                      |> fmap (Value.option_of_bencode
                                 (fun v -> Value.hash_of_bencode v
                                           |> Result.map (fun hash -> S.Hash hash)
                                           |> Result.map (SI.Pointer.make Loader.load))) in
      Ok { multigroups; previous }
  end
  and Loader : sig val load : (S.transaction -> S.address -> (t, Concepts.Condition.condition) result) end = struct
    let load tx addr =
      SI.get_req tx addr
      |> Utilities.Result.fmap Representation.of_blob
  end

  let pointer_of hash = SI.Pointer.make Loader.load (S.Hash hash)

  class branch storage value node = object (self)
    inherit Lifecycle.null

    method to_string = "branch"

    val storage : S.connection = storage
    val branch : t = value
    val node = node (* FIXME: can we not place this inside `t`? *)

    method deriving branch' =
      let open Utilities.Result in
      let branch'' = { branch' with previous = self#address
                                               |> pointer_of
                                               |> Option.some } in
      let* node' = SI.with_transaction storage (fun tx ->
                       let* _ = SI.store_blob tx (Representation.to_blob branch'') in
                       MultigroupM.find tx branch'.multigroups
                       |> fmap (Option.to_result ~none:(Error.incomplete_branch branch'.multigroups))) in
      new branch storage branch'' node' |> Protocols.Handle.make |> Result.ok

    method protocols : Protocols.Handle.protocol list =
      let open Utilities.Result in
      Protocols.[ Addressable.make self;
                  Prototype.Associative.(of_properties
                    [ "multigroup", update_only (fun node' ->
                                        Handle.require Addressable.from node'
                                        |> Result.map Addressable.address
                                        |> fmap (fun addr -> self#deriving { branch with multigroups = addr })) ]);
                  Prototype.Directory.of_properties
                    [ "multigroup", Prototype.mixture_of node
                                      (fun make node ->
                                        [ MMAddressable.make
                                            ~node:(MultigroupM.into node);
                                          MMDirectory.make
                                            ~storage ~node
                                            ~constructor:(M.wrap storage);
	                                      MMAssociative.make
                                            ~storage ~node:(MultigroupM.into node)
                                            ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok) ]) ] ]

    method hash =
      Representation.to_blob branch
      |> Concepts.Hash.hash_of_blob

    method address = self#hash
  end

  let load tx conn addr =
    let open Utilities.Result in
    let* data = SI.get_req tx (S.Hash addr) in
    let* branch = Representation.of_blob data in
    let* node = MultigroupM.find tx branch.multigroups |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups)) in
    Ok (new branch conn branch node |> Protocols.Handle.make)

  let make conn =
    let open Utilities.Result in
    SI.with_transaction conn (fun tx ->
        let* empty = MultigroupM.empty_under tx in
        let branch = { multigroups = empty; previous = None } in
        let* _ = SI.store_blob tx (Representation.to_blob branch) in
        Ok (new branch conn branch MultigroupM.empty |> Protocols.Handle.make))
end