diff options
| -rw-r--r-- | lib/Utilities.ml | 13 | ||||
| -rw-r--r-- | lib/Utilities.mli | 1 | ||||
| -rw-r--r-- | lib/kernel/Branch.ml | 15 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.ml | 14 | ||||
| -rw-r--r-- | lib/protocols/Addressable.ml | 13 | ||||
| -rw-r--r-- | lib/protocols/Addressable.mli | 11 | ||||
| -rw-r--r-- | lib/protocols/Context.ml | 4 | ||||
| -rw-r--r-- | lib/protocols/Handle.ml | 9 | ||||
| -rw-r--r-- | lib/protocols/Handle.mli | 2 |
9 files changed, 64 insertions, 18 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml index 9bff69b..404d8aa 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -4,6 +4,14 @@ module Ordering = struct let of_int x = if x < 0 then Smaller else if x > 0 then Greater else Equal end +module Option = struct + let ( let* ) = Option.bind + let fmap f m = Option.bind m f + let sequence = function + | None -> Ok None + | Some x -> Result.map Option.some x +end + module Result = struct let ( let* ) = Result.bind let fmap f m = Result.bind m f @@ -80,11 +88,6 @@ module FingerTree = struct |> Fun.flip BatIO.to_string ss end -module Option = struct - let ( let* ) = Option.bind - let fmap f m = Option.bind m f -end - module Atomic = struct let rec swap atom f = let v = Atomic.get atom in diff --git a/lib/Utilities.mli b/lib/Utilities.mli index eae59f9..11c4487 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -17,6 +17,7 @@ end module Option : sig val ( let* ) : 'a option -> ('a -> 'b option) -> 'b option val fmap : ('a -> 'b option) -> 'a option -> 'b option + val sequence : ('a, 'b) result option -> ('a option, 'b) result end module Atomic : sig diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 64f9689..3832a07 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -59,7 +59,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct Ok { multigroups; previous } end - class branch storage value node = object + class branch storage value node = object (self) inherit Lifecycle.null val storage : S.connection = storage @@ -67,15 +67,18 @@ module Make (S : Abstract.Storage.STORAGE) = struct val node = node (* FIXME: can we not place this inside `t`? *) method protocols : Protocols.Handle.protocol list = - [ Prototype.Directory.of_properties - [ "multigroup", Prototype.mixture - [ MMDirectory.make - ~storage ~node - ~constructor:(M.wrap storage) ] ] ] + Protocols.[ Addressable.make self; + Prototype.Directory.of_properties + [ "multigroup", Prototype.mixture + [ MMDirectory.make + ~storage ~node + ~constructor:(M.wrap storage) ] ] ] method hash = Representation.to_blob branch |> Concepts.Hash.hash_of_blob + + method address = self#hash end let load tx conn addr = diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index 016f75a..1162b40 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -51,13 +51,21 @@ module Make (S : Abstract.Storage.STORAGE) = struct 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 - (* FIXME: we should have an addressable protocol rather than assuming the hash is the content store address *) - let reference = Option.map Protocols.Handle.hash reference in - let value = Option.map Protocols.Handle.hash value 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 diff --git a/lib/protocols/Addressable.ml b/lib/protocols/Addressable.ml new file mode 100644 index 0000000..7e97f08 --- /dev/null +++ b/lib/protocols/Addressable.ml @@ -0,0 +1,13 @@ +class type implementation = object + method address : Concepts.Hash.hash +end + +type Handle.protocol += Addressable of implementation + +type t = implementation + +let make impl = Addressable (impl :> implementation) + +let from handle = Handle.into handle (function Addressable impl -> Some impl | _ -> None) + +let address i = Handle.invoke i (fun o -> o#address) diff --git a/lib/protocols/Addressable.mli b/lib/protocols/Addressable.mli new file mode 100644 index 0000000..2d9c14d --- /dev/null +++ b/lib/protocols/Addressable.mli @@ -0,0 +1,11 @@ +type t + +class type implementation = object + method address : Concepts.Hash.hash +end + +val make : #implementation -> Handle.protocol + +val from : Handle.t -> t Handle.interface option + +val address : t Handle.interface -> Concepts.Hash.hash diff --git a/lib/protocols/Context.ml b/lib/protocols/Context.ml deleted file mode 100644 index b7c8a37..0000000 --- a/lib/protocols/Context.ml +++ /dev/null @@ -1,4 +0,0 @@ -type t = - { snapshot : Concepts.Hash.hash - ; root : Handle.t - ; status : unit -> [`Live | `Cancelled | `Exhausted] } diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index 524386b..313a3d4 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -1,5 +1,12 @@ type protocol = .. +module Error = struct + open Concepts.Condition + + let unimplemented_protocol () = condition "unimplemented-protocol" "A required protocol was not implemented by the specified object" + empty +end + class type obj = object method reference : bool method release : unit @@ -45,3 +52,5 @@ let release ({ valid; _ } as handle) = let o = object_of handle in valid := false; o#release + +let require f h = Option.to_result ~none:(Error.unimplemented_protocol ()) (f h) diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index f36c95e..f63bbea 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -22,3 +22,5 @@ val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash + +val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result |