aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/kernel/Branch.ml28
-rw-r--r--lib/kernel/Merkle.ml4
-rw-r--r--lib/kernel/Multigroup.ml65
-rw-r--r--lib/kernel/Multigroup.mli9
-rw-r--r--lib/kernel/Path.ml17
-rw-r--r--lib/kernel/Path.mli6
-rw-r--r--lib/kernel/Prototype.ml33
-rw-r--r--lib/kernel/Prototype.mli10
-rw-r--r--lib/kernel/SubstantialRelation.ml10
-rw-r--r--lib/kernel/SubstantialRelation.mli5
-rw-r--r--test/integration/Registration.ml8
11 files changed, 180 insertions, 15 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index f44ab6e..64f9689 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -1,5 +1,3 @@
-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
@@ -10,7 +8,16 @@ module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
- module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (Multigroup)
+ module M = Multigroup.Make (S)
+ module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (M)
+ module MMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (M)
+
+ 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;
@@ -52,13 +59,19 @@ module Make (S : Abstract.Storage.STORAGE) = struct
Ok { multigroups; previous }
end
- class branch storage value = object
+ class branch storage value node = object
inherit Lifecycle.null
val storage : S.connection = storage
val branch : t = value
+ val node = node (* FIXME: can we not place this inside `t`? *)
- method protocols : Protocols.Handle.protocol list = []
+ method protocols : Protocols.Handle.protocol list =
+ [ Prototype.Directory.of_properties
+ [ "multigroup", Prototype.mixture
+ [ MMDirectory.make
+ ~storage ~node
+ ~constructor:(M.wrap storage) ] ] ]
method hash =
Representation.to_blob branch
@@ -69,7 +82,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash addr) in
let* branch = Representation.of_blob data in
- Ok (new branch conn branch |> Protocols.Handle.make)
+ 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
@@ -77,5 +91,5 @@ module Make (S : Abstract.Storage.STORAGE) = struct
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 |> Protocols.Handle.make))
+ Ok (new branch conn branch MultigroupM.empty |> Protocols.Handle.make))
end
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 2566941..06bbb8f 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -362,8 +362,8 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA
val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result
val fold_left : S.transaction -> ('c -> K.t -> V.t -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result
-
val iter : S.transaction -> (K.t -> V.t -> 'a) -> node -> (unit, Concepts.Condition.condition) result
+ val keys : S.transaction -> node -> (K.t BatFingerTree.t, Concepts.Condition.condition) result
end
module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> struct
@@ -425,6 +425,8 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY)
fold_left tx
(fun _ k v -> f k v |> ignore)
() node
+
+ let keys = T.keys
end
module StringKey : KEY with type t = string = struct
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
new file mode 100644
index 0000000..685c8c7
--- /dev/null
+++ b/lib/kernel/Multigroup.ml
@@ -0,0 +1,65 @@
+module Make (S : Abstract.Storage.STORAGE) = struct
+ module SI = Storage.Make (S)
+
+ module R = SubstantialRelation.Make (S)
+ module RelationM = Merkle.Interface (S) (Merkle.StringKey) (R)
+ module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (R)
+
+ type t = { relations : RelationM.address }
+
+ module Error = struct
+ open Concepts.Condition
+
+ let malformed_multigroup () = condition "malformed-multigroup" "The on-disk representation of a multigroup did not conform to what was expected. Is your database corrupted?"
+ empty
+
+ let incomplete_multigroup addr = condition "incomplete-multigroup" "A stored multigroup is missing part of its expected structure. Is your storage corrupted?"
+ ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
+ end
+
+ 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 = '*'
+ let malformed = Error.malformed_multigroup
+
+ let fields { relations } =
+ let open Concepts.Encoding in
+ ["relations", Value.bencode_of_hash relations]
+
+ let of_fields fields =
+ let open Utilities.Result in
+ let open Concepts.Encoding in
+ let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
+ Ok { relations }
+ end
+
+ let encode = Representation.to_blob
+ let decode = Representation.of_blob
+
+ class multigroup conn value node = object
+ inherit Lifecycle.null
+
+ val multigroup = value
+ val storage = conn
+ val node = node (* FIXME: see the comment on Branch.ml *)
+
+ method protocols : Protocols.Handle.protocol list =
+ [ Prototype.Directory.of_properties
+ [ "relation", Prototype.mixture
+ [ RMDirectory.make
+ ~storage ~node
+ ~constructor:(R.wrap storage) ] ] ]
+
+ method hash =
+ Representation.to_blob multigroup
+ |> Concepts.Hash.hash_of_blob
+ end
+
+ let wrap conn value =
+ let open Utilities.Result in
+ let* node = SI.with_transaction conn (fun tx -> RelationM.find tx value.relations)
+ |> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations)) in
+ new multigroup conn value node |> Protocols.Handle.make |> Result.ok
+end
diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli
new file mode 100644
index 0000000..88aee30
--- /dev/null
+++ b/lib/kernel/Multigroup.mli
@@ -0,0 +1,9 @@
+module Make (S : Abstract.Storage.STORAGE) : sig
+ type t
+
+ val encode : t -> Concepts.Blob.t
+ val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
+
+ val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
+
+end
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
new file mode 100644
index 0000000..803d8cf
--- /dev/null
+++ b/lib/kernel/Path.ml
@@ -0,0 +1,17 @@
+type t = string list
+
+let this = []
+let (@/) x y = x::y
+
+let rec lookup handle = function
+ | [] -> Ok (Some handle)
+ | x::xs ->
+ let open Utilities.Result in
+ let open Protocols in
+ match Protocols.Directory.from handle with
+ | None -> Ok None
+ | Some dir ->
+ let* elem = Directory.find dir x in
+ match elem with
+ | None -> Ok None
+ | Some elem -> lookup elem xs
diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli
new file mode 100644
index 0000000..85d0ca9
--- /dev/null
+++ b/lib/kernel/Path.mli
@@ -0,0 +1,6 @@
+type t
+
+val this : t
+val (@/) : string -> t -> t
+
+val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t option, Concepts.Condition.condition) result
diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml
new file mode 100644
index 0000000..9c1dcd2
--- /dev/null
+++ b/lib/kernel/Prototype.ml
@@ -0,0 +1,33 @@
+let mixture ps = Protocols.Handle.make @@
+ object
+ inherit Lifecycle.null
+ inherit Identity.of_id (* Should we allow the user to override this? *)
+
+ method protocols = ps
+ end
+
+module Directory = struct
+ let of_properties (props) =
+ Protocols.Directory.make @@
+ object
+ val props = BatList.to_seq props |> BatMap.of_seq
+
+ method list = Ok (BatMap.keys props |> BatFingerTree.of_enum)
+ method find k = Ok (BatMap.find_opt k props)
+ end
+
+ module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) (V : Merkle.VALUE) = struct
+ module Interface = Merkle.Interface (S) (K) (V)
+ module SI = Storage.Make (S)
+
+ let make ~storage ~constructor ~node =
+ Protocols.Directory.make @@
+ object
+ method list = SI.with_transaction storage (Fun.flip Interface.keys node)
+ method find k = SI.with_transaction storage (fun tx -> Interface.lookup tx k node)
+ |> Utilities.Result.fmap (function
+ | None -> Ok None
+ | Some x -> constructor x |> Result.map (Option.some))
+ end
+ end
+end
diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli
new file mode 100644
index 0000000..c1e93df
--- /dev/null
+++ b/lib/kernel/Prototype.mli
@@ -0,0 +1,10 @@
+val mixture : Protocols.Handle.protocol list -> Protocols.Handle.t
+
+module Directory : sig
+ val of_properties : (string * Protocols.Handle.t) list -> Protocols.Handle.protocol
+
+ module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) (V : Merkle.VALUE) : sig
+ module Interface : module type of Merkle.Interface (S) (K) (V)
+ val make : storage:S.connection -> constructor:(V.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Interface.node -> Protocols.Handle.protocol
+ end
+end
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 8658f87..eebae3e 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -78,6 +78,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
Ok {heading; predicate; local_constraints; tuples; indexes}
end
+ let encode = Representation.to_blob
+ let decode = Representation.of_blob
+
let heading {heading; _} = heading
let predicate {predicate; _} = predicate
let local_constraints {local_constraints; _} = local_constraints
@@ -133,10 +136,11 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* data = SI.get_req tx (S.Hash addr) in
Representation.of_blob data
+ let wrap conn relation =
+ new relation conn relation |> Protocols.Handle.make |> Result.ok
+
let load tx conn addr =
- let open Utilities.Result in
- let* relation = load_value tx addr in
- Ok (new relation conn relation |> Protocols.Handle.make)
+ load_value tx addr |> Utilities.Result.fmap (wrap conn)
let assert_tuple tx relation tuple =
let open Utilities.Result in
diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli
index db86fe2..9e61411 100644
--- a/lib/kernel/SubstantialRelation.mli
+++ b/lib/kernel/SubstantialRelation.mli
@@ -1,6 +1,9 @@
module Make (S : Abstract.Storage.STORAGE) : sig
type t
+ val encode : t -> Concepts.Blob.t
+ val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
+
val empty :
S.transaction ->
heading:Concepts.Hash.hash ->
@@ -23,6 +26,8 @@ module Make (S : Abstract.Storage.STORAGE) : sig
val load_value : S.transaction -> Concepts.Hash.hash -> (t, Concepts.Condition.condition) result
+ val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
+
val load :
S.transaction ->
S.connection ->
diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml
index 1f1a768..c77a139 100644
--- a/test/integration/Registration.ml
+++ b/test/integration/Registration.ml
@@ -19,8 +19,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let registration =
begin
let* root = I.initialize conn in
- let* root = Directory.from root |> Option.to_result ~none:(Error.not_found ()) in
- let* bm = Directory.find root "branch" |> fmap (Option.to_result ~none:(Error.not_found ())) in
+ let* bm = Kernel.Path.(lookup root ("branch" @/ this))
+ |> fmap (Option.to_result ~none:(Error.not_found ())) in
let* bm = Registry.from bm |> Option.to_result ~none:(Error.not_found ()) in
let* branch = B.make conn in
Registry.update bm "master" None (Some branch)
@@ -29,8 +29,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let presence =
begin
let* root = I.initialize conn in
- let* root = Directory.from root |> Option.to_result ~none:(Error.not_found ()) in
- let* bm = Directory.find root "branch" |> fmap (Option.to_result ~none:(Error.not_found ())) in
+ let* bm = Kernel.Path.(lookup root ("branch" @/ this))
+ |> fmap (Option.to_result ~none:(Error.not_found ())) in
let* bm = Directory.from bm |> Option.to_result ~none:(Error.not_found ()) in
Directory.find bm "master" |> Result.map Option.is_some
end
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 20:10:37 +0000