aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/kernel/Branch.ml45
-rw-r--r--lib/kernel/BranchManager.ml2
-rw-r--r--lib/kernel/Generator.ml2
-rw-r--r--lib/kernel/Multigroup.ml25
-rw-r--r--lib/kernel/Multigroup.mli2
-rw-r--r--lib/kernel/Namespace.ml2
-rw-r--r--lib/kernel/Path.ml44
-rw-r--r--lib/kernel/Path.mli1
-rw-r--r--lib/kernel/Prototype.ml14
-rw-r--r--lib/kernel/Prototype.mli7
-rw-r--r--lib/kernel/Storage.ml4
-rw-r--r--lib/kernel/Storage.mli2
-rw-r--r--lib/kernel/SubstantialRelation.ml3
-rw-r--r--lib/kernel/Tuple.ml2
14 files changed, 116 insertions, 39 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index b8d331f..53f6fa1 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -12,12 +12,14 @@ 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
- 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))
+ 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 = {
@@ -29,10 +31,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,30 +54,51 @@ 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
+
+ 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' ->
- let open Utilities.Result in
- let* addressable = Handle.require Addressable.from node' in
- let addr = Addressable.address addressable in
- ignore addr;
- failwith "TODO") ]);
+ 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 ->
- [ MMDirectory.make
+ [ MMAddressable.make
+ ~node:(MultigroupM.into node);
+ MMDirectory.make
~storage ~node
~constructor:(M.wrap storage);
MMAssociative.make
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 1162b40..bda4233 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -28,6 +28,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
inherit Lifecycle.null
inherit Identity.of_id
+ method to_string = "branch-manager"
+
val storage : S.connection = storage
val label : string = label
val head : M.node Atomic.t = Atomic.make head
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
index b8f4962..204699f 100644
--- a/lib/kernel/Generator.ml
+++ b/lib/kernel/Generator.ml
@@ -15,6 +15,8 @@ class producer_cursor produce finally =
inherit Lifecycle.null
inherit Identity.of_id
+ method to_string = "producer-cursor"
+
val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh
method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self]
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 685c8c7..c8ffa62 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -38,23 +38,28 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let encode = Representation.to_blob
let decode = Representation.of_blob
- class multigroup conn value node = object
+ class multigroup conn value node = object (self)
inherit Lifecycle.null
+ method to_string = "multigroup"
+
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) ] ] ]
+ Protocols.[ Addressable.make self;
+ 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
+
+ method address = self#hash
end
let wrap conn value =
@@ -62,4 +67,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
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
+
+ let make conn =
+ let open Utilities.Result in
+ SI.with_transaction conn (fun tx ->
+ let* empty = RelationM.empty_under tx in
+ let multigroup = { relations = empty } in
+ let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
+ new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok)
end
diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli
index 88aee30..fc58dad 100644
--- a/lib/kernel/Multigroup.mli
+++ b/lib/kernel/Multigroup.mli
@@ -5,5 +5,5 @@ module Make (S : Abstract.Storage.STORAGE) : sig
val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
-
+ val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
end
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
index 507afa4..728c307 100644
--- a/lib/kernel/Namespace.ml
+++ b/lib/kernel/Namespace.ml
@@ -2,6 +2,8 @@ class namespace = object (self)
inherit Lifecycle.null
inherit Identity.of_id
+ method to_string = "namespace"
+
val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t =
Atomic.make BatMap.empty
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 629a527..b83c9b2 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -15,32 +15,44 @@ module Error = struct
let path_not_found path = condition "path-not-found" "A given path was not found under the specified object"
("path" |=| Concepts.Value.String (to_string path))
-
- let not_a_registry path = condition "not-a-registry" "The specified path did not point to a registry"
- ("path" |=| Concepts.Value.String (to_string path))
-
- let not_a_directory path = condition "not-a-directory" "The specified path did not point to a directory"
- ("path" |=| Concepts.Value.String (to_string path))
end
-let lookup handle path =
+let walking f g handle path =
let rec walk handle = function
- | [] -> Ok handle
+ | [] -> g handle
| x::xs ->
let open Utilities.Result in
let open Protocols in
- match Directory.from handle with
+ let* dir =
+ Handle.require Directory.from handle
+ |> Result.map_error Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x)) in
+ let* elem = Directory.find dir x in
+ match elem with
| None -> Error (Error.path_not_found path)
- | Some dir ->
- let* elem = Directory.find dir x in
- match elem with
- | None -> Error (Error.not_a_directory path)
- | Some elem -> walk elem xs
+ | Some elem -> f x handle (fun () -> walk elem xs)
in
walk handle path
+ |> Result.map_error Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))
+
+let lookup = walking (fun _ _ f -> f ()) Result.ok
let update handle path key reference value =
let open Utilities.Result in
+ let open Protocols in
let* handle = lookup handle path in
- let* registry = Protocols.Registry.from handle |> Option.to_result ~none:(Error.not_a_registry path) in
- Protocols.Registry.update registry key reference value
+ let* registry = Handle.require Registry.from handle in
+ Registry.update registry key reference value
+
+let assoc handle path key value =
+ let open Utilities.Result in
+ let open Utilities.Fun in
+ let open Protocols in
+ let assoc_on handle key value =
+ let* a = Handle.require Associative.from handle in
+ let* a' = Associative.update a key value in
+ Ok (Handle.from a')
+ in
+ walking
+ (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some))
+ (fun h -> assoc_on h key value)
+ handle path
diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli
index 6a74350..ece0615 100644
--- a/lib/kernel/Path.mli
+++ b/lib/kernel/Path.mli
@@ -6,3 +6,4 @@ val (@/) : string -> t -> t
val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
val update : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> Protocols.Handle.t option -> (bool, Concepts.Condition.condition) result
+val assoc : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result
diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml
index 65de68f..b159e00 100644
--- a/lib/kernel/Prototype.ml
+++ b/lib/kernel/Prototype.ml
@@ -4,6 +4,8 @@ let mixture ps = Protocols.Handle.make @@
inherit Identity.of_id (* Should we allow the user to override this? *)
method protocols = ps
+
+ method to_string = "mixture"
end
let rec mixture_of value f =
@@ -19,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 f0c4800..d50735c 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 fa8a785..53bb666 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/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 090568f..52ce83c 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -150,6 +150,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
class relation storage value description =
object (self)
inherit Lifecycle.null
+
+ method to_string = "relation"
+
val storage : S.connection = storage
val relation : t = value
val declaration = modes_of description
diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml
index ef591ae..bbc20ab 100644
--- a/lib/kernel/Tuple.ml
+++ b/lib/kernel/Tuple.ml
@@ -117,6 +117,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
class tuple ~relation conn value node = object (self)
inherit Lifecycle.null
+ method to_string = "tuple"
+
val tuple = value
val storage = conn
val node = node
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 19:29:01 +0000