diff options
| -rw-r--r-- | lib/kernel/Initialization.ml | 100 | ||||
| -rw-r--r-- | lib/kernel/Initialization.mli | 19 | ||||
| -rw-r--r-- | test/test_rnt.ml | 1 | ||||
| -rw-r--r-- | test/unit/kernel/Initialization.ml | 69 |
4 files changed, 0 insertions, 189 deletions
diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml deleted file mode 100644 index d15b65b..0000000 --- a/lib/kernel/Initialization.ml +++ /dev/null @@ -1,100 +0,0 @@ -type address = Concepts.Hash.hash - -type t = - { default_branch: string; - branches: address } - -let fixed_label = "rnt.boot" -let fixed_label_address = Concepts.Hash.hash_of_bytes (Bytes.of_string fixed_label) - -module Field = struct - let default_branch = "default_branch" - let branches = "branches" -end - -module Error = struct - open Concepts.Condition - - let malformed_initialization () = - condition "initialization-malformed" - "An initialization representation did not conform to what was expected" empty - - let malformed_hash length = - condition "initialization-malformed-hash" - "An initialization address was not a valid hash" - ("length" |=| Concepts.Value.Integer length) - - let missing_target address = - condition "initialization-target-missing" - "The fixed initialization label points at a missing object" - ("address" |=| Concepts.Value.String (Concepts.Hash.to_raw_string address)) -end - -let make ~default_branch ~branches = {default_branch; branches} - -let default_branch initialization = initialization.default_branch -let branches initialization = initialization.branches - -module Body = struct - type nonrec t = t - - let tag = 'i' - let malformed = Error.malformed_initialization - - let equal left right = - String.equal left.default_branch right.default_branch - && Concepts.Hash.hash_equals left.branches right.branches - - let fields initialization = - [ Field.default_branch, Concepts.Object.Field.string initialization.default_branch; - Field.branches, Concepts.Object.Field.address initialization.branches ] - - let of_fields data = - let open Utilities.Result in - let* default_branch = - Concepts.Object.Field.require_string Field.default_branch data - in - let* branches = - Concepts.Object.Field.require_address ~malformed:Error.malformed_hash Field.branches data - in - Ok {default_branch; branches} -end - -include (Concepts.Object.Codec.Make (Body) : Concepts.Object.S with type t := t) - -let address initialization = to_blob initialization |> Concepts.Hash.hash_of_blob - -let address_to_blob address = - Concepts.Object.Field.address address |> Concepts.Codec.Bencode.to_blob - -let address_of_blob blob = - let open Utilities.Result in - let* data = Concepts.Codec.Bencode.of_blob blob in - let* raw = Concepts.Codec.Bencode.as_string data in - if String.length raw = Concepts.Hash.size then Ok (Concepts.Hash.of_raw_string raw) - else Error (Error.malformed_hash (String.length raw)) - -module Make (Store : Abstract.Storage.STORAGE) = struct - let register tx initialization = - let open Utilities.Result in - let blob = to_blob initialization in - let initialization_address = Concepts.Hash.hash_of_blob blob in - let* () = Store.put tx initialization_address blob in - let* () = Store.put tx fixed_label_address (address_to_blob initialization_address) in - Ok initialization_address - - let load tx = - let open Utilities.Result in - let* label = Store.get tx fixed_label_address in - match label with - | None -> Ok None - | Some label -> - let* initialization_address = address_of_blob label in - let* initialization = Store.get tx initialization_address in - begin match initialization with - | None -> Error (Error.missing_target initialization_address) - | Some initialization -> - let* initialization = of_blob initialization in - Ok (Some initialization) - end -end diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli deleted file mode 100644 index 35e6f22..0000000 --- a/lib/kernel/Initialization.mli +++ /dev/null @@ -1,19 +0,0 @@ -type address = Concepts.Hash.hash - -type t - -val fixed_label : string -val fixed_label_address : address - -include Concepts.Object.S with type t := t - -val make : default_branch:string -> branches:address -> t - -val default_branch : t -> string -val branches : t -> address -val address : t -> address - -module Make (Store : Abstract.Storage.STORAGE) : sig - val register : Store.transaction -> t -> (address, Concepts.Condition.condition) result - val load : Store.transaction -> (t option, Concepts.Condition.condition) result -end diff --git a/test/test_rnt.ml b/test/test_rnt.ml index f825c51..a2a8e84 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -1,6 +1,5 @@ let all_suites = Unit.Concepts.Serialization.suites () - @ Unit.Kernel.Initialization.suites () @ Unit.Backend.Storage.suites () @ Unit.Backend.Lifecycle.suites () diff --git a/test/unit/kernel/Initialization.ml b/test/unit/kernel/Initialization.ml deleted file mode 100644 index c0e9c17..0000000 --- a/test/unit/kernel/Initialization.ml +++ /dev/null @@ -1,69 +0,0 @@ -open Rnt - -module Hash = Concepts.Hash -module Initialization = Rnt.Kernel.Initialization - -module Memory_storage = struct - type connection = (Hash.hash, Concepts.Representation.blob) Hashtbl.t - type transaction = connection - - let connect _ = Ok (Hashtbl.create 16) - let start conn = Ok conn - let commit _ = Ok () - let abort _ = Ok () - let get tx address = Ok (Hashtbl.find_opt tx address) - let put tx address blob = Hashtbl.replace tx address blob; Ok () -end - -module Store_initialization = Initialization.Make (Memory_storage) - -let fail_condition c = Alcotest.fail (Concepts.Condition.to_string_hum c) -let hash text = Hash.hash_of_bytes (Bytes.of_string text) - -let check_hash label expected actual = - Alcotest.(check bool) label true (Hash.hash_equals expected actual) - -let test_initialization_round_trips () = - let expected = - Initialization.make ~default_branch:"master" ~branches:(hash "branch-index") - in - match Initialization.(expected |> to_bytes |> of_bytes) with - | Ok actual -> - Alcotest.(check string) - "default branch" - (Initialization.default_branch expected) - (Initialization.default_branch actual); - check_hash "branches" (Initialization.branches expected) (Initialization.branches actual) - | Error c -> fail_condition c - -let test_registers_under_fixed_label () = - let tx = Hashtbl.create 16 in - let expected = - Initialization.make ~default_branch:"master" ~branches:(hash "branch-index") - in - let before, registered, after = - begin - let open Utilities.Result in - let* before = Store_initialization.load tx in - let* registered = Store_initialization.register tx expected in - let* after = Store_initialization.load tx in - Ok (before, registered, after) - end - |> Helpers.condition_as_failure - in - Alcotest.(check (option bool)) - "missing before registration" None (Option.map (Fun.const true) before); - check_hash "registered address" (Initialization.address expected) registered; - Alcotest.(check bool) - "fixed label exists" true - (Hashtbl.mem tx Initialization.fixed_label_address); - match after with - | Some actual -> Alcotest.(check bool) "loaded object" true (Initialization.equal expected actual) - | None -> Alcotest.fail "expected initialization object after registration" - -let suites () = - [ ( "kernel/initialization", - [ Alcotest.test_case "initialization round-trips" `Quick - test_initialization_round_trips; - Alcotest.test_case "registers under fixed label" `Quick - test_registers_under_fixed_label ] ) ] |