Branch serialization

5 files changed, 96 insertions, 1 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
new file mode 100644
index 0000000..2aaa9ca
--- /dev/null
+++ b/lib/kernel/Branch.ml
@@ -0,0 +1,60 @@
+module Multigroup = Merkle.StringKey (* FIXME *)
+
+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 MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (Multigroup)
+
+  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 load tx addr =
+      SI.get_req tx addr
+      |> Utilities.Result.fmap Representation.of_blob
+
+    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 (Fun.flip (SI.Pointer.make) load))) in
+      Ok { multigroups; previous }
+  end
+
+  class branch = object
+    (* TODO *)
+  end
+
+  let load _tx _conn _name _addr = failwith "TODO"
+end
diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli
new file mode 100644
index 0000000..02be2ed
--- /dev/null
+++ b/lib/kernel/Branch.mli
@@ -0,0 +1,5 @@
+module Make (S : Abstract.Storage.STORAGE) : sig
+  type t
+
+  val load : S.transaction -> S.connection -> string -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result
+end
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index bdc461e..cd3c5e2 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -19,6 +19,7 @@ end
 module Make (S : Abstract.Storage.STORAGE) = struct
   module M = Merkle.Make (S) (Merkle.StringKey)
   module SI = Storage.Make (S)
+  module B = Branch.Make (S)
 
   let root_for tx label =
     let open Utilities.Result in
@@ -60,7 +61,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
     method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx)
 
-    method find _ = failwith "TODO"
+    method find key =
+      let open Utilities.Result in
+      SI.with_transaction storage (fun tx ->
+          let* head = Atomic.get head |> M.lookup tx key in
+          match head with
+          | None -> Ok None
+          | Some head -> B.load tx storage key head |> Result.map Option.some)
   end
 
   let make storage label =
diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml
index e6a84ba..dd06783 100644
--- a/lib/kernel/Storage.ml
+++ b/lib/kernel/Storage.ml
@@ -11,6 +11,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let deref tx { addr; loader } = loader tx addr
   end
 
+  let as_hash = function
+    | S.Hash h -> h
+    | _ -> failwith "A label was provided where a hash was expected."
+
+  let to_hum_string = function
+    | S.Hash h -> "Hash " ^ (Concepts.Hash.to_hum_string h)
+    | S.Label l -> "Label " ^ l
+
+  module Error = struct
+    open Concepts.Condition
+
+    let missing_data addr =
+      condition "missing-data" "An expected value was not found on the underlying storage. Is your database corrupted?"
+        ("address" |=| Concepts.Value.String (to_hum_string addr))
+  end
+
   let finish tx = function
     | Ok value ->
        let open Utilities.Result in
@@ -31,4 +47,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let* () = S.put tx (S.Hash address) blob in
     Ok address
 
+  let get_req tx addr =
+    S.get tx addr
+    |> Utilities.Result.fmap (Option.to_result ~none:(Error.missing_data addr))
+
 end
diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli
index 9a10984..b8c0e5b 100644
--- a/lib/kernel/Storage.mli
+++ b/lib/kernel/Storage.mli
@@ -8,7 +8,10 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig
     val deref : S.transaction -> 'a t -> ('a, Concepts.Condition.condition) result
   end
 
+  val as_hash : S.address -> Concepts.Hash.hash
+
   val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result
   val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result
   val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result
+  val get_req: S.transaction -> S.address -> (Concepts.Blob.t, Concepts.Condition.condition) result
 end