From 584fbca6d920e9a9f91d451667f9380714ac2175 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Fri, 25 Sep 2026 21:51:33 -0300 Subject: dune fmt --- lib/kernel/Branch.ml | 156 ++++---- lib/kernel/Branch.mli | 7 +- lib/kernel/BranchManager.ml | 143 ++++---- lib/kernel/EphemeralRelation.ml | 2 +- lib/kernel/Generator.ml | 12 +- lib/kernel/Identity.ml | 7 +- lib/kernel/Initialization.ml | 2 +- lib/kernel/Lifecycle.ml | 52 ++- lib/kernel/Merkle.ml | 725 +++++++++++++++++++------------------ lib/kernel/Multigroup.ml | 76 ++-- lib/kernel/Multigroup.mli | 1 - lib/kernel/Namespace.ml | 59 ++- lib/kernel/Path.ml | 36 +- lib/kernel/Path.mli | 19 +- lib/kernel/Prototype.ml | 130 +++---- lib/kernel/Prototype.mli | 35 +- lib/kernel/Storage.ml | 36 +- lib/kernel/Storage.mli | 28 +- lib/kernel/SubstantialRelation.ml | 25 +- lib/kernel/SubstantialRelation.mli | 1 - lib/kernel/Tuple.ml | 78 ++-- 21 files changed, 839 insertions(+), 791 deletions(-) (limited to 'lib/kernel') 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 diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli index 82bdbb7..c08e781 100644 --- a/lib/kernel/Branch.mli +++ b/lib/kernel/Branch.mli @@ -2,5 +2,10 @@ module Make (S : Abstract.Storage.STORAGE) : sig type t val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result - val load : S.transaction -> S.connection -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result + + val load : + S.transaction -> + S.connection -> + Concepts.Hash.hash -> + (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index bda4233..3531748 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -2,8 +2,10 @@ module Error = struct open Concepts.Condition let invalid_root head = - condition "invalid-root" "The root hash for the database state is missing from the backend. Either your storage is corrupted, or this is a bug in RNT!" - ("hash" |=| (Concepts.Value.String (Concepts.Hash.to_hum_string head))) + condition "invalid-root" + "The root hash for the database state is missing from the backend. Either your storage is \ + corrupted, or this is a bug in RNT!" + ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head)) end module Make (S : Abstract.Storage.STORAGE) = struct @@ -14,89 +16,90 @@ module Make (S : Abstract.Storage.STORAGE) = struct let root_for tx label = let open Utilities.Result in let* label = S.get tx (S.Label label) in - let data = Option.map (fun blob -> Concepts.Blob.bytes_of_blob blob - |> Bytes.to_string - |> Concepts.Hash.of_raw_string) - label in + let data = + Option.map + (fun blob -> + Concepts.Blob.bytes_of_blob blob |> Bytes.to_string |> Concepts.Hash.of_raw_string ) + label + in Ok data let persist_root tx label addr = let data = Concepts.Hash.blob_of_hash addr in S.put tx (S.Label label) data - class manager storage label head = object (self) - inherit Lifecycle.null - inherit Identity.of_id + class manager storage label head = + object (self) + 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 - method to_string = "branch-manager" + method fetch branch_name = + SI.with_transaction storage (fun tx -> + let head = Atomic.get head in + M.lookup tx branch_name head ) - val storage : S.connection = storage - val label : string = label - val head : M.node Atomic.t = Atomic.make head + method protocols = Protocols.[Directory.make self; Registry.make self] + method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx) - method fetch branch_name = - SI.with_transaction storage (fun tx -> - let head = Atomic.get head in - M.lookup tx branch_name head) + 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 head |> Result.map Option.some ) - method protocols = Protocols.[Directory.make self; Registry.make self] - - method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx) - - 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 head |> Result.map Option.some) - - method update key reference value = - let open Utilities.Result in - let open Protocols in - SI.with_transaction storage (fun tx -> - match - Utilities.Atomic.mswap head (fun head -> - let address_of h = - let* i = Handle.require Addressable.from h in - Ok (Addressable.address i) - in - let* branch = M.lookup tx key head |> Result.map_error (fun e -> Some e) in - let* reference = Option.map address_of reference - |> Utilities.Option.sequence - |> Result.map_error (fun e -> Some e) in - let* value = Option.map address_of value - |> Utilities.Option.sequence - |> Result.map_error (fun e -> Some e) in - if branch = reference then - begin - let* new_head = match value with - | Some value -> M.insert tx key value head - | None -> M.remove tx key head - in - let* _ = persist_root tx label (M.hash_of new_head) in - Ok new_head - end - |> Result.map_error (fun e -> Some e) - else - Error None) - with - | Ok _ -> Ok true - | Error None -> Ok false - | Error (Some e) -> Error e) - - end + method update key reference value = + let open Utilities.Result in + let open Protocols in + SI.with_transaction storage (fun tx -> + match + Utilities.Atomic.mswap head (fun head -> + let address_of h = + let* i = Handle.require Addressable.from h in + Ok (Addressable.address i) + in + let* branch = M.lookup tx key head |> Result.map_error (fun e -> Some e) in + let* reference = + Option.map address_of reference + |> Utilities.Option.sequence + |> Result.map_error (fun e -> Some e) + in + let* value = + Option.map address_of value + |> Utilities.Option.sequence + |> Result.map_error (fun e -> Some e) + in + if branch = reference then + begin + let* new_head = + match value with + | Some value -> M.insert tx key value head + | None -> M.remove tx key head + in + let* _ = persist_root tx label (M.hash_of new_head) in + Ok new_head + end + |> Result.map_error (fun e -> Some e) + else Error None ) + with + | Ok _ -> Ok true + | Error None -> Ok false + | Error (Some e) -> Error e ) + end let make storage label = let open Utilities.Result in SI.with_transaction storage (fun tx -> let* addr = root_for tx label in match addr with - | None -> - Ok (new manager storage label M.empty |> Protocols.Handle.make) + | None -> Ok (new manager storage label M.empty |> Protocols.Handle.make) | Some addr -> - let* head = M.find tx addr in - let* head = Option.to_result ~none:(Error.invalid_root addr) head in - Ok (new manager storage label head |> Protocols.Handle.make)) - + let* head = M.find tx addr in + let* head = Option.to_result ~none:(Error.invalid_root addr) head in + Ok (new manager storage label head |> Protocols.Handle.make) ) end diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml index b403e13..8aa0463 100644 --- a/lib/kernel/EphemeralRelation.ml +++ b/lib/kernel/EphemeralRelation.ml @@ -41,7 +41,7 @@ module Make (D : DERIVATION) = struct method generate binding = D.generate plan binding |> Result.map (fun cursor -> - new Lifecycle.retaining cursor (self :> Lifecycle.lifecycle) |> Protocols.Handle.make ) + new Lifecycle.retaining cursor (self :> Lifecycle.lifecycle) |> Protocols.Handle.make ) method enumerate = self#generate Protocols.Generative.nothing method describe () = Ok (Protocols.Schematics.Relation description) diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml index 204699f..272bb86 100644 --- a/lib/kernel/Generator.ml +++ b/lib/kernel/Generator.ml @@ -5,8 +5,8 @@ type step = | Finished of (unit, Concepts.Condition.condition) result let start produce = - try Finished (produce ~yield:(fun tuple -> Effect.perform (Yield tuple))) with - | effect (Yield tuple), k -> Element (tuple, k) + try Finished (produce ~yield:(fun tuple -> Effect.perform (Yield tuple))) + with effect Yield tuple, k -> Element (tuple, k) let resume k = Effect.Deep.continue k () @@ -14,9 +14,7 @@ class producer_cursor produce finally = object (self) 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] @@ -48,12 +46,10 @@ class producer_cursor produce finally = | None -> Ok Protocols.Cursor.{tuples; exhausted= true} | Some tuple -> fill (taken + 1) (BatFingerTree.snoc tuples tuple) in - if limit <= 0 then - Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)} + if limit <= 0 then Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= state = `Done} else fill 0 BatFingerTree.empty method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> () end -let cursor_of ?finally produce = - new producer_cursor produce finally |> Protocols.Handle.make +let cursor_of ?finally produce = new producer_cursor produce finally |> Protocols.Handle.make diff --git a/lib/kernel/Identity.ml b/lib/kernel/Identity.ml index ce3d30c..2205958 100644 --- a/lib/kernel/Identity.ml +++ b/lib/kernel/Identity.ml @@ -2,6 +2,7 @@ class type identity = object method hash : Concepts.Hash.hash end -class of_id = object (self) - method hash = Oo.id self |> Concepts.Hash.hash_of_int -end +class of_id = + object (self) + method hash = Oo.id self |> Concepts.Hash.hash_of_int + end diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index ae041fc..25c2b3d 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -14,7 +14,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct List.fold_left (fun acc (name, handle) -> let* _ = acc in - Registry.update evaluator_registry name None (Some handle)) + Registry.update evaluator_registry name None (Some handle) ) (Ok true) evaluators in let* _ = Registry.update registry "evaluator" None (Some evaluator_namespace) in diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml index 772cb6e..bf0b544 100644 --- a/lib/kernel/Lifecycle.ml +++ b/lib/kernel/Lifecycle.ml @@ -8,33 +8,25 @@ class type virtual controlled_lifecycle = object method virtual destroy : unit end -class null = object - method reference = true - method release = () -end - -class virtual counted = object (self) - val references = Atomic.make 1 - - method virtual destroy : unit - - method reference = - Atomic.incr references; - true - - method release = - if Atomic.fetch_and_add references (-1) = 1 then - self#destroy -end - -class retaining inner (owner : lifecycle) = object - inherit counted - initializer ignore owner#reference - - method destroy = - Protocols.Handle.release inner; - owner#release - - method hash = Protocols.Handle.hash inner - method protocols = Protocols.Handle.protocols inner -end +class null = + object + method reference = true + method release = () + end + +class virtual counted = + object (self) + val references = Atomic.make 1 + method virtual destroy : unit + method reference = Atomic.incr references; true + method release = if Atomic.fetch_and_add references (-1) = 1 then self#destroy + end + +class retaining inner (owner : lifecycle) = + object + inherit counted + initializer ignore owner#reference + method destroy = Protocols.Handle.release inner; owner#release + method hash = Protocols.Handle.hash inner + method protocols = Protocols.Handle.protocols inner + end diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index fc076ac..af5b19f 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -13,234 +13,238 @@ end module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig type address = Concepts.Hash.hash - type node - val with_batch: S.transaction -> (unit -> (node, Concepts.Condition.condition) result) -> (node, Concepts.Condition.condition) result + val with_batch : + S.transaction -> + (unit -> (node, Concepts.Condition.condition) result) -> + (node, Concepts.Condition.condition) result val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result val persist : S.transaction -> node -> (address, Concepts.Condition.condition) result - val empty : node val empty_under : S.transaction -> (address, Concepts.Condition.condition) result - val hash_of : node -> address - val insert : S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result + val insert : + S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result + val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result - val fold_left : S.transaction -> ('c -> K.t -> address -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result + val fold_left : + S.transaction -> + ('c -> K.t -> address -> 'c) -> + 'c -> + node -> + ('c, Concepts.Condition.condition) result + val keys : S.transaction -> node -> (K.t BatFingerTree.t, Concepts.Condition.condition) result end -module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct - type address = Concepts.Hash.hash +module Make : TREE = +functor + (S : Abstract.Storage.STORAGE) + (K : KEY) + -> + struct + type address = Concepts.Hash.hash - module Error = struct - open Concepts.Condition + module Error = struct + open Concepts.Condition - let malformed_node () = condition "malformed-node" "A node representation did not conform to what was expected" empty - end + let malformed_node () = + condition "malformed-node" "A node representation did not conform to what was expected" + empty + end - type node = - Leaf of - { keys : K.t BatFingerTree.t; - values : address BatFingerTree.t } - | Trunk of - { keys : K.t BatFingerTree.t; - children : address BatFingerTree.t } - - let empty = Leaf { keys = BatFingerTree.empty; values = BatFingerTree.empty } - - let rec lookup1' keys key bottom top = - let open Utilities.Ordering in - if bottom >= top then (bottom, false) - else - let mid = bottom + (top - bottom) / 2 in - let node = BatFingerTree.get keys mid in - match K.compare node key with - | Equal -> (mid, true) - | Greater -> lookup1' keys key bottom mid - | Smaller -> lookup1' keys key (mid + 1) top - - let lookup1 keys key = lookup1' keys key 0 (BatFingerTree.size keys) - - let keys_of = function - | Leaf { keys; _ } -> keys - | Trunk { keys; _ } -> keys - - let of_bencode = - let open Concepts.Encoding.Bencode in - let open Utilities.Result in - (* This is terrible *) - let decode_key t = as_string t - |> Result.map String.to_bytes - |> Result.map Concepts.Blob.blob_of_bytes - |> fmap K.decode in - let decode_value t = as_string t |> Result.map Concepts.Hash.of_raw_string in - let decode_list f data = data - |> fmap as_list - |> Result.map (List.map f) - |> fmap Utilities.List.sequence - |> Result.map BatFingerTree.of_list in - function - | Tagged ('!', (Dict _ as data)) -> - let* keys = field "keys" data |> decode_list decode_key in - let* values = field "values" data |> decode_list decode_value in - Ok (Leaf { keys; values }) - | Tagged ('#', (Dict _ as data)) -> - let* keys = field "keys" data |> decode_list decode_key in - let* children = field "children" data |> decode_list decode_value in - Ok (Trunk { keys; children }) - | _ -> Error (Error.malformed_node ()) - - let from_blob blob = Concepts.Encoding.Bencode.of_blob blob - |> Utilities.Result.fmap of_bencode - - let to_bencode = - let open Concepts.Encoding.Bencode in - (* Ditto. *) - let bencode_key k = K.encode k - |> Concepts.Blob.bytes_of_blob - |> String.of_bytes - |> (fun s -> String s) in - let bencode_hash h = String (Concepts.Hash.to_raw_string h) in - function - | Leaf { keys; values } -> - Tagged ('!', Dict [("keys", List (BatFingerTree.to_list keys |> List.map bencode_key)); - ("values", List (BatFingerTree.to_list values |> List.map bencode_hash))]) - | Trunk { keys; children } -> - Tagged ('#', Dict [("keys", List (BatFingerTree.to_list keys |> List.map bencode_key)); - ("children", List (BatFingerTree.to_list children |> List.map bencode_hash))]) - - let to_blob node = to_bencode node |> Concepts.Encoding.Bencode.to_blob - - (* TODO: we should probably cache this inside the node itself rather + type node = + | Leaf of {keys: K.t BatFingerTree.t; values: address BatFingerTree.t} + | Trunk of {keys: K.t BatFingerTree.t; children: address BatFingerTree.t} + + let empty = Leaf {keys= BatFingerTree.empty; values= BatFingerTree.empty} + + let rec lookup1' keys key bottom top = + let open Utilities.Ordering in + if bottom >= top then bottom, false + else + let mid = bottom + ((top - bottom) / 2) in + let node = BatFingerTree.get keys mid in + match K.compare node key with + | Equal -> mid, true + | Greater -> lookup1' keys key bottom mid + | Smaller -> lookup1' keys key (mid + 1) top + + let lookup1 keys key = lookup1' keys key 0 (BatFingerTree.size keys) + let keys_of = function Leaf {keys; _} -> keys | Trunk {keys; _} -> keys + + let of_bencode = + let open Concepts.Encoding.Bencode in + let open Utilities.Result in + (* This is terrible *) + let decode_key t = + as_string t + |> Result.map String.to_bytes + |> Result.map Concepts.Blob.blob_of_bytes + |> fmap K.decode + in + let decode_value t = as_string t |> Result.map Concepts.Hash.of_raw_string in + let decode_list f data = + data + |> fmap as_list + |> Result.map (List.map f) + |> fmap Utilities.List.sequence + |> Result.map BatFingerTree.of_list + in + function + | Tagged ('!', (Dict _ as data)) -> + let* keys = field "keys" data |> decode_list decode_key in + let* values = field "values" data |> decode_list decode_value in + Ok (Leaf {keys; values}) + | Tagged ('#', (Dict _ as data)) -> + let* keys = field "keys" data |> decode_list decode_key in + let* children = field "children" data |> decode_list decode_value in + Ok (Trunk {keys; children}) + | _ -> Error (Error.malformed_node ()) + + let from_blob blob = Concepts.Encoding.Bencode.of_blob blob |> Utilities.Result.fmap of_bencode + + let to_bencode = + let open Concepts.Encoding.Bencode in + (* Ditto. *) + let bencode_key k = + K.encode k |> Concepts.Blob.bytes_of_blob |> String.of_bytes |> fun s -> String s + in + let bencode_hash h = String (Concepts.Hash.to_raw_string h) in + function + | Leaf {keys; values} -> + Tagged + ( '!', + Dict + [ "keys", List (BatFingerTree.to_list keys |> List.map bencode_key); + "values", List (BatFingerTree.to_list values |> List.map bencode_hash) ] ) + | Trunk {keys; children} -> + Tagged + ( '#', + Dict + [ "keys", List (BatFingerTree.to_list keys |> List.map bencode_key); + "children", List (BatFingerTree.to_list children |> List.map bencode_hash) ] ) + + let to_blob node = to_bencode node |> Concepts.Encoding.Bencode.to_blob + + (* TODO: we should probably cache this inside the node itself rather than recalculating it every time. We could also allow the user to create "uninterned" nodes that are not storage-backed, that could be used for intermediates and the like. *) - let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob - - type _ Effect.t += Intern: (address * node * Concepts.Blob.t) -> unit Effect.t | Retrieve: address -> (node * Concepts.Blob.t) option Effect.t - - let rec flush tx buffer addr = - let open Utilities.Result in - match BatMap.find_opt addr buffer with - | None -> Ok () - | Some (node, data) -> - let* _ = S.put tx (S.Hash addr) data in - match node with - | Leaf _ -> Ok () - | Trunk { children; _ } -> - BatFingerTree.map (fun addr -> flush tx buffer addr) children - |> Utilities.FingerTree.sequence - |> Result.map ignore - - let with_batch tx f = - let open Utilities.Result in - let buffer = ref BatMap.empty in - try - let* node = f () in - let* _ = flush tx !buffer (hash_of node) in - Ok node - with - | effect (Intern (addr, node, data)), k -> - buffer := BatMap.add addr (node, data) !buffer; - Effect.Deep.continue k () - | effect (Retrieve addr), k -> - Effect.Deep.continue k (BatMap.find_opt addr !buffer) - - let find tx addr = - let open Utilities.Result in - try Effect.perform (Retrieve addr) |> Option.map fst |> Result.ok - with - | Effect.Unhandled _ -> - let* data = S.get tx (S.Hash addr) in - match data with - | None -> Ok None - | Some data -> - let* node = from_blob data in - Ok (Some node) - - let persist tx node = - let data = to_blob node in - let addr = Concepts.Hash.hash_of_blob data in - begin - try Ok (Effect.perform (Intern (addr, node, data))) + let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob + + type _ Effect.t += + | Intern : (address * node * Concepts.Blob.t) -> unit Effect.t + | Retrieve : address -> (node * Concepts.Blob.t) option Effect.t + + let rec flush tx buffer addr = + let open Utilities.Result in + match BatMap.find_opt addr buffer with + | None -> Ok () + | Some (node, data) -> ( + let* _ = S.put tx (S.Hash addr) data in + match node with + | Leaf _ -> Ok () + | Trunk {children; _} -> + BatFingerTree.map (fun addr -> flush tx buffer addr) children + |> Utilities.FingerTree.sequence + |> Result.map ignore ) + + let with_batch tx f = + let open Utilities.Result in + let buffer = ref BatMap.empty in + try + let* node = f () in + let* _ = flush tx !buffer (hash_of node) in + Ok node with - | Effect.Unhandled _ -> - S.put tx (S.Hash addr) data - end - |> Result.map (fun () -> addr) - - let find' tx addr = - let open Utilities.Result in - let* child = find tx addr in - match child with - | Some child -> Ok child - | None -> failwith "A child node was not found on the underlying storage. Either your database is corrupted, or this is a bug on RNT!" - - let rec lookup tx key node = - let open Utilities.Result in - let i, found = lookup1 (keys_of node) key in - match node with - | Leaf { values; _ } -> - if found then Ok (Some (BatFingerTree.get values i)) else Ok None - | Trunk { children; _ } -> - let* child = BatFingerTree.get children (if found then i+1 else i) |> find' tx in - lookup tx key child - - let empty_under tx = persist tx empty - - type op = Update of address * node | Split of address * K.t * address - - let emplace i v ft = - let size = BatFingerTree.size ft in - if i < 0 || i > size then - invalid_arg "Merkle.emplace: index out of bounds" - else if size = 0 then - BatFingerTree.singleton v - else if i = size then - BatFingerTree.snoc ft v - else - let fl, fr = BatFingerTree.split_at ft i in - BatFingerTree.singleton v - |> BatFingerTree.append fl - |> (Fun.flip BatFingerTree.append) fr - - let insert1 key value node = - let i, present = lookup1 (keys_of node) key in - match node with - | Leaf ({ keys; values } as leaf) -> - if present then - Leaf { leaf with values = BatFingerTree.set values i value } - else - Leaf { keys = emplace i key keys; values = emplace i value values } - (* When in danger or in doubt: run in circles, scream and shout. *) - | Trunk _ -> failwith "Cannot insert a value on a trunk node. This is a bug in RNT!" - - let pivot_at ft i = - let l, r' = BatFingerTree.split_at ft i in - let r, p = BatFingerTree.front_exn r' in - l, p, r - - let split_at pivot = function - | Leaf { keys; values } -> - let kl, kr = BatFingerTree.split_at keys pivot in - let vl, vr = BatFingerTree.split_at values pivot in - let p = BatFingerTree.get kr 0 in - Leaf { keys = kl; values = vl }, - p, - Leaf { keys = kr; values = vr } - | Trunk { keys; children } -> - let kl, kp, kr = pivot_at keys pivot in - let cl, cr = BatFingerTree.split_at children (pivot + 1) in - Trunk { keys = kl; children = cl }, - kp, - Trunk { keys = kr; children = cr } - - (* FIXME: this works out to a geometric distribution with roughly 64 + | effect Intern (addr, node, data), k -> + buffer := BatMap.add addr (node, data) !buffer; + Effect.Deep.continue k () + | effect Retrieve addr, k -> Effect.Deep.continue k (BatMap.find_opt addr !buffer) + + let find tx addr = + let open Utilities.Result in + try Effect.perform (Retrieve addr) |> Option.map fst |> Result.ok + with Effect.Unhandled _ -> ( + let* data = S.get tx (S.Hash addr) in + match data with + | None -> Ok None + | Some data -> + let* node = from_blob data in + Ok (Some node) ) + + let persist tx node = + let data = to_blob node in + let addr = Concepts.Hash.hash_of_blob data in + begin try Ok (Effect.perform (Intern (addr, node, data))) + with Effect.Unhandled _ -> S.put tx (S.Hash addr) data + end + |> Result.map (fun () -> addr) + + let find' tx addr = + let open Utilities.Result in + let* child = find tx addr in + match child with + | Some child -> Ok child + | None -> + failwith + "A child node was not found on the underlying storage. Either your database is \ + corrupted, or this is a bug on RNT!" + + let rec lookup tx key node = + let open Utilities.Result in + let i, found = lookup1 (keys_of node) key in + match node with + | Leaf {values; _} -> if found then Ok (Some (BatFingerTree.get values i)) else Ok None + | Trunk {children; _} -> + let* child = BatFingerTree.get children (if found then i + 1 else i) |> find' tx in + lookup tx key child + + let empty_under tx = persist tx empty + + type op = Update of address * node | Split of address * K.t * address + + let emplace i v ft = + let size = BatFingerTree.size ft in + if i < 0 || i > size then invalid_arg "Merkle.emplace: index out of bounds" + else if size = 0 then BatFingerTree.singleton v + else if i = size then BatFingerTree.snoc ft v + else + let fl, fr = BatFingerTree.split_at ft i in + BatFingerTree.singleton v |> BatFingerTree.append fl |> (Fun.flip BatFingerTree.append) fr + + let insert1 key value node = + let i, present = lookup1 (keys_of node) key in + match node with + | Leaf ({keys; values} as leaf) -> + if present then Leaf {leaf with values= BatFingerTree.set values i value} + else Leaf {keys= emplace i key keys; values= emplace i value values} + (* When in danger or in doubt: run in circles, scream and shout. *) + | Trunk _ -> failwith "Cannot insert a value on a trunk node. This is a bug in RNT!" + + let pivot_at ft i = + let l, r' = BatFingerTree.split_at ft i in + let r, p = BatFingerTree.front_exn r' in + l, p, r + + let split_at pivot = function + | Leaf {keys; values} -> + let kl, kr = BatFingerTree.split_at keys pivot in + let vl, vr = BatFingerTree.split_at values pivot in + let p = BatFingerTree.get kr 0 in + Leaf {keys= kl; values= vl}, p, Leaf {keys= kr; values= vr} + | Trunk {keys; children} -> + let kl, kp, kr = pivot_at keys pivot in + let cl, cr = BatFingerTree.split_at children (pivot + 1) in + Trunk {keys= kl; children= cl}, kp, Trunk {keys= kr; children= cr} + + (* FIXME: this works out to a geometric distribution with roughly 64 keys per node. Some of the consequences of this are that: - most of our nodes will end up with one or a few elements, which would make our trees taller than they would normally need to be @@ -251,98 +255,94 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct node size. See https://www.dolthub.com/docs/architecture/storage-engine/prolly-tree/#controlling-chunk-size *) - let should_split = Concepts.Hash.pick 6 - - let hash_of_keys ks = - let buffer = Buffer.create 1024 in - BatFingerTree.iter - (fun k -> - K.encode k - |> Concepts.Blob.bytes_of_blob - |> Buffer.add_bytes buffer) - ks; - Concepts.Hash.hash_of_bytes (Buffer.to_bytes buffer) - - let split_position keys = - let rec loop left right = - match BatFingerTree.front right with - | None -> None - | Some (tail, head) -> - (* TODO: rolling hash *) - let left' = BatFingerTree.snoc left head in - let hash = hash_of_keys left' in - if should_split hash then - Some (BatFingerTree.size left) - else - loop left' tail - in - loop BatFingerTree.empty keys - - let commit_node tx node = - let open Utilities.Result in - match split_position (keys_of node) with - | Some i -> - let l, p, r = split_at i node in - let* l_addr = persist tx l in - let* r_addr = persist tx r in - Ok (Split (l_addr, p, r_addr)) - | None -> - let* addr = persist tx node in - Ok (Update (addr, node)) - - let rec insert' tx key value node = - let open Utilities.Result in - match node with - | Leaf _ -> - insert1 key value node - |> commit_node tx - | Trunk { keys; children } -> - let i, found = lookup1 keys key in - let i = if found then i+1 else i in - let* child = BatFingerTree.get children i |> find' tx in - let* r = insert' tx key value child in - match r with - | Update (addr, _) -> - Trunk { keys; children = BatFingerTree.set children i addr } - |> commit_node tx - | Split (l, p, r) -> - Trunk { keys = emplace i p keys; - children = BatFingerTree.set children i l |> emplace (i + 1) r } - |> commit_node tx - - let insert tx key value node = - let open Utilities.Result in - let* op = insert' tx key value node in - match op with - | Update (_, node) -> Ok node - | Split (l, p, r) -> - let new_root = - Trunk { keys = BatFingerTree.singleton p; - children = BatFingerTree.empty - |> (Fun.flip BatFingerTree.snoc) l - |> (Fun.flip BatFingerTree.snoc) r } in - let* _ = persist tx new_root in - Ok new_root - - let remove tx key node = failwith "TODO" [@@warning "-27"] - - let rec fold_left tx f acc = - let open Utilities.Result in - function - | Leaf { keys; values } -> - Utilities.FingerTree.zip keys values - |> BatFingerTree.fold_left (fun acc (k, v) -> f acc k v) acc - |> Result.ok - | Trunk { children; _ } -> - BatFingerTree.fold_left - (fun acc addr -> - let* acc = acc in - let* node = find' tx addr in - fold_left tx f acc node) - (Ok acc) children - - let keys tx node = fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node -end + let should_split = Concepts.Hash.pick 6 + + let hash_of_keys ks = + let buffer = Buffer.create 1024 in + BatFingerTree.iter + (fun k -> K.encode k |> Concepts.Blob.bytes_of_blob |> Buffer.add_bytes buffer) + ks; + Concepts.Hash.hash_of_bytes (Buffer.to_bytes buffer) + + let split_position keys = + let rec loop left right = + match BatFingerTree.front right with + | None -> None + | Some (tail, head) -> + (* TODO: rolling hash *) + let left' = BatFingerTree.snoc left head in + let hash = hash_of_keys left' in + if should_split hash then Some (BatFingerTree.size left) else loop left' tail + in + loop BatFingerTree.empty keys + + let commit_node tx node = + let open Utilities.Result in + match split_position (keys_of node) with + | Some i -> + let l, p, r = split_at i node in + let* l_addr = persist tx l in + let* r_addr = persist tx r in + Ok (Split (l_addr, p, r_addr)) + | None -> + let* addr = persist tx node in + Ok (Update (addr, node)) + + let rec insert' tx key value node = + let open Utilities.Result in + match node with + | Leaf _ -> insert1 key value node |> commit_node tx + | Trunk {keys; children} -> ( + let i, found = lookup1 keys key in + let i = if found then i + 1 else i in + let* child = BatFingerTree.get children i |> find' tx in + let* r = insert' tx key value child in + match r with + | Update (addr, _) -> + Trunk {keys; children= BatFingerTree.set children i addr} |> commit_node tx + | Split (l, p, r) -> + Trunk + { keys= emplace i p keys; + children= BatFingerTree.set children i l |> emplace (i + 1) r } + |> commit_node tx ) + + let insert tx key value node = + let open Utilities.Result in + let* op = insert' tx key value node in + match op with + | Update (_, node) -> Ok node + | Split (l, p, r) -> + let new_root = + Trunk + { keys= BatFingerTree.singleton p; + children= + BatFingerTree.empty + |> (Fun.flip BatFingerTree.snoc) l + |> (Fun.flip BatFingerTree.snoc) r } + in + let* _ = persist tx new_root in + Ok new_root + + let remove tx key node = failwith "TODO" [@@warning "-27"] + + let rec fold_left tx f acc = + let open Utilities.Result in + function + | Leaf {keys; values} -> + Utilities.FingerTree.zip keys values + |> BatFingerTree.fold_left (fun acc (k, v) -> f acc k v) acc + |> Result.ok + | Trunk {children; _} -> + BatFingerTree.fold_left + (fun acc addr -> + let* acc = acc in + let* node = find' tx addr in + fold_left tx f acc node ) + (Ok acc) children + + let keys tx node = + fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node + end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig module Tree : module type of Make (S) (K) @@ -350,83 +350,90 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA type address = Concepts.Hash.hash type node - val with_batch: S.transaction -> (unit -> (node, Concepts.Condition.condition) result) -> (node, Concepts.Condition.condition) result + val with_batch : + S.transaction -> + (unit -> (node, Concepts.Condition.condition) result) -> + (node, Concepts.Condition.condition) result val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result val from : Tree.node -> node val into : node -> Tree.node - val empty : node val empty_under : S.transaction -> (address, Concepts.Condition.condition) result - val hash_of : node -> address - val insert : S.transaction -> K.t -> V.t -> node -> (node, Concepts.Condition.condition) result val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result val mem : S.transaction -> K.t -> node -> (bool, 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 - module Tree = Make (S) (K) - module SI = Storage.Make (S) - - type address = Tree.address - type node = Tree.node - - open Utilities.Result - - let intern tx v = - let data = V.encode v in - let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx (S.Hash addr) data in - Ok addr - - let retrieve tx addr = SI.get_req tx (S.Hash addr) |> fmap V.decode - - let find = Tree.find - let from x = x - let into x = x - let empty = Tree.empty - let empty_under = Tree.empty_under - let hash_of = Tree.hash_of - let with_batch = Tree.with_batch - - let insert tx k v node = - let* addr = intern tx v in - Tree.insert tx k addr node + val fold_left : + S.transaction -> + ('c -> K.t -> V.t -> 'c) -> + 'c -> + node -> + ('c, Concepts.Condition.condition) result - let remove = Tree.remove + val iter : + S.transaction -> (K.t -> V.t -> 'a) -> node -> (unit, Concepts.Condition.condition) result - let lookup tx k node = - let* addr = Tree.lookup tx k node in - match addr with - | None -> Ok None - | Some addr -> retrieve tx addr |> Result.map Option.some - - let mem tx k node = Tree.lookup tx k node |> Result.map Option.is_some - - let fold_left tx f acc node = - Tree.fold_left tx - (fun acc k addr -> - let* acc = acc in - let* v = retrieve tx addr in - Ok (f acc k v)) - (Ok acc) node - |> Result.join - - let iter tx f node = - fold_left tx - (fun _ k v -> f k v |> ignore) - () node - - let keys = Tree.keys + 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 + module Tree = Make (S) (K) + module SI = Storage.Make (S) + + type address = Tree.address + type node = Tree.node + + open Utilities.Result + + let intern tx v = + let data = V.encode v in + let addr = Concepts.Hash.hash_of_blob data in + let* () = S.put tx (S.Hash addr) data in + Ok addr + + let retrieve tx addr = SI.get_req tx (S.Hash addr) |> fmap V.decode + let find = Tree.find + let from x = x + let into x = x + let empty = Tree.empty + let empty_under = Tree.empty_under + let hash_of = Tree.hash_of + let with_batch = Tree.with_batch + + let insert tx k v node = + let* addr = intern tx v in + Tree.insert tx k addr node + + let remove = Tree.remove + + let lookup tx k node = + let* addr = Tree.lookup tx k node in + match addr with None -> Ok None | Some addr -> retrieve tx addr |> Result.map Option.some + + let mem tx k node = Tree.lookup tx k node |> Result.map Option.is_some + + let fold_left tx f acc node = + Tree.fold_left tx + (fun acc k addr -> + let* acc = acc in + let* v = retrieve tx addr in + Ok (f acc k v) ) + (Ok acc) node + |> Result.join + + let iter tx f node = fold_left tx (fun _ k v -> f k v |> ignore) () node + let keys = Tree.keys + end + module StringKey : KEY with type t = string = struct type t = string diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index c8ffa62..602f3a9 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -1,30 +1,36 @@ 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 } + 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 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)) + 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) + 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 fields {relations} = let open Concepts.Encoding in ["relations", Value.bencode_of_hash relations] @@ -32,47 +38,45 @@ module Make (S : Abstract.Storage.STORAGE) = struct let open Utilities.Result in let open Concepts.Encoding in let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in - Ok { relations } + Ok {relations} end let encode = Representation.to_blob let decode = Representation.of_blob - 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 = - 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 + 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 = + 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 = 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 + 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 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) + 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 fc58dad..2df41e6 100644 --- a/lib/kernel/Multigroup.mli +++ b/lib/kernel/Multigroup.mli @@ -3,7 +3,6 @@ module Make (S : Abstract.Storage.STORAGE) : sig 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 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 728c307..340e813 100644 --- a/lib/kernel/Namespace.ml +++ b/lib/kernel/Namespace.ml @@ -1,39 +1,30 @@ -class namespace = object (self) - inherit Lifecycle.null - inherit Identity.of_id +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 + method protocols = Protocols.[Directory.make self; Registry.make self] - method to_string = "namespace" + method update key reference value = + match + Utilities.Atomic.mswap entries (fun e -> + if BatMap.find_opt key e = reference then + match value with + | Some v -> Ok (BatMap.add key v e) + | None -> Ok (BatMap.remove key e) + else Error () ) + with + | Ok _ -> Ok true + | Error _ -> Ok false - val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = - Atomic.make BatMap.empty + method list = Atomic.get entries |> BatMap.keys |> BatFingerTree.of_enum |> Result.ok - method protocols = Protocols.[Directory.make self; Registry.make self] - - method update key reference value = - match - Utilities.Atomic.mswap entries - (fun e -> - if BatMap.find_opt key e = reference then - match value with - | Some v -> Ok (BatMap.add key v e) - | None -> Ok (BatMap.remove key e) - else - Error ()) - with - | Ok _ -> Ok true - | Error _ -> Ok false - - method list = - Atomic.get entries - |> BatMap.keys - |> BatFingerTree.of_enum - |> Result.ok - - method find key = - Atomic.get entries - |> BatMap.find_opt key - |> Utilities.Option.fmap Protocols.Handle.copy - |> Result.ok -end + method find key = + Atomic.get entries + |> BatMap.find_opt key + |> Utilities.Option.fmap Protocols.Handle.copy + |> Result.ok + end let make () = Protocols.Handle.make (new namespace) diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index b83c9b2..f34abe2 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -1,38 +1,42 @@ type t = string list let this = [] -let (@/) x y = x::y +let ( @/ ) x y = x :: y let to_string path = path |> List.map (fun x -> - let str = BatString.replace ~str:x ~sub:"^" ~by:"^^" |> snd in - BatString.replace ~str ~sub:"/" ~by:"^/" |> snd) + let str = BatString.replace ~str:x ~sub:"^" ~by:"^^" |> snd in + BatString.replace ~str ~sub:"/" ~by:"^/" |> snd ) |> BatIO.to_string (BatList.print ~first:"/" ~last:"" ~sep:"/" BatString.print) module Error = struct open Concepts.Condition - 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 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)) end let walking f g handle path = let rec walk handle = function | [] -> g handle - | x::xs -> - let open Utilities.Result in - let open Protocols in - 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 elem -> f x handle (fun () -> walk elem xs) + | x :: xs -> ( + let open Utilities.Result in + let open Protocols in + 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 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))) + |> Result.map_error + Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) let lookup = walking (fun _ _ f -> f ()) Result.ok diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli index ece0615..198ef83 100644 --- a/lib/kernel/Path.mli +++ b/lib/kernel/Path.mli @@ -1,9 +1,20 @@ type t val this : t -val (@/) : string -> t -> t - +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 +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 b159e00..4c96bc3 100644 --- a/lib/kernel/Prototype.ml +++ b/lib/kernel/Prototype.ml @@ -1,24 +1,24 @@ -let mixture ps = Protocols.Handle.make @@ - object - inherit Lifecycle.null - inherit Identity.of_id (* Should we allow the user to override this? *) +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 + method to_string = "mixture" + end - method protocols = ps - - method to_string = "mixture" - end - -let rec mixture_of value f = - mixture (f (fun value' -> mixture_of value' f) value) +let rec mixture_of value f = mixture (f (fun value' -> mixture_of value' f) value) module Error = struct open Concepts.Condition - let invalid_property key = condition "invalid-property" "The specified key does not correspond to any property of the object" - ("key" |=| Concepts.Value.String key) + let invalid_property key = + condition "invalid-property" + "The specified key does not correspond to any property of the object" + ("key" |=| Concepts.Value.String key) - let deletion_not_supported () = condition "deletion-not-supported" "Attempting to delete an object property" - empty + let deletion_not_supported () = + condition "deletion-not-supported" "Attempting to delete an object property" empty end module Addressable = struct @@ -26,75 +26,79 @@ module Addressable = struct module Tree = Merkle.Make (S) (K) let make ~node = - Protocols.Addressable.make @@ - object - method address = Tree.hash_of node - end + Protocols.Addressable.make + @@ object + method address = Tree.hash_of node + end end end module Associative = struct let of_properties props = - Protocols.Associative.make @@ - object - val props = BatList.to_seq props |> BatMap.of_seq + Protocols.Associative.make + @@ object + val props = BatList.to_seq props |> BatMap.of_seq - method update key value = - match BatMap.find_opt key props with - | None -> Error (Error.invalid_property key) - | Some f -> f value - end + method update key value = + match BatMap.find_opt key props with + | None -> Error (Error.invalid_property key) + | Some f -> f value + end - let update_only f = function - | None -> Error (Error.deletion_not_supported ()) - | Some x -> f x + let update_only f = function None -> Error (Error.deletion_not_supported ()) | Some x -> f x module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) = struct module Tree = Merkle.Make (S) (K) module SI = Storage.Make (S) let make ~storage ~constructor ~node = - Protocols.Associative.make @@ - object - method update key value = - (* TODO: read-only transactions *) - SI.with_transaction storage (fun tx -> - let open Utilities.Result in - let open Protocols in - let* node' = match value with - | None -> Tree.remove tx key node - | Some h -> - let* addressable = Handle.require Addressable.from h in - let addr = Addressable.address addressable in - Tree.insert tx key addr node - in - constructor node') - end + Protocols.Associative.make + @@ object + method update key value = + (* TODO: read-only transactions *) + SI.with_transaction storage (fun tx -> + let open Utilities.Result in + let open Protocols in + let* node' = + match value with + | None -> Tree.remove tx key node + | Some h -> + let* addressable = Handle.require Addressable.from h in + let addr = Addressable.address addressable in + Tree.insert tx key addr node + in + constructor node' ) + end end 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 + 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 Tree = 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 Tree.keys node) - method find k = SI.with_transaction storage (fun tx -> Tree.lookup tx k node) - |> Utilities.Result.fmap (function - | None -> Ok None - | Some x -> constructor x |> Result.map (Option.some)) - end + Protocols.Directory.make + @@ object + method list = SI.with_transaction storage (Fun.flip Tree.keys node) + + method find k = + SI.with_transaction storage (fun tx -> Tree.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 index 919f5d3..db22b63 100644 --- a/lib/kernel/Prototype.mli +++ b/lib/kernel/Prototype.mli @@ -1,29 +1,52 @@ -val mixture_of : 'a -> (('a -> Protocols.Handle.t) -> 'a -> Protocols.Handle.protocol list) -> Protocols.Handle.t +val mixture_of : + 'a -> (('a -> Protocols.Handle.t) -> 'a -> Protocols.Handle.protocol list) -> Protocols.Handle.t + 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 OfTree + (S : Abstract.Storage.STORAGE) + (K : Merkle.KEY with type t = string) + (V : Merkle.VALUE) : sig module Tree : module type of Merkle.Interface (S) (K) (V) - val make : storage:S.connection -> constructor:(V.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Tree.node -> Protocols.Handle.protocol + + val make : + storage:S.connection -> + constructor:(V.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> + node:Tree.node -> + Protocols.Handle.protocol end end module Associative : sig - val of_properties : (string * (Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result)) list -> Protocols.Handle.protocol + val of_properties : + ( string + * (Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result) ) + list -> + Protocols.Handle.protocol - val update_only : (Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> (Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result) + val update_only : + (Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> + Protocols.Handle.t option -> + (Protocols.Handle.t, Concepts.Condition.condition) result module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) : sig module Tree : module type of Merkle.Make (S) (K) - val make : storage:S.connection -> constructor:(Tree.node -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Tree.node -> Protocols.Handle.protocol + + 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 d50735c..da438d2 100644 --- a/lib/kernel/Storage.ml +++ b/lib/kernel/Storage.ml @@ -1,14 +1,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct module Pointer = struct - type 'a t = { - addr : S.address; - loader : S.transaction -> S.address -> ('a, Concepts.Condition.condition) result - } - - let make loader addr = { addr; loader } - let address_of { addr; _ } = addr - let swap { loader; _ } addr = make loader addr - let deref tx { addr; loader } = loader tx addr + type 'a t = + { addr: S.address; + loader: S.transaction -> S.address -> ('a, Concepts.Condition.condition) result } + + let make loader addr = {addr; loader} + let address_of {addr; _} = addr + let swap {loader; _} addr = make loader addr + let deref tx {addr; loader} = loader tx addr end let as_hash = function @@ -16,25 +15,26 @@ module Make (S : Abstract.Storage.STORAGE) = struct | _ -> 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.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?" + 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 - let* () = S.commit tx in - Ok value + let open Utilities.Result in + let* () = S.commit tx in + Ok value | Error condition -> - let _ = S.abort tx in - Error condition + let _ = S.abort tx in + Error condition let within start connection body = let open Utilities.Result in @@ -51,7 +51,5 @@ module Make (S : Abstract.Storage.STORAGE) = struct Ok address let get_req tx addr = - S.get tx addr - |> Utilities.Result.fmap (Option.to_result ~none:(Error.missing_data 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 53bb666..92f602d 100644 --- a/lib/kernel/Storage.mli +++ b/lib/kernel/Storage.mli @@ -2,7 +2,9 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig module Pointer : sig type 'a t - val make : (S.transaction -> S.address -> ('a, Concepts.Condition.condition) result) -> S.address -> '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 @@ -10,9 +12,23 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig 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 with_read : 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 + 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 with_read : + 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 diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index 52ce83c..f90ddff 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -87,7 +87,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct let encode = Representation.to_blob let decode = Representation.of_blob - let schematics {schematics; _} = schematics let predicate {predicate; _} = predicate let local_constraints {local_constraints; _} = local_constraints @@ -119,9 +118,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* kvs = Concepts.Encoding.Bencode.as_dict fields in kvs |> List.map (fun (name, domain) -> - Concepts.Encoding.Bencode.as_string domain - |> Result.map (fun domain -> - (name, {Protocols.Schematics.domain; provenance= []}) ) ) + Concepts.Encoding.Bencode.as_string domain + |> Result.map (fun domain -> name, {Protocols.Schematics.domain; provenance= []}) ) |> Utilities.List.sequence |> Result.map BatMap.String.of_list @@ -150,9 +148,7 @@ 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 @@ -172,15 +168,15 @@ module Make (S : Abstract.Storage.STORAGE) = struct unused here: this enumeration reads through its own cursor-lifetime transaction and needs no name resolution, but cancellation should eventually be checked between tuples. *) method enumerate = enumerate storage relation - method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = Ok declaration method generate binding = generate storage relation binding method protocols : Protocols.Handle.protocol list = - [ Protocols.Relation.make self - ; Protocols.Enumerable.make self - ; Protocols.Generative.make self - ; Protocols.Schematics.make self ] + [ Protocols.Relation.make self; + Protocols.Enumerable.make self; + Protocols.Generative.make self; + Protocols.Schematics.make self ] + method hash = hash relation end @@ -188,7 +184,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct the description and modes are served from it on every request. *) let instantiate tx conn relation = schema_of tx relation - |> Result.map (fun description -> new relation conn relation description |> Protocols.Handle.make) + |> Result.map (fun description -> + new relation conn relation description |> Protocols.Handle.make ) let make conn ~schematics ?predicate ?local_constraints ?indexes () = let open Utilities.Result in @@ -203,9 +200,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct Representation.of_blob data let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation) - - let load tx conn addr = - load_value tx addr |> Utilities.Result.fmap (instantiate tx conn) + let load tx conn addr = load_value tx addr |> Utilities.Result.fmap (instantiate tx 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 a36c802..98f1e8f 100644 --- a/lib/kernel/SubstantialRelation.mli +++ b/lib/kernel/SubstantialRelation.mli @@ -25,7 +25,6 @@ module Make (S : Abstract.Storage.STORAGE) : sig (Protocols.Handle.t, Concepts.Condition.condition) result 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 : diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml index bbc20ab..9dbbc17 100644 --- a/lib/kernel/Tuple.ml +++ b/lib/kernel/Tuple.ml @@ -7,9 +7,10 @@ module Make (S : Abstract.Storage.STORAGE) = struct let unknown_attribute name = condition "unknown-attribute" "No such attribute on this tuple" ("attribute" |=| Concepts.Value.String name) + let malformed_value () = - condition "malformed-tuple-value" - "A tuple field did not conform to what was expected" empty + condition "malformed-tuple-value" "A tuple field did not conform to what was expected" empty + let incomplete_tuple addr = condition "incomplete-tuple" "A stored tuple is missing part of its expected structure. Is your storage corrupted?" @@ -24,9 +25,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct let encode value = let open Concepts.Encoding in Bencode.to_blob - (match value with - | Concepts.Value.String s -> Bencode.Tagged ('s', Bencode.String s) - | Concepts.Value.Integer n -> Bencode.Tagged ('i', Bencode.Int n)) + ( match value with + | Concepts.Value.String s -> Bencode.Tagged ('s', Bencode.String s) + | Concepts.Value.Integer n -> Bencode.Tagged ('i', Bencode.Int n) ) let decode blob = let open Utilities.Result in @@ -48,7 +49,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct over an in-memory storage. Consider later splitting [t] into resident (an address) and ephemeral (an in-memory attribute map) forms instead. *) - type t = { type_ : string; attributes : AttributeM.address } + type t = {type_: string; attributes: AttributeM.address} module rec Representation : (Concepts.Encoding.Record.S with type t = t) = Concepts.Encoding.Record.Make (Body) @@ -59,26 +60,24 @@ module Make (S : Abstract.Storage.STORAGE) = struct let tag = 'T' let malformed = Error.malformed_value - let fields { type_; attributes } = + let fields {type_; attributes} = let open Concepts.Encoding in - [ "type", Bencode.String type_; - "attributes", Value.bencode_of_hash attributes ] + ["type", Bencode.String type_; "attributes", Value.bencode_of_hash attributes] let of_fields data = let open Utilities.Result in let open Concepts.Encoding in let* type_ = Bencode.field "type" data |> fmap Bencode.as_string in let* attributes = Bencode.field "attributes" data |> fmap Value.hash_of_bencode in - Ok { type_; attributes } + Ok {type_; attributes} end let encode = Representation.to_blob let decode = Representation.of_blob let hash tuple = Representation.to_blob tuple |> Concepts.Hash.hash_of_blob + let type_of {type_; _} = type_ - let type_of { type_; _ } = type_ - - let node tx { attributes; _ } = + let node tx {attributes; _} = let open Utilities.Result in AttributeM.find tx attributes |> fmap (Option.to_result ~none:(Error.incomplete_tuple attributes)) @@ -86,7 +85,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let empty tx ~type_ () = let open Utilities.Result in let* attributes = AttributeM.empty_under tx in - Ok { type_; attributes } + Ok {type_; attributes} let make tx ~type_ attributes = let open Utilities.Result in @@ -96,10 +95,10 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> BatEnum.fold (fun node (name, value) -> let* node = node in - AttributeM.insert tx name value node) - (Ok AttributeM.empty)) + AttributeM.insert tx name value node ) + (Ok AttributeM.empty) ) in - Ok { type_; attributes = AttributeM.hash_of node } + Ok {type_; attributes= AttributeM.hash_of node} let attribute tx tuple name = let open Utilities.Result in @@ -114,30 +113,27 @@ module Make (S : Abstract.Storage.STORAGE) = struct (fun acc name value -> BatMap.String.add name value acc) BatMap.String.empty node - class tuple ~relation conn value node = object (self) - inherit Lifecycle.null - - method to_string = "tuple" - - val tuple = value - val storage = conn - val node = node - - method describe () = - let open Utilities.Result in - let* attributes = - SI.with_transaction storage (fun tx -> - AttributeM.fold_left tx - (fun acc name value -> BatMap.String.add name (Attribute.domain value) acc) - BatMap.String.empty node) - in - Ok (Protocols.Schematics.Tuple { Protocols.Schematics.relation; attributes }) - - method protocols : Protocols.Handle.protocol list = - [Protocols.Schematics.make self] - - method hash = hash tuple - end + class tuple ~relation conn value node = + object (self) + inherit Lifecycle.null + method to_string = "tuple" + val tuple = value + val storage = conn + val node = node + + method describe () = + let open Utilities.Result in + let* attributes = + SI.with_transaction storage (fun tx -> + AttributeM.fold_left tx + (fun acc name value -> BatMap.String.add name (Attribute.domain value) acc) + BatMap.String.empty node ) + in + Ok (Protocols.Schematics.Tuple {Protocols.Schematics.relation; attributes}) + + method protocols : Protocols.Handle.protocol list = [Protocols.Schematics.make self] + method hash = hash tuple + end let wrap ~relation conn value = let open Utilities.Result in -- cgit v1.2.3