aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Utilities.ml4
-rw-r--r--lib/Utilities.mli1
-rw-r--r--lib/concepts/Encoding.ml31
-rw-r--r--lib/kernel/Branch.ml60
-rw-r--r--lib/kernel/Branch.mli5
-rw-r--r--lib/kernel/BranchManager.ml9
-rw-r--r--lib/kernel/Storage.ml20
-rw-r--r--lib/kernel/Storage.mli3
8 files changed, 125 insertions, 8 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml
index e4ee9c3..9bff69b 100644
--- a/lib/Utilities.ml
+++ b/lib/Utilities.ml
@@ -39,6 +39,10 @@ module List = struct
end
include Generic (ListSequence)
+
+ let hd_opt = function
+ | x::_ -> Some x
+ | [] -> None
end
module FingerTree = struct
diff --git a/lib/Utilities.mli b/lib/Utilities.mli
index f149889..eae59f9 100644
--- a/lib/Utilities.mli
+++ b/lib/Utilities.mli
@@ -11,6 +11,7 @@ end
module List : sig
val sequence : ('a, 'b) result list -> ('a list, 'b) result
+ val hd_opt : 'a list -> 'a option
end
module Option : sig
diff --git a/lib/concepts/Encoding.ml b/lib/concepts/Encoding.ml
index 121e98d..5bb9b16 100644
--- a/lib/concepts/Encoding.ml
+++ b/lib/concepts/Encoding.ml
@@ -62,9 +62,9 @@ let value_of_blob (b : Blob.t) =
condition "codec-missing-field" "A required field is absent"
("field" |=| Value.String key)
- let unexpected_object ~expected ~actual =
+ let unexpected_object ~expected =
condition "codec-unexpected-object" "The decoded object is not of the expected kind"
- ("expected" |=| Value.String expected & "actual" |=| Value.String actual)
+ ("expected" |=| Value.String expected)
end
(* A self-describing serialization used as the uniform wire format for
@@ -211,6 +211,27 @@ module Bencode = struct
| _ -> Error (Error.type_mismatch ~expected:"dict")
end
+module Value = struct
+ let bencode_of_hash hash = Bencode.Tagged ('h', Bencode.String (Hash.to_raw_string hash))
+ let hash_of_bencode value =
+ let open Utilities.Result in
+ Bencode.with_tag 'h' value
+ |> fmap Bencode.as_string
+ |> Result.map Hash.of_raw_string
+
+ let bencode_of_option f option = Bencode.Tagged ('?', Option.map f option
+ |> Option.to_list
+ |> (fun x -> Bencode.List x))
+ let option_of_bencode f value =
+ let open Utilities.Result in
+ Bencode.with_tag '?' value
+ |> fmap Bencode.as_list
+ |> Result.map Utilities.List.hd_opt
+ |> fmap (function
+ | None -> Ok None
+ | Some v -> f v |> Result.map Option.some)
+end
+
module Field = struct
let string value = Bencode.String value
let address address = Bencode.String (Hash.to_raw_string address)
@@ -229,8 +250,6 @@ module Record = struct
module type S = sig
type t
- val equal : t -> t -> bool
-
val to_bencode : t -> Bencode.t
val of_bencode : Bencode.t -> (t, Condition.condition) result
@@ -246,15 +265,13 @@ module Record = struct
val tag : char
val malformed : unit -> Condition.condition
- val equal : t -> t -> bool
val fields : t -> (string * Bencode.t) list
val of_fields : Bencode.t -> (t, Condition.condition) result
end
- module Make (B : BODY) = struct
+ module Make (B : BODY) : S with type t = B.t = struct
type t = B.t
- let equal = B.equal
let to_bencode object_ = Bencode.Tagged (B.tag, Bencode.Dict (B.fields object_))
let of_bencode = function
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
new file mode 100644
index 0000000..2aaa9ca
--- /dev/null
+++ b/lib/kernel/Branch.ml
@@ -0,0 +1,60 @@
+module Multigroup = Merkle.StringKey (* FIXME *)
+
+module Make (S : Abstract.Storage.STORAGE) = struct
+ (* Branch has a name, a set of multigroups, and a backlink to the previous state
+ multigroup has a name and a set of schemas
+ schema has a name and a set of relations
+
+ /branch/master/multigroup/universe/schema/sky/relation/planet
+ *)
+
+ module SI = Storage.Make (S)
+
+ module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (Multigroup)
+
+ 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)
+ 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.
+ (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 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]
+
+ 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 (Fun.flip (SI.Pointer.make) load))) in
+ Ok { multigroups; previous }
+ end
+
+ class branch = object
+ (* TODO *)
+ end
+
+ let load _tx _conn _name _addr = failwith "TODO"
+end
diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli
new file mode 100644
index 0000000..02be2ed
--- /dev/null
+++ b/lib/kernel/Branch.mli
@@ -0,0 +1,5 @@
+module Make (S : Abstract.Storage.STORAGE) : sig
+ type t
+
+ val load : S.transaction -> S.connection -> string -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result
+end
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index bdc461e..cd3c5e2 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -19,6 +19,7 @@ end
module Make (S : Abstract.Storage.STORAGE) = struct
module M = Merkle.Make (S) (Merkle.StringKey)
module SI = Storage.Make (S)
+ module B = Branch.Make (S)
let root_for tx label =
let open Utilities.Result in
@@ -60,7 +61,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx)
- method find _ = failwith "TODO"
+ 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 key head |> Result.map Option.some)
end
let make storage label =
diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml
index e6a84ba..dd06783 100644
--- a/lib/kernel/Storage.ml
+++ b/lib/kernel/Storage.ml
@@ -11,6 +11,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let deref tx { addr; loader } = loader tx addr
end
+ let as_hash = function
+ | S.Hash h -> h
+ | _ -> 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.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?"
+ ("address" |=| Concepts.Value.String (to_hum_string addr))
+ end
+
let finish tx = function
| Ok value ->
let open Utilities.Result in
@@ -31,4 +47,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* () = S.put tx (S.Hash address) blob in
Ok address
+ let get_req tx 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 9a10984..b8c0e5b 100644
--- a/lib/kernel/Storage.mli
+++ b/lib/kernel/Storage.mli
@@ -8,7 +8,10 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig
val deref : S.transaction -> 'a t -> ('a, Concepts.Condition.condition) result
end
+ 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 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
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 15:18:35 +0000