aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel/Branch.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/kernel/Branch.ml')
-rw-r--r--lib/kernel/Branch.ml156
1 files changed, 80 insertions, 76 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 53f6fa1..d398707 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -7,7 +7,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct
*)
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)
@@ -18,112 +17,117 @@ module Make (S : Abstract.Storage.STORAGE) = 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?"
+ 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
- }
+ 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)
- 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)
+ 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 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]
+ [ "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 }
+ 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
+
+ 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
+ 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
+ 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 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))
+ Ok (new branch conn branch MultigroupM.empty |> Protocols.Handle.make) )
end
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 08:21:52 +0000