diff options
| -rw-r--r-- | lib/kernel/Branch.ml | 28 | ||||
| -rw-r--r-- | lib/kernel/Prototype.ml | 12 | ||||
| -rw-r--r-- | lib/kernel/Prototype.mli | 7 | ||||
| -rw-r--r-- | lib/kernel/Storage.ml | 4 | ||||
| -rw-r--r-- | lib/kernel/Storage.mli | 2 | ||||
| -rw-r--r-- | test/integration/Registration.ml | 2 |
6 files changed, 43 insertions, 12 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 1e7794e..4b9d948 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -12,6 +12,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct 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 @@ -29,10 +30,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct 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. @@ -56,9 +53,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> 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 + |> 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 class branch storage value node = object (self) inherit Lifecycle.null @@ -73,15 +75,25 @@ module Make (S : Abstract.Storage.STORAGE) = struct Protocols.[ Addressable.make self; Prototype.Associative.(of_properties [ "multigroup", update_only (fun node' -> + (* FIXME: most of this should not be here *) let open Utilities.Result in let* addressable = Handle.require Addressable.from node' in let addr = Addressable.address addressable in - ignore addr; - failwith "TODO") ]); + let branch' = { multigroups = addr; + previous = self#address + |> (fun hash -> S.Hash hash) + |> SI.Pointer.make Loader.load + |> Option.some } in + let* node' = SI.with_transaction storage (fun tx -> + let* _ = SI.store_blob tx (Representation.to_blob branch') in + MultigroupM.find tx addr |> fmap (Option.to_result ~none:(Error.incomplete_branch addr))) in + new branch storage branch' node' |> Protocols.Handle.make |> Result.ok) ]); Prototype.Directory.of_properties [ "multigroup", Prototype.mixture_of node (fun make node -> - [ MMDirectory.make + [ MMAddressable.make + ~node:(MultigroupM.into node); + MMDirectory.make ~storage ~node ~constructor:(M.wrap storage); MMAssociative.make diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml index 1d0751a..b159e00 100644 --- a/lib/kernel/Prototype.ml +++ b/lib/kernel/Prototype.ml @@ -21,6 +21,18 @@ module Error = struct empty end +module Addressable = struct + module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY) = struct + module Tree = Merkle.Make (S) (K) + + let make ~node = + Protocols.Addressable.make @@ + object + method address = Tree.hash_of node + end + end +end + module Associative = struct let of_properties props = Protocols.Associative.make @@ diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli index db55445..919f5d3 100644 --- a/lib/kernel/Prototype.mli +++ b/lib/kernel/Prototype.mli @@ -20,3 +20,10 @@ module Associative : sig val make : storage:S.connection -> constructor:(Tree.node -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Tree.node -> Protocols.Handle.protocol end end + +module Addressable : sig + module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY) : sig + module Tree : module type of Merkle.Make (S) (K) + val make : node:Tree.node -> Protocols.Handle.protocol + end +end diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml index dd06783..665b1a7 100644 --- a/lib/kernel/Storage.ml +++ b/lib/kernel/Storage.ml @@ -5,9 +5,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct loader : S.transaction -> S.address -> ('a, Concepts.Condition.condition) result } - let make addr loader = { addr; loader } + let make loader addr = { addr; loader } let address_of { addr; _ } = addr - let swap { loader; _ } addr = make addr loader + let swap { loader; _ } addr = make loader addr let deref tx { addr; loader } = loader tx addr end diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli index b8c0e5b..3c036ca 100644 --- a/lib/kernel/Storage.mli +++ b/lib/kernel/Storage.mli @@ -2,7 +2,7 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig module Pointer : sig type 'a t - val make : S.address -> (S.transaction -> S.address -> ('a, Concepts.Condition.condition) result) -> 'a t + val make : (S.transaction -> S.address -> ('a, Concepts.Condition.condition) result) -> S.address -> 'a t val address_of : 'a t -> S.address val swap : 'a t -> S.address -> 'a t val deref : S.transaction -> 'a t -> ('a, Concepts.Condition.condition) result diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml index a50bc2a..daecc22 100644 --- a/test/integration/Registration.ml +++ b/test/integration/Registration.ml @@ -20,7 +20,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = |> Helpers.condition_as_failure |> ignore; begin let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in - let* _ = Kernel.Path.(lookup root ("branch" @/ "master" @/ "multigroup" @/ this)) in + let* _ = Kernel.Path.(lookup root ("branch" @/ "master" @/ "multigroup" @/ "library" @/ this)) in let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in Ok () end |