From ed35075fdf3c53edb49b5b87920263a568db2716 Mon Sep 17 00:00:00 2001 From: Sylvain Ribstein Date: Thu, 16 Dec 2021 16:02:54 +0100 Subject: [PATCH 01/11] env: bootstrap env V5 --- src/lib_base/protocol.ml | 6 +- src/lib_base/protocol.mli | 2 +- .../environment_V5.ml | 1360 +++++++++++++++++ .../environment_V5.mli | 152 ++ src/lib_protocol_environment/sigs/dune | 4 +- .../sigs/v0/protocol.mli | 2 +- .../sigs/v1/protocol.mli | 2 +- .../sigs/v2/protocol.mli | 2 +- .../sigs/v3/protocol.mli | 2 +- .../sigs/v4/protocol.mli | 2 +- src/lib_protocol_environment/sigs/v5.dune.inc | 80 + .../sigs/v5/.ocamlformat | 17 + .../sigs/v5/.ocamlformat-ignore | 15 + .../sigs/v5/RPC_answer.mli | 55 + .../sigs/v5/RPC_arg.mli | 64 + .../sigs/v5/RPC_context.mli | 149 ++ .../sigs/v5/RPC_directory.mli | 259 ++++ .../sigs/v5/RPC_path.mli | 50 + .../sigs/v5/RPC_query.mli | 66 + .../sigs/v5/RPC_service.mli | 71 + .../sigs/v5/base58.mli | 44 + src/lib_protocol_environment/sigs/v5/bits.mli | 29 + .../sigs/v5/blake2B.mli | 58 + .../sigs/v5/block_hash.mli | 27 + .../sigs/v5/block_header.mli | 45 + .../sigs/v5/bls12_381.mli | 32 + .../sigs/v5/bls_signature.mli | 62 + .../sigs/v5/bytes.mli | 260 ++++ .../sigs/v5/chain_id.mli | 26 + src/lib_protocol_environment/sigs/v5/char.mli | 54 + .../sigs/v5/compare.mli | 116 ++ .../sigs/v5/context.mli | 324 ++++ .../sigs/v5/context_hash.mli | 47 + .../sigs/v5/data_encoding.mli | 445 ++++++ .../sigs/v5/ed25519.mli | 28 + .../sigs/v5/equality_witness.mli | 62 + .../sigs/v5/error_monad.mli | 224 +++ .../sigs/v5/fallbackArray.mli | 70 + .../sigs/v5/fitness.mli | 28 + .../sigs/v5/format.mli | 747 +++++++++ src/lib_protocol_environment/sigs/v5/hex.mli | 82 + .../sigs/v5/int32.mli | 144 ++ .../sigs/v5/int64.mli | 152 ++ src/lib_protocol_environment/sigs/v5/json.mli | 45 + src/lib_protocol_environment/sigs/v5/list.mli | 938 ++++++++++++ .../sigs/v5/logging.mli | 44 + src/lib_protocol_environment/sigs/v5/lwt.mli | 265 ++++ src/lib_protocol_environment/sigs/v5/map.mli | 152 ++ .../sigs/v5/micheline.mli | 54 + .../sigs/v5/operation.mli | 38 + .../sigs/v5/operation_hash.mli | 27 + .../sigs/v5/operation_list_hash.mli | 27 + .../sigs/v5/operation_list_list_hash.mli | 27 + .../sigs/v5/option.mli | 142 ++ src/lib_protocol_environment/sigs/v5/p256.mli | 28 + .../sigs/v5/pervasives.mli | 482 ++++++ .../sigs/v5/protocol.mli | 44 + .../sigs/v5/protocol_hash.mli | 27 + .../sigs/v5/pvss_secp256k1.mli | 28 + .../sigs/v5/raw_hashes.mli | 36 + .../sigs/v5/result.mli | 160 ++ src/lib_protocol_environment/sigs/v5/s.mli | 406 +++++ .../sigs/v5/sapling.mli | 125 ++ .../sigs/v5/secp256k1.mli | 28 + src/lib_protocol_environment/sigs/v5/seq.mli | 119 ++ src/lib_protocol_environment/sigs/v5/set.mli | 131 ++ .../sigs/v5/signature.mli | 46 + .../sigs/v5/string.mli | 242 +++ .../sigs/v5/tezos_data.mli | 26 + src/lib_protocol_environment/sigs/v5/time.mli | 48 + .../sigs/v5/timelock.mli | 53 + .../sigs/v5/tzEndian.mli | 60 + .../sigs/v5/updater.mli | 295 ++++ src/lib_protocol_environment/sigs/v5/z.mli | 468 ++++++ src/lib_protocol_environment/structs/dune | 4 +- .../structs/v5.dune.inc | 8 + src/lib_validation/block_validation.ml | 11 +- 77 files changed, 10085 insertions(+), 15 deletions(-) create mode 100644 src/lib_protocol_environment/environment_V5.ml create mode 100644 src/lib_protocol_environment/environment_V5.mli create mode 100644 src/lib_protocol_environment/sigs/v5.dune.inc create mode 100644 src/lib_protocol_environment/sigs/v5/.ocamlformat create mode 100644 src/lib_protocol_environment/sigs/v5/.ocamlformat-ignore create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_answer.mli create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_arg.mli create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_context.mli create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_directory.mli create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_path.mli create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_query.mli create mode 100644 src/lib_protocol_environment/sigs/v5/RPC_service.mli create mode 100644 src/lib_protocol_environment/sigs/v5/base58.mli create mode 100644 src/lib_protocol_environment/sigs/v5/bits.mli create mode 100644 src/lib_protocol_environment/sigs/v5/blake2B.mli create mode 100644 src/lib_protocol_environment/sigs/v5/block_hash.mli create mode 100644 src/lib_protocol_environment/sigs/v5/block_header.mli create mode 100644 src/lib_protocol_environment/sigs/v5/bls12_381.mli create mode 100644 src/lib_protocol_environment/sigs/v5/bls_signature.mli create mode 100644 src/lib_protocol_environment/sigs/v5/bytes.mli create mode 100644 src/lib_protocol_environment/sigs/v5/chain_id.mli create mode 100644 src/lib_protocol_environment/sigs/v5/char.mli create mode 100644 src/lib_protocol_environment/sigs/v5/compare.mli create mode 100644 src/lib_protocol_environment/sigs/v5/context.mli create mode 100644 src/lib_protocol_environment/sigs/v5/context_hash.mli create mode 100644 src/lib_protocol_environment/sigs/v5/data_encoding.mli create mode 100644 src/lib_protocol_environment/sigs/v5/ed25519.mli create mode 100644 src/lib_protocol_environment/sigs/v5/equality_witness.mli create mode 100644 src/lib_protocol_environment/sigs/v5/error_monad.mli create mode 100644 src/lib_protocol_environment/sigs/v5/fallbackArray.mli create mode 100644 src/lib_protocol_environment/sigs/v5/fitness.mli create mode 100644 src/lib_protocol_environment/sigs/v5/format.mli create mode 100644 src/lib_protocol_environment/sigs/v5/hex.mli create mode 100644 src/lib_protocol_environment/sigs/v5/int32.mli create mode 100644 src/lib_protocol_environment/sigs/v5/int64.mli create mode 100644 src/lib_protocol_environment/sigs/v5/json.mli create mode 100644 src/lib_protocol_environment/sigs/v5/list.mli create mode 100644 src/lib_protocol_environment/sigs/v5/logging.mli create mode 100644 src/lib_protocol_environment/sigs/v5/lwt.mli create mode 100644 src/lib_protocol_environment/sigs/v5/map.mli create mode 100644 src/lib_protocol_environment/sigs/v5/micheline.mli create mode 100644 src/lib_protocol_environment/sigs/v5/operation.mli create mode 100644 src/lib_protocol_environment/sigs/v5/operation_hash.mli create mode 100644 src/lib_protocol_environment/sigs/v5/operation_list_hash.mli create mode 100644 src/lib_protocol_environment/sigs/v5/operation_list_list_hash.mli create mode 100644 src/lib_protocol_environment/sigs/v5/option.mli create mode 100644 src/lib_protocol_environment/sigs/v5/p256.mli create mode 100644 src/lib_protocol_environment/sigs/v5/pervasives.mli create mode 100644 src/lib_protocol_environment/sigs/v5/protocol.mli create mode 100644 src/lib_protocol_environment/sigs/v5/protocol_hash.mli create mode 100644 src/lib_protocol_environment/sigs/v5/pvss_secp256k1.mli create mode 100644 src/lib_protocol_environment/sigs/v5/raw_hashes.mli create mode 100644 src/lib_protocol_environment/sigs/v5/result.mli create mode 100644 src/lib_protocol_environment/sigs/v5/s.mli create mode 100644 src/lib_protocol_environment/sigs/v5/sapling.mli create mode 100644 src/lib_protocol_environment/sigs/v5/secp256k1.mli create mode 100644 src/lib_protocol_environment/sigs/v5/seq.mli create mode 100644 src/lib_protocol_environment/sigs/v5/set.mli create mode 100644 src/lib_protocol_environment/sigs/v5/signature.mli create mode 100644 src/lib_protocol_environment/sigs/v5/string.mli create mode 100644 src/lib_protocol_environment/sigs/v5/tezos_data.mli create mode 100644 src/lib_protocol_environment/sigs/v5/time.mli create mode 100644 src/lib_protocol_environment/sigs/v5/timelock.mli create mode 100644 src/lib_protocol_environment/sigs/v5/tzEndian.mli create mode 100644 src/lib_protocol_environment/sigs/v5/updater.mli create mode 100644 src/lib_protocol_environment/sigs/v5/z.mli create mode 100644 src/lib_protocol_environment/structs/v5.dune.inc diff --git a/src/lib_base/protocol.ml b/src/lib_base/protocol.ml index 7d1b84707526..9e734572ed80 100644 --- a/src/lib_base/protocol.ml +++ b/src/lib_base/protocol.ml @@ -31,7 +31,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 let compare_version = Stdlib.compare @@ -57,18 +57,20 @@ let module_name_of_env_version = function | V2 -> "V2" | V3 -> "V3" | V4 -> "V4" + | V5 -> "V5" let env_version_encoding = let open Data_encoding in def "protocol.environment_version" @@ conv - (function V0 -> 0 | V1 -> 1 | V2 -> 2 | V3 -> 3 | V4 -> 4) + (function V0 -> 0 | V1 -> 1 | V2 -> 2 | V3 -> 3 | V4 -> 4 | V5 -> 5) (function | 0 -> V0 | 1 -> V1 | 2 -> V2 | 3 -> V3 | 4 -> V4 + | 5 -> V5 | _ -> failwith "unexpected environment version") uint16 diff --git a/src/lib_base/protocol.mli b/src/lib_base/protocol.mli index d8cc47c53857..e5c2a30e2bb7 100644 --- a/src/lib_base/protocol.mli +++ b/src/lib_base/protocol.mli @@ -31,7 +31,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 val component_encoding : component Data_encoding.t diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml new file mode 100644 index 000000000000..4f65d8424552 --- /dev/null +++ b/src/lib_protocol_environment/environment_V5.ml @@ -0,0 +1,1360 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Nomadic Labs. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Shell_error_monad = Error_monad + +type shell_error = error = .. + +open Environment_context +open Environment_protocol_T + +module type V5 = sig + include + Tezos_protocol_environment_sigs.V5.T + with type Format.formatter = Format.formatter + and type 'a Data_encoding.t = 'a Data_encoding.t + and type 'a Data_encoding.lazy_t = 'a Data_encoding.lazy_t + and type 'a Lwt.t = 'a Lwt.t + and type ('a, 'b) Pervasives.result = ('a, 'b) result + and type Chain_id.t = Chain_id.t + and type Block_hash.t = Block_hash.t + and type Operation_hash.t = Operation_hash.t + and type Operation_list_hash.t = Operation_list_hash.t + and type Operation_list_list_hash.t = Operation_list_list_hash.t + and type Context.t = Context.t + and type Context.cache_key = Environment_context.Context.cache_key + and type Context.cache_value = Environment_context.Context.cache_value + and type Context_hash.t = Context_hash.t + and type Context_hash.Version.t = Context_hash.Version.t + and type Protocol_hash.t = Protocol_hash.t + and type Time.t = Time.Protocol.t + and type Operation.shell_header = Operation.shell_header + and type Operation.t = Operation.t + and type Block_header.shell_header = Block_header.shell_header + and type Block_header.t = Block_header.t + and type 'a RPC_directory.t = 'a RPC_directory.t + and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t + and type Ed25519.Public_key.t = Ed25519.Public_key.t + and type Ed25519.t = Ed25519.t + and type Secp256k1.Public_key_hash.t = Secp256k1.Public_key_hash.t + and type Secp256k1.Public_key.t = Secp256k1.Public_key.t + and type Secp256k1.t = Secp256k1.t + and type P256.Public_key_hash.t = P256.Public_key_hash.t + and type P256.Public_key.t = P256.Public_key.t + and type P256.t = P256.t + and type Signature.public_key_hash = Signature.public_key_hash + and type Signature.public_key = Signature.public_key + and type Signature.t = Signature.t + and type Signature.watermark = Signature.watermark + and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t + and type Pvss_secp256k1.Encrypted_share.t = + Pvss_secp256k1.Encrypted_share.t + and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t + and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t + and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t + and type Micheline.canonical_location = Micheline.canonical_location + and type 'a Micheline.canonical = 'a Micheline.canonical + and type Z.t = Z.t + and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node + and type Data_encoding.json_schema = Data_encoding.json_schema + and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t + and type RPC_service.meth = RPC_service.meth + and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + and type Error_monad.shell_tztrace = Error_monad.tztrace + and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result + and type Timelock.chest = Timelock.chest + and type Timelock.chest_key = Timelock.chest_key + and type Timelock.opening_result = Timelock.opening_result + and module Sapling = Tezos_sapling.Core.Validator + and type Bls_signature.pk = Bls12_381.Signature.pk + + type error += Ecoproto_error of Error_monad.error + + val wrap_tzerror : Error_monad.error -> error + + val wrap_tztrace : Error_monad.error Error_monad.trace -> error trace + + val wrap_tzresult : 'a Error_monad.tzresult -> 'a tzresult + + module Lift (P : Updater.PROTOCOL) : + PROTOCOL + with type block_header_data = P.block_header_data + and type block_header_metadata = P.block_header_metadata + and type block_header = P.block_header + and type operation_data = P.operation_data + and type operation_receipt = P.operation_receipt + and type operation = P.operation + and type validation_state = P.validation_state + + class ['chain, 'block] proto_rpc_context : + Tezos_rpc.RPC_context.t + -> (unit, (unit * 'chain) * 'block) RPC_path.t + -> ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : + ('block -> RPC_context.t) + -> RPC_context.t RPC_directory.t + -> ['block] RPC_context.simple +end + +module MakeV5 (Param : sig + val name : string +end) +() = +struct + (* The protocol V5 only supports 64-bits architectures. We ensure this the + hard way with a dynamic check. *) + let () = + match Sys.word_size with + | 32 -> + Printf.eprintf + "FAILURE: Environment V5 does not support 32-bit architectures\n%!" ; + Stdlib.exit 1 + | 64 -> () + | n -> + Printf.eprintf + "FAILURE: Unknown, unsupported architecture (%d bits)\n%!" + n ; + Stdlib.exit 1 + + include Stdlib + + (* The modules provided in the [_struct.V5.M] pack are meant specifically to + shadow modules from [Stdlib]/[Base]/etc. with backwards compatible + versions. Thus we open the module, hiding the incompatible, newer modules. + *) + open Tezos_protocol_environment_structs.V5.M + module Pervasives = Stdlib + + module Logging = struct + type level = Internal_event.level = + | Debug + | Info + | Notice + | Warning + | Error + | Fatal + + let logging_function = ref None + + let name_colon_space = Param.name ^ ": " + + let null_formatter = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) + + let log (level : Internal_event.level) = + match !logging_function with + | None -> Format.ikfprintf ignore null_formatter + | Some f -> Format.kasprintf (fun s -> f level (name_colon_space ^ s)) + + let log_string (level : Internal_event.level) s = + match !logging_function with + | None -> () + | Some f -> f level (name_colon_space ^ s) + end + + module Compare = Compare + module Seq = Tezos_error_monad.TzLwtreslib.Seq + module List = Tezos_error_monad.TzLwtreslib.List + module Char = Char + module Bytes = Bytes + module Hex = Hex + module String = String + module Bits = Bits + module TzEndian = TzEndian + module Set = Tezos_error_monad.TzLwtreslib.Set + module Map = Tezos_error_monad.TzLwtreslib.Map + module Int32 = Int32 + module Int64 = Int64 + module Buffer = Buffer + module Format = Format + module FallbackArray = FallbackArray + + let not_a_sys_exc next_classifier = function + | Unix.Unix_error _ | UnixLabels.Unix_error _ | Sys_error _ -> false + | e -> next_classifier e + + module Option = struct + include Tezos_error_monad.TzLwtreslib.Option + + (* This as well as the catchers in [Result] and [Error_monad] are different + from the ones in Lwtreslib/Error Monad in that they also hide the Unix + and System errors. This is because, from the point-of-view of the + protocol, these exceptions are too abstract and too indeterministic. *) + let catch ?(catch_only = fun _ -> true) f = + (* Note that [catch] also special-cases its own set of exceptions. *) + catch ~catch_only:(not_a_sys_exc catch_only) f + + let catch_s ?(catch_only = fun _ -> true) f = + catch_s ~catch_only:(not_a_sys_exc catch_only) f + end + + module Result = struct + include Tezos_error_monad.TzLwtreslib.Result + + let catch ?(catch_only = fun _ -> true) f = + catch ~catch_only:(not_a_sys_exc catch_only) f + + let catch_f ?(catch_only = fun _ -> true) f = + catch_f ~catch_only:(not_a_sys_exc catch_only) f + + let catch_s ?(catch_only = fun _ -> true) f = + catch_s ~catch_only:(not_a_sys_exc catch_only) f + end + + module Raw_hashes = struct + let sha256 = Hacl.Hash.SHA256.digest + + let sha512 = Hacl.Hash.SHA512.digest + + let blake2b msg = Blake2B.to_bytes (Blake2B.hash_bytes [msg]) + + let keccak256 msg = Hacl.Hash.Keccak_256.digest msg + + let sha3_256 msg = Hacl.Hash.SHA3_256.digest msg + + let sha3_512 msg = Hacl.Hash.SHA3_512.digest msg + end + + module Z = Z + module Lwt = Lwt + module Uri = Uri + + module Data_encoding = struct + include Data_encoding + + type tag_size = [`Uint8 | `Uint16] + + let def name ?title ?description encoding = + def (Param.name ^ "." ^ name) ?title ?description encoding + end + + module Time = Time.Protocol + + module Bls12_381 = struct + include Bls12_381 + + let pairing_check = Bls12_381.Pairing.pairing_check + end + + module Bls_signature = struct + open Bls12_381.Signature + + type pk = Bls12_381.Signature.pk + + let unsafe_pk_of_bytes = unsafe_pk_of_bytes + + let pk_of_bytes_opt = pk_of_bytes_opt + + let pk_to_bytes = pk_to_bytes + + type signature = Bls12_381.Signature.signature + + let verify = Aug.verify + + let aggregate_verify = Aug.aggregate_verify + + let aggregate_signature_opt = aggregate_signature_opt + end + + module Ed25519 = Ed25519 + module Secp256k1 = Secp256k1 + module P256 = P256 + module Signature = Signature + module Pvss_secp256k1 = Pvss_secp256k1 + module Timelock = Timelock + + module S = struct + module type T = Tezos_base.S.T + + module type HASHABLE = Tezos_base.S.HASHABLE + + module type MINIMAL_HASH = Tezos_crypto.S.MINIMAL_HASH + + module type B58_DATA = sig + type t + + val to_b58check : t -> string + + val to_short_b58check : t -> string + + val of_b58check_exn : string -> t + + val of_b58check_opt : string -> t option + + type Base58.data += Data of t + + val b58check_encoding : t Base58.encoding + end + + module type RAW_DATA = sig + type t + + val size : int (* in bytes *) + + val to_bytes : t -> Bytes.t + + val of_bytes_opt : Bytes.t -> t option + + val of_bytes_exn : Bytes.t -> t + end + + module type ENCODER = sig + type t + + val encoding : t Data_encoding.t + + val rpc_arg : t RPC_arg.t + end + + module type INDEXES_SET = sig + include Set.S + + val random_elt : t -> elt + + val encoding : t Data_encoding.t + end + + module type INDEXES_MAP = sig + include Map.S + + val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t + end + + module type INDEXES = sig + type t + + module Set : INDEXES_SET with type elt = t + + module Map : INDEXES_MAP with type key = t + end + + module type HASH = sig + include MINIMAL_HASH + + include RAW_DATA with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + include INDEXES with type t := t + end + + module type MERKLE_TREE = sig + type elt + + include HASH + + val compute : elt list -> t + + val empty : t + + type path = Left of path * t | Right of t * path | Op + + val compute_path : elt list -> int -> path + + val check_path : path -> elt -> t * int + + val path_encoding : path Data_encoding.t + end + + module type SIGNATURE_PUBLIC_KEY_HASH = sig + type t + + val pp : Format.formatter -> t -> unit + + val pp_short : Format.formatter -> t -> unit + + include Compare.S with type t := t + + include RAW_DATA with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + include INDEXES with type t := t + + val zero : t + end + + module type SIGNATURE_PUBLIC_KEY = sig + type t + + val pp : Format.formatter -> t -> unit + + include Compare.S with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + type public_key_hash_t + + val hash : t -> public_key_hash_t + + val size : t -> int (* in bytes *) + + val of_bytes_without_validation : bytes -> t option + end + + module type SIGNATURE = sig + module Public_key_hash : SIGNATURE_PUBLIC_KEY_HASH + + module Public_key : + SIGNATURE_PUBLIC_KEY with type public_key_hash_t := Public_key_hash.t + + type t + + val pp : Format.formatter -> t -> unit + + include RAW_DATA with type t := t + + include Compare.S with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + val zero : t + + type watermark + + (** Check a signature *) + val check : ?watermark:watermark -> Public_key.t -> t -> Bytes.t -> bool + end + + module type FIELD = sig + type t + + (** The order of the finite field *) + val order : Z.t + + (** minimal number of bytes required to encode a value of the field. *) + val size_in_bytes : int + + (** [check_bytes bs] returns [true] if [bs] is a correct byte + representation of a field element *) + val check_bytes : Bytes.t -> bool + + (** The neutral element for the addition *) + val zero : t + + (** The neutral element for the multiplication *) + val one : t + + (** [add a b] returns [a + b mod order] *) + val add : t -> t -> t + + (** [mul a b] returns [a * b mod order] *) + val mul : t -> t -> t + + (** [eq a b] returns [true] if [a = b mod order], else [false] *) + val eq : t -> t -> bool + + (** [negate x] returns [-x mod order]. Equivalently, [negate x] returns the + unique [y] such that [x + y mod order = 0] + *) + val negate : t -> t + + (** [inverse_opt x] returns [x^-1] if [x] is not [0] as an option, else [None] *) + val inverse_opt : t -> t option + + (** [pow x n] returns [x^n] *) + val pow : t -> Z.t -> t + + (** From a predefined bytes representation, construct a value t. It is not + required that to_bytes [(Option.get (of_bytes_opt t)) = t]. By default, little endian encoding + is used and the given element is modulo the prime order *) + val of_bytes_opt : Bytes.t -> t option + + (** Convert the value t to a bytes representation which can be used for + hashing for instance. It is not required that [Option.get (to_bytes + (of_bytes_opt t)) = t]. By default, little endian encoding is used, and + length of the resulting bytes may vary depending on the order. + *) + val to_bytes : t -> Bytes.t + end + + (** Module type for the prime fields GF(p) *) + module type PRIME_FIELD = sig + include FIELD + + (** [of_z x] builds an element t from the Zarith element [x]. [mod order] is + applied if [x >= order] or [x < 0]. *) + val of_z : Z.t -> t + + (** [to_z x] builds a Zarith element, using the decimal representation. + Arithmetic on the result can be done using the modular functions on + integers *) + val to_z : t -> Z.t + end + + module type CURVE = sig + (** The type of the element in the elliptic curve *) + type t + + (** The size of a point representation, in bytes *) + val size_in_bytes : int + + module Scalar : FIELD + + (** Check if a point, represented as a byte array, is on the curve **) + val check_bytes : Bytes.t -> bool + + (** Attempt to construct a point from a byte array *) + val of_bytes_opt : Bytes.t -> t option + + (** Return a representation in bytes *) + val to_bytes : t -> Bytes.t + + (** Zero of the elliptic curve *) + val zero : t + + (** A fixed generator of the elliptic curve *) + val one : t + + (** Return the addition of two element *) + val add : t -> t -> t + + (** Double the element *) + val double : t -> t + + (** Return the opposite of the element *) + val negate : t -> t + + (** Return [true] if the two elements are algebraically the same *) + val eq : t -> t -> bool + + (** Multiply an element by a scalar *) + val mul : t -> Scalar.t -> t + end + + module type PVSS_ELEMENT = sig + type t + + include B58_DATA with type t := t + + include ENCODER with type t := t + end + + module type PVSS_PUBLIC_KEY = sig + type t + + val pp : Format.formatter -> t -> unit + + include Compare.S with type t := t + + include RAW_DATA with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + end + + module type PVSS_SECRET_KEY = sig + type public_key + + type t + + include ENCODER with type t := t + + val to_public_key : t -> public_key + end + + module type PVSS = sig + type proof + + module Clear_share : PVSS_ELEMENT + + module Commitment : PVSS_ELEMENT + + module Encrypted_share : PVSS_ELEMENT + + module Public_key : PVSS_PUBLIC_KEY + + module Secret_key : PVSS_SECRET_KEY with type public_key := Public_key.t + + val proof_encoding : proof Data_encoding.t + + val check_dealer_proof : + Encrypted_share.t list -> + Commitment.t list -> + proof:proof -> + public_keys:Public_key.t list -> + bool + + val check_revealed_share : + Encrypted_share.t -> + Clear_share.t -> + public_key:Public_key.t -> + proof -> + bool + + val reconstruct : Clear_share.t list -> int list -> Public_key.t + end + end + + module Error_core = struct + include + Tezos_error_monad.Core_maker.Make + (struct + let id = Format.asprintf "proto.%s." Param.name + end) + (struct + type t = + [ `Branch (** Errors that may not happen in another context *) + | `Temporary (** Errors that may not happen in a later context *) + | `Permanent (** Errors that will happen no matter the context *) + | `Outdated (** Errors that happen when the context is too old *) + ] + + let default_category = `Temporary + + let string_of_category = function + | `Permanent -> "permanent" + | `Outdated -> "outdated" + | `Branch -> "branch" + | `Temporary -> "temporary" + + let classify = function + | `Permanent -> Tezos_error_monad.Error_classification.Permanent + | `Branch -> Branch + | `Temporary -> Temporary + | `Outdated -> Outdated + end) + end + + type error_category = Error_core.error_category + + type shell_error += Ecoproto_error of Error_core.error + + module Wrapped_error_monad = struct + type unwrapped = Error_core.error = .. + + include ( + Error_core : + sig + include + Tezos_error_monad.Sig.CORE + with type error := unwrapped + and type error_category = error_category + end) + + let unwrap = function Ecoproto_error ecoerror -> Some ecoerror | _ -> None + + let wrap ecoerror = Ecoproto_error ecoerror + end + + module Error_monad = struct + type shell_tztrace = Error_monad.tztrace + + type 'a shell_tzresult = ('a, Error_monad.tztrace) result + + include Error_core + include Tezos_error_monad.TzLwtreslib.Monad + include + Tezos_error_monad.Monad_extension_maker.Make (Error_core) (TzTrace) + (Tezos_error_monad.TzLwtreslib.Monad) + + (* Backwards compatibility additions (dont_wait, trace helpers) *) + let dont_wait ex er f = dont_wait f er ex + + let trace_of_error e = TzTrace.make e + + let make_trace_encoding e = TzTrace.encoding e + + let pp_trace = pp_print_trace + + type 'err trace = 'err TzTrace.trace + + (* Shadowing catch to prevent catching system exceptions *) + type error += Exn of exn + + let () = + register_error_kind + `Temporary + ~id:"failure" + ~title:"Exception" + ~description:"Exception safely wrapped in an error" + ~pp:(fun ppf s -> + Format.fprintf ppf "@[%a@]" Format.pp_print_text s) + Data_encoding.(obj1 (req "msg" string)) + (function + | Exn (Failure msg) -> Some msg + | Exn exn -> Some (Printexc.to_string exn) + | _ -> None) + (fun msg -> Exn (Failure msg)) + + let error_of_exn e = TzTrace.make @@ Exn e + + let catch ?catch_only f = + Result.catch ?catch_only f |> Result.map_error error_of_exn + + let catch_f ?catch_only f h = + Result.catch ?catch_only f + |> Result.map_error (fun e -> trace_of_error (h e)) + + let catch_s ?catch_only f = + Result.catch_s ?catch_only f + >|= Result.map_error (fun e -> error_of_exn e) + + let both_e = Tzresult_syntax.both + + let join_e = Tzresult_syntax.join + + let all_e = Tzresult_syntax.all + end + + let () = + let id = Format.asprintf "proto.%s.wrapper" Param.name in + Shell_error_monad.register_wrapped_error_kind + (module Wrapped_error_monad) + ~id + ~title:("Error returned by protocol " ^ Param.name) + ~description:("Wrapped error for economic protocol " ^ Param.name ^ ".") + + let wrap_tzerror error = Ecoproto_error error + + let wrap_tztrace t = List.map wrap_tzerror t + + let wrap_tzresult r = Result.map_error wrap_tztrace r + + module Chain_id = Chain_id + module Block_hash = Block_hash + module Operation_hash = Operation_hash + module Operation_list_hash = Operation_list_hash + module Operation_list_list_hash = Operation_list_list_hash + module Context_hash = Context_hash + module Protocol_hash = Protocol_hash + module Blake2B = Blake2B + module Fitness = Fitness + module Operation = Operation + module Block_header = Block_header + module Protocol = Protocol + module RPC_arg = RPC_arg + module RPC_path = RPC_path + module RPC_query = RPC_query + module RPC_service = RPC_service + + module RPC_answer = struct + type 'o t = + [ `Ok of 'o (* 200 *) + | `OkChunk of 'o (* 200 but with chunked transfer encoding *) + | `OkStream of 'o stream (* 200 *) + | `Created of string option (* 201 *) + | `No_content (* 204 *) + | `Unauthorized of Error_monad.error list option (* 401 *) + | `Forbidden of Error_monad.error list option (* 403 *) + | `Not_found of Error_monad.error list option (* 404 *) + | `Conflict of Error_monad.error list option (* 409 *) + | `Error of Error_monad.error list option (* 500 *) ] + + and 'a stream = 'a Resto_directory.Answer.stream = { + next : unit -> 'a option Lwt.t; + shutdown : unit -> unit; + } + + let return x = Lwt.return (`Ok x) + + let return_chunked x = Lwt.return (`OkChunk x) + + let return_stream x = Lwt.return (`OkStream x) + + let not_found = Lwt.return (`Not_found None) + + let fail err = Lwt.return (`Error (Some err)) + end + + module RPC_directory = struct + include RPC_directory + + let gen_register dir service handler = + gen_register dir service (fun p q i -> + handler p q i >>= function + | `Ok o -> RPC_answer.return o + | `OkChunk o -> RPC_answer.return_chunked o + | `OkStream s -> RPC_answer.return_stream s + | `Created s -> Lwt.return (`Created s) + | `No_content -> Lwt.return `No_content + | `Unauthorized e -> + let e = Option.map (List.map (fun e -> Ecoproto_error e)) e in + Lwt.return (`Unauthorized e) + | `Forbidden e -> + let e = Option.map (List.map (fun e -> Ecoproto_error e)) e in + Lwt.return (`Forbidden e) + | `Not_found e -> + let e = Option.map (List.map (fun e -> Ecoproto_error e)) e in + Lwt.return (`Not_found e) + | `Conflict e -> + let e = Option.map (List.map (fun e -> Ecoproto_error e)) e in + Lwt.return (`Conflict e) + | `Error e -> + let e = Option.map (List.map (fun e -> Ecoproto_error e)) e in + Lwt.return (`Error e)) + + let register ~chunked dir service handler = + gen_register dir service (fun p q i -> + handler p q i >>= function + | Ok o when chunked -> RPC_answer.return_chunked o + | Ok o (* otherwise *) -> RPC_answer.return o + | Error e -> RPC_answer.fail e) + + let opt_register ~chunked dir service handler = + gen_register dir service (fun p q i -> + handler p q i >>= function + | Ok (Some o) when chunked -> RPC_answer.return_chunked o + | Ok (Some o) (* otherwise *) -> RPC_answer.return o + | Ok None -> RPC_answer.not_found + | Error e -> RPC_answer.fail e) + + let lwt_register ~chunked dir service handler = + gen_register dir service (fun p q i -> + handler p q i >>= fun o -> + if chunked then RPC_answer.return_chunked o else RPC_answer.return o) + + open Curry + + let register0 ~chunked root s f = register ~chunked root s (curry Z f) + + let register1 ~chunked root s f = register ~chunked root s (curry (S Z) f) + + let register2 ~chunked root s f = + register ~chunked root s (curry (S (S Z)) f) + + let register3 ~chunked root s f = + register ~chunked root s (curry (S (S (S Z))) f) + + let register4 ~chunked root s f = + register ~chunked root s (curry (S (S (S (S Z)))) f) + + let register5 ~chunked root s f = + register ~chunked root s (curry (S (S (S (S (S Z))))) f) + + let opt_register0 ~chunked root s f = + opt_register ~chunked root s (curry Z f) + + let opt_register1 ~chunked root s f = + opt_register ~chunked root s (curry (S Z) f) + + let opt_register2 ~chunked root s f = + opt_register ~chunked root s (curry (S (S Z)) f) + + let opt_register3 ~chunked root s f = + opt_register ~chunked root s (curry (S (S (S Z))) f) + + let opt_register4 ~chunked root s f = + opt_register ~chunked root s (curry (S (S (S (S Z)))) f) + + let opt_register5 ~chunked root s f = + opt_register ~chunked root s (curry (S (S (S (S (S Z))))) f) + + let gen_register0 root s f = gen_register root s (curry Z f) + + let gen_register1 root s f = gen_register root s (curry (S Z) f) + + let gen_register2 root s f = gen_register root s (curry (S (S Z)) f) + + let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f) + + let gen_register4 root s f = gen_register root s (curry (S (S (S (S Z)))) f) + + let gen_register5 root s f = + gen_register root s (curry (S (S (S (S (S Z))))) f) + + let lwt_register0 ~chunked root s f = + lwt_register ~chunked root s (curry Z f) + + let lwt_register1 ~chunked root s f = + lwt_register ~chunked root s (curry (S Z) f) + + let lwt_register2 ~chunked root s f = + lwt_register ~chunked root s (curry (S (S Z)) f) + + let lwt_register3 ~chunked root s f = + lwt_register ~chunked root s (curry (S (S (S Z))) f) + + let lwt_register4 ~chunked root s f = + lwt_register ~chunked root s (curry (S (S (S (S Z)))) f) + + let lwt_register5 ~chunked root s f = + lwt_register ~chunked root s (curry (S (S (S (S (S Z))))) f) + end + + module RPC_context = struct + type t = rpc_context + + class type ['pr] simple = + object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end + + let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s + + let make_call0 = (make_call0 : _ -> _ simple -> _ :> _ -> _ #simple -> _) + + let make_call1 s (ctxt : _ simple) = ctxt#call_proto_service1 s + + let make_call1 = (make_call1 : _ -> _ simple -> _ :> _ -> _ #simple -> _) + + let make_call2 s (ctxt : _ simple) = ctxt#call_proto_service2 s + + let make_call2 = (make_call2 : _ -> _ simple -> _ :> _ -> _ #simple -> _) + + let make_call3 s (ctxt : _ simple) = ctxt#call_proto_service3 s + + let make_call3 = (make_call3 : _ -> _ simple -> _ :> _ -> _ #simple -> _) + + let make_opt_call0 s ctxt block q i = + make_call0 s ctxt block q i >>= function + | Error [RPC_context.Not_found _] -> Lwt.return_ok None + | Error _ as v -> Lwt.return v + | Ok v -> Lwt.return_ok (Some v) + + let make_opt_call1 s ctxt block a1 q i = + make_call1 s ctxt block a1 q i >>= function + | Error [RPC_context.Not_found _] -> Lwt.return_ok None + | Error _ as v -> Lwt.return v + | Ok v -> Lwt.return_ok (Some v) + + let make_opt_call2 s ctxt block a1 a2 q i = + make_call2 s ctxt block a1 a2 q i >>= function + | Error [RPC_context.Not_found _] -> Lwt.return_ok None + | Error _ as v -> Lwt.return v + | Ok v -> Lwt.return_ok (Some v) + + let make_opt_call3 s ctxt block a1 a2 a3 q i = + make_call3 s ctxt block a1 a2 a3 q i >>= function + | Error [RPC_context.Not_found _] -> Lwt.return_ok None + | Error _ as v -> Lwt.return v + | Ok v -> Lwt.return_ok (Some v) + end + + module Sapling = Tezos_sapling.Core.Validator + + module Micheline = struct + include Micheline + include Micheline_encoding + + (* The environment exposes a single canonical encoding for Micheline + expression. For env-V5, it is encoding-v2 because this is the most + recent, most correct-at-time-of-writing encoding. For backwards + compatibility reason, you should never upgrade (nor downgrade) this. + Future fixes and improvements of the encoding should be made available in + future environments only. *) + let canonical_encoding ~variant encoding = + canonical_encoding_v2 ~variant:(Param.name ^ "." ^ variant) encoding + end + + module Updater = struct + type nonrec validation_result = validation_result = { + context : Context.t; + fitness : Fitness.t; + message : string option; + max_operations_ttl : int; + last_allowed_fork_level : Int32.t; + } + + type nonrec quota = quota = {max_size : int; max_op : int option} + + type nonrec rpc_context = rpc_context = { + block_hash : Block_hash.t; + block_header : Block_header.shell_header; + context : Context.t; + } + + let activate = Context.set_protocol + + module type PROTOCOL = + Environment_protocol_T_V3.T + with type context := Context.t + and type cache_value := Environment_context.Context.cache_value + and type cache_key := Environment_context.Context.cache_key + and type quota := quota + and type validation_result := validation_result + and type rpc_context := rpc_context + and type 'a tzresult := 'a Error_monad.tzresult + end + + module Base58 = struct + include Tezos_crypto.Base58 + + let simple_encode enc s = simple_encode enc s + + let simple_decode enc s = simple_decode enc s + + include Make (struct + type context = Context.t + end) + + let decode s = decode s + end + + module Context = struct + include Context + + type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] + + module type VIEW = Environment_context.VIEW + + module Kind = struct + type t = [`Value | `Tree] + end + + module type TREE = Environment_context.TREE + + module type CACHE = Environment_context.CACHE + + let register_resolver = Base58.register_resolver + + let complete ctxt s = Base58.complete ctxt s + end + + module Lift (P : Updater.PROTOCOL) = struct + let environment_version = Protocol.V5 + + include P + + let value_of_key ~chain_id ~predecessor_context ~predecessor_timestamp + ~predecessor_level ~predecessor_fitness ~predecessor ~timestamp = + value_of_key + ~chain_id + ~predecessor_context + ~predecessor_timestamp + ~predecessor_level + ~predecessor_fitness + ~predecessor + ~timestamp + >|= wrap_tzresult + >>=? fun f -> return (fun x -> f x >|= wrap_tzresult) + + (* + [load_predecessor_cache] ensures that the cache is correctly + loaded in memory before running any operations. + *) + let load_predecessor_cache ~chain_id ~predecessor_context + ~predecessor_timestamp ~predecessor_level ~predecessor_fitness + ~predecessor ~timestamp ~cache = + value_of_key + ~chain_id + ~predecessor_context + ~predecessor_timestamp + ~predecessor_level + ~predecessor_fitness + ~predecessor + ~timestamp + >>=? fun value_of_key -> + Context.load_cache predecessor predecessor_context cache value_of_key + + let begin_partial_application ~chain_id ~ancestor_context + ~(predecessor : Block_header.t) ~predecessor_hash ~cache + (raw_block : block_header) = + load_predecessor_cache + ~chain_id + ~predecessor_context:ancestor_context + ~predecessor_timestamp:predecessor.shell.timestamp + ~predecessor_level:predecessor.shell.level + ~predecessor_fitness:predecessor.shell.fitness + ~predecessor:predecessor_hash + ~timestamp:raw_block.shell.timestamp + ~cache + >>=? fun ancestor_context -> + begin_partial_application + ~chain_id + ~ancestor_context + ~predecessor_timestamp:predecessor.shell.timestamp + ~predecessor_fitness:predecessor.shell.fitness + raw_block + >|= wrap_tzresult + + let begin_application ~chain_id ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness ~cache (raw_block : block_header) = + load_predecessor_cache + ~chain_id + ~predecessor_context + ~predecessor_timestamp + ~predecessor_level:(Int32.pred raw_block.shell.level) + ~predecessor_fitness + ~predecessor:raw_block.shell.predecessor + ~timestamp:raw_block.shell.timestamp + ~cache + >>=? fun predecessor_context -> + begin_application + ~chain_id + ~predecessor_context + ~predecessor_timestamp + ~predecessor_fitness + raw_block + >|= wrap_tzresult + + let begin_construction ~chain_id ~predecessor_context ~predecessor_timestamp + ~predecessor_level ~predecessor_fitness ~predecessor ~timestamp + ?protocol_data ~cache () = + load_predecessor_cache + ~chain_id + ~predecessor_context + ~predecessor_timestamp + ~predecessor_level + ~predecessor_fitness + ~predecessor + ~timestamp + ~cache + >>=? fun predecessor_context -> + begin_construction + ~chain_id + ~predecessor_context + ~predecessor_timestamp + ~predecessor_level + ~predecessor_fitness + ~predecessor + ~timestamp + ?protocol_data + () + >|= wrap_tzresult + + let apply_operation c o = apply_operation c o >|= wrap_tzresult + + let finalize_block c shell_header = + finalize_block c shell_header >|= wrap_tzresult + + let init c bh = init c bh >|= wrap_tzresult + + let set_log_message_consumer f = Logging.logging_function := Some f + end + + class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t) + (prefix : (unit, (unit * 'chain) * 'block) RPC_path.t) = + object + method call_proto_service0 + : 'm 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + RPC_context.t, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'chain * 'block -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s (chain, block) q i -> + let s = RPC_service.subst0 s in + let s = RPC_service.prefix prefix s in + t#call_service s (((), chain), block) q i + + method call_proto_service1 + : 'm 'a 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + RPC_context.t * 'a, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'chain * 'block -> + 'a -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s (chain, block) a1 q i -> + let s = RPC_service.subst1 s in + let s = RPC_service.prefix prefix s in + t#call_service s ((((), chain), block), a1) q i + + method call_proto_service2 + : 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + (RPC_context.t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'chain * 'block -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s (chain, block) a1 a2 q i -> + let s = RPC_service.subst2 s in + let s = RPC_service.prefix prefix s in + t#call_service s (((((), chain), block), a1), a2) q i + + method call_proto_service3 + : 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + ((RPC_context.t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'chain * 'block -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s (chain, block) a1 a2 a3 q i -> + let s = RPC_service.subst3 s in + let s = RPC_service.prefix prefix s in + t#call_service s ((((((), chain), block), a1), a2), a3) q i + end + + class ['block] proto_rpc_context_of_directory conv dir : + ['block] RPC_context.simple = + let lookup = new Tezos_rpc.RPC_context.of_directory dir in + object + method call_proto_service0 + : 'm 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + RPC_context.t, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'block -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s block q i -> + let rpc_context = conv block in + lookup#call_service s rpc_context q i + + method call_proto_service1 + : 'm 'a 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + RPC_context.t * 'a, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'block -> + 'a -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s block a1 q i -> + let rpc_context = conv block in + lookup#call_service s (rpc_context, a1) q i + + method call_proto_service2 + : 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + (RPC_context.t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'block -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s block a1 a2 q i -> + let rpc_context = conv block in + lookup#call_service s ((rpc_context, a1), a2) q i + + method call_proto_service3 + : 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + RPC_context.t, + ((RPC_context.t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'block -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o tzresult Lwt.t = + fun s block a1 a2 a3 q i -> + let rpc_context = conv block in + lookup#call_service s (((rpc_context, a1), a2), a3) q i + end + + module Equality_witness = Environment_context.Equality_witness +end diff --git a/src/lib_protocol_environment/environment_V5.mli b/src/lib_protocol_environment/environment_V5.mli new file mode 100644 index 000000000000..9a456fceda62 --- /dev/null +++ b/src/lib_protocol_environment/environment_V5.mli @@ -0,0 +1,152 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2021 Nomadic Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Environment_context +open Environment_protocol_T + +module type V5 = sig + include + Tezos_protocol_environment_sigs.V5.T + with type Format.formatter = Format.formatter + and type 'a Data_encoding.t = 'a Data_encoding.t + and type 'a Data_encoding.lazy_t = 'a Data_encoding.lazy_t + and type 'a Lwt.t = 'a Lwt.t + and type ('a, 'b) Pervasives.result = ('a, 'b) result + and type Chain_id.t = Chain_id.t + and type Block_hash.t = Block_hash.t + and type Operation_hash.t = Operation_hash.t + and type Operation_list_hash.t = Operation_list_hash.t + and type Operation_list_list_hash.t = Operation_list_list_hash.t + and type Context.t = Context.t + and type Context.cache_key = Environment_context.Context.cache_key + and type Context.cache_value = Environment_context.Context.cache_value + and type Context_hash.t = Context_hash.t + and type Context_hash.Version.t = Context_hash.Version.t + and type Protocol_hash.t = Protocol_hash.t + and type Time.t = Time.Protocol.t + and type Operation.shell_header = Operation.shell_header + and type Operation.t = Operation.t + and type Block_header.shell_header = Block_header.shell_header + and type Block_header.t = Block_header.t + and type 'a RPC_directory.t = 'a RPC_directory.t + and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t + and type Ed25519.Public_key.t = Ed25519.Public_key.t + and type Ed25519.t = Ed25519.t + and type Secp256k1.Public_key_hash.t = Secp256k1.Public_key_hash.t + and type Secp256k1.Public_key.t = Secp256k1.Public_key.t + and type Secp256k1.t = Secp256k1.t + and type P256.Public_key_hash.t = P256.Public_key_hash.t + and type P256.Public_key.t = P256.Public_key.t + and type P256.t = P256.t + and type Signature.public_key_hash = Signature.public_key_hash + and type Signature.public_key = Signature.public_key + and type Signature.t = Signature.t + and type Signature.watermark = Signature.watermark + and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t + and type Pvss_secp256k1.Encrypted_share.t = + Pvss_secp256k1.Encrypted_share.t + and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t + and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t + and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t + and type Micheline.canonical_location = Micheline.canonical_location + and type 'a Micheline.canonical = 'a Micheline.canonical + and type Z.t = Z.t + and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node + and type Data_encoding.json_schema = Data_encoding.json_schema + and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t + and type RPC_service.meth = RPC_service.meth + and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + and type Error_monad.shell_tztrace = Error_monad.tztrace + and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result + and type Timelock.chest = Timelock.chest + and type Timelock.chest_key = Timelock.chest_key + and type Timelock.opening_result = Timelock.opening_result + and module Sapling = Tezos_sapling.Core.Validator + and type Bls_signature.pk = Bls12_381.Signature.pk + + (** An [Ecoproto_error e] is a shell error that carry a protocol error. + + Each protocol has its own error-monad (instantiated when this module here + is applied) with a fresh extensible error type. This protocol-specific + error type is incompatible with the shell's. The [Ecoproto_error] + constructor belongs to the shell's error type and it carries the errors of + the protocol's specific error type back into the shell's. + + The function [wrap_tz*] below provide wrappers for three different levels: + errors, traces, and tzresults. They are used within the implementation of + the environment to translate some return values from the protocol's error + monad into the shell's. They are exported because they can be useful for + writing tests for the protocol (i.e., for the tests located in + [src/proto_*/lib_protocol/test/]) and for writing protocol-specific + support libraries and binaries (i.e., for the code in + [src/proto_*/lib_{client,delegate,etc.}]). *) + type error += Ecoproto_error of Error_monad.error + + (** [wrap_tzerror e] is a shell error wrapping the protocol error [e]. + (It is [Ecoproto_error e].) *) + val wrap_tzerror : Error_monad.error -> error + + (** [wrap_tztrace t] is a shell trace composed of the wrapped errors of the + protocol trace [t]. *) + val wrap_tztrace : Error_monad.error Error_monad.trace -> error trace + + (** [wrap_tzresult r] is a shell tzresult that carries the same result as or a + wrapped trace of the protocol tzresult [r]. + (It is [Ok x] if [r] is [Ok x], it is [Error (wrap_tztrace t)] if [r] is + [Error t].) *) + val wrap_tzresult : 'a Error_monad.tzresult -> 'a tzresult + + module Lift (P : Updater.PROTOCOL) : + PROTOCOL + with type block_header_data = P.block_header_data + and type block_header_metadata = P.block_header_metadata + and type block_header = P.block_header + and type operation_data = P.operation_data + and type operation_receipt = P.operation_receipt + and type operation = P.operation + and type validation_state = P.validation_state + + class ['chain, 'block] proto_rpc_context : + Tezos_rpc.RPC_context.t + -> (unit, (unit * 'chain) * 'block) RPC_path.t + -> ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : + ('block -> RPC_context.t) + -> RPC_context.t RPC_directory.t + -> ['block] RPC_context.simple +end + +module MakeV5 (Param : sig + val name : string +end) +() : + V5 + with type Context.t = Context.t + and type Updater.validation_result = validation_result + and type Updater.quota = quota + and type Updater.rpc_context = rpc_context diff --git a/src/lib_protocol_environment/sigs/dune b/src/lib_protocol_environment/sigs/dune index 5d5121ebe4ba..cccd12fcbeb8 100644 --- a/src/lib_protocol_environment/sigs/dune +++ b/src/lib_protocol_environment/sigs/dune @@ -3,7 +3,7 @@ (public_name tezos-protocol-environment-sigs) (instrumentation (backend bisect_ppx)) (flags (:standard -nopervasives)) - (modules V0 V1 V2 V3 V4)) + (modules V0 V1 V2 V3 V4 V5)) (include v0.dune.inc) @@ -14,3 +14,5 @@ (include v3.dune.inc) (include v4.dune.inc) + +(include v5.dune.inc) diff --git a/src/lib_protocol_environment/sigs/v0/protocol.mli b/src/lib_protocol_environment/sigs/v0/protocol.mli index 77231065c2d4..35bf38a36c1f 100644 --- a/src/lib_protocol_environment/sigs/v0/protocol.mli +++ b/src/lib_protocol_environment/sigs/v0/protocol.mli @@ -35,7 +35,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 val component_encoding : component Data_encoding.t diff --git a/src/lib_protocol_environment/sigs/v1/protocol.mli b/src/lib_protocol_environment/sigs/v1/protocol.mli index 77231065c2d4..35bf38a36c1f 100644 --- a/src/lib_protocol_environment/sigs/v1/protocol.mli +++ b/src/lib_protocol_environment/sigs/v1/protocol.mli @@ -35,7 +35,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 val component_encoding : component Data_encoding.t diff --git a/src/lib_protocol_environment/sigs/v2/protocol.mli b/src/lib_protocol_environment/sigs/v2/protocol.mli index 77231065c2d4..35bf38a36c1f 100644 --- a/src/lib_protocol_environment/sigs/v2/protocol.mli +++ b/src/lib_protocol_environment/sigs/v2/protocol.mli @@ -35,7 +35,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 val component_encoding : component Data_encoding.t diff --git a/src/lib_protocol_environment/sigs/v3/protocol.mli b/src/lib_protocol_environment/sigs/v3/protocol.mli index 77231065c2d4..35bf38a36c1f 100644 --- a/src/lib_protocol_environment/sigs/v3/protocol.mli +++ b/src/lib_protocol_environment/sigs/v3/protocol.mli @@ -35,7 +35,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 val component_encoding : component Data_encoding.t diff --git a/src/lib_protocol_environment/sigs/v4/protocol.mli b/src/lib_protocol_environment/sigs/v4/protocol.mli index 77231065c2d4..35bf38a36c1f 100644 --- a/src/lib_protocol_environment/sigs/v4/protocol.mli +++ b/src/lib_protocol_environment/sigs/v4/protocol.mli @@ -35,7 +35,7 @@ and component = { implementation : string; } -and env_version = V0 | V1 | V2 | V3 | V4 +and env_version = V0 | V1 | V2 | V3 | V4 | V5 val component_encoding : component Data_encoding.t diff --git a/src/lib_protocol_environment/sigs/v5.dune.inc b/src/lib_protocol_environment/sigs/v5.dune.inc new file mode 100644 index 000000000000..cf2b5153e39f --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5.dune.inc @@ -0,0 +1,80 @@ +(rule + (targets v5.ml) + (deps + + ;; Part of OCaml stdlib 4.09.1 + v5/pervasives.mli + v5/string.mli + v5/char.mli + v5/bytes.mli + v5/int32.mli + v5/int64.mli + v5/format.mli + + v5/logging.mli + + ;; Part of external libraries + v5/hex.mli ; 1.4.0 + v5/z.mli ; 1.10 + v5/lwt.mli ; 5.3.0 + v5/data_encoding.mli ; 0.2 + + ;; Tezos extended stdlib revision 32f04ec483b8d9c62dd0957389eb5268d8b3a38d + v5/raw_hashes.mli + v5/compare.mli + v5/time.mli + v5/tzEndian.mli + v5/bits.mli + v5/equality_witness.mli + v5/fallbackArray.mli + + ;; Part of Error_monad/Lwtreslib + v5/error_monad.mli + v5/seq.mli + v5/list.mli + v5/set.mli + v5/map.mli + v5/option.mli + v5/result.mli + + ;; everything RPC + v5/RPC_arg.mli + v5/RPC_path.mli + v5/RPC_query.mli + v5/RPC_service.mli + v5/RPC_answer.mli + v5/RPC_directory.mli + + ;; Tezos common types and functions (cryptographic primitives, contract + ;; addresses, operations, etc.) + v5/base58.mli + v5/s.mli + v5/blake2B.mli + v5/bls12_381.mli + v5/bls_signature.mli + v5/ed25519.mli + v5/secp256k1.mli + v5/p256.mli + v5/chain_id.mli + v5/signature.mli + v5/block_hash.mli + v5/operation_hash.mli + v5/operation_list_hash.mli + v5/operation_list_list_hash.mli + v5/protocol_hash.mli + v5/context_hash.mli + v5/pvss_secp256k1.mli + v5/sapling.mli + v5/timelock.mli + + v5/micheline.mli + v5/block_header.mli + v5/fitness.mli + v5/operation.mli + v5/protocol.mli + v5/context.mli + v5/updater.mli + v5/RPC_context.mli + ) + (action (with-stdout-to %{targets} (chdir %{workspace_root}} + (run %{libexec:tezos-protocol-environment-packer:s_packer} "sigs" %{deps}))))) diff --git a/src/lib_protocol_environment/sigs/v5/.ocamlformat b/src/lib_protocol_environment/sigs/v5/.ocamlformat new file mode 100644 index 000000000000..5e1158919e85 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/.ocamlformat @@ -0,0 +1,17 @@ +version=0.18.0 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after +space-around-arrays=false +space-around-lists=false +space-around-records=false +space-around-variants=false +dock-collection-brackets=true +space-around-records=false +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always diff --git a/src/lib_protocol_environment/sigs/v5/.ocamlformat-ignore b/src/lib_protocol_environment/sigs/v5/.ocamlformat-ignore new file mode 100644 index 000000000000..154496fb51f6 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/.ocamlformat-ignore @@ -0,0 +1,15 @@ +bytes.mli +char.mli +format.mli +hex.mli +int32.mli +int64.mli +list.mli +lwt.mli +map.mli +option.mli +pervasives.mli +s.mli +set.mli +string.mli +z.mli diff --git a/src/lib_protocol_environment/sigs/v5/RPC_answer.mli b/src/lib_protocol_environment/sigs/v5/RPC_answer.mli new file mode 100644 index 000000000000..4a5f32f30723 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_answer.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Return type for service handler *) +type 'o t = + [ `Ok of 'o (* 200 *) + | `OkChunk of 'o (* 200 but send answer as chunked transfer encoding *) + | `OkStream of 'o stream (* 200 *) + | `Created of string option (* 201 *) + | `No_content (* 204 *) + | `Unauthorized of error list option (* 401 *) + | `Forbidden of error list option (* 403 *) + | `Not_found of error list option (* 404 *) + | `Conflict of error list option (* 409 *) + | `Error of error list option (* 500 *) ] + +and 'a stream = {next : unit -> 'a option Lwt.t; shutdown : unit -> unit} + +val return : 'o -> 'o t Lwt.t + +(** [return_chunked] is identical to [return] but it indicates to the server + that the result might be long and that the serialisation should be done in + mutliple chunks. + + You should use [return_chunked] when returning an (unbounded or potentially + large) list, array, map, or other such set. *) +val return_chunked : 'o -> 'o t Lwt.t + +val return_stream : 'o stream -> 'o t Lwt.t + +val not_found : 'o t Lwt.t + +val fail : error list -> 'a t Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/RPC_arg.mli b/src/lib_protocol_environment/sigs/v5/RPC_arg.mli new file mode 100644 index 000000000000..660a6bfada34 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_arg.mli @@ -0,0 +1,64 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** See [src/lib_rpc/RPC_arg.mli] for documentation *) + +type 'a t + +type 'a arg = 'a t + +val make : + ?descr:string -> + name:string -> + destruct:(string -> ('a, string) result) -> + construct:('a -> string) -> + unit -> + 'a arg + +type descr = {name : string; descr : string option} + +val descr : 'a arg -> descr + +val bool : bool arg + +val int : int arg + +val uint : int arg + +val int32 : int32 arg + +val uint31 : int32 arg + +val int64 : int64 arg + +val uint63 : int64 arg + +val string : string arg + +val like : 'a arg -> ?descr:string -> string -> 'a arg + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +val eq : 'a arg -> 'b arg -> ('a, 'b) eq option diff --git a/src/lib_protocol_environment/sigs/v5/RPC_context.mli b/src/lib_protocol_environment/sigs/v5/RPC_context.mli new file mode 100644 index 000000000000..3eb4b4094aee --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_context.mli @@ -0,0 +1,149 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Updater.rpc_context + +class type ['pr] simple = + object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end + +val make_call0 : + ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'q -> + 'i -> + 'o shell_tzresult Lwt.t + +val make_call1 : + ([< RPC_service.meth], t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o shell_tzresult Lwt.t + +val make_call2 : + ([< RPC_service.meth], t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o shell_tzresult Lwt.t + +val make_call3 : + ([< RPC_service.meth], t, ((t * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o shell_tzresult Lwt.t + +val make_opt_call0 : + ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'q -> + 'i -> + 'o option shell_tzresult Lwt.t + +val make_opt_call1 : + ([< RPC_service.meth], t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o option shell_tzresult Lwt.t + +val make_opt_call2 : + ([< RPC_service.meth], t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o option shell_tzresult Lwt.t + +val make_opt_call3 : + ([< RPC_service.meth], t, ((t * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + 'pr #simple -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o option shell_tzresult Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/RPC_directory.mli b/src/lib_protocol_environment/sigs/v5/RPC_directory.mli new file mode 100644 index 000000000000..b45970de9bfa --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_directory.mli @@ -0,0 +1,259 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Dispatch tree *) +type 'prefix t + +type 'prefix directory = 'prefix t + +(** Empty list of dispatch trees *) +val empty : 'prefix directory + +val map : ('a -> 'b Lwt.t) -> 'b directory -> 'a directory + +val prefix : ('pr, 'p) RPC_path.path -> 'p directory -> 'pr directory + +val merge : 'a directory -> 'a directory -> 'a directory + +(** Possible error while registering services. *) +type step = + | Static of string + | Dynamic of RPC_arg.descr + | DynamicTail of RPC_arg.descr + +type conflict = + | CService of RPC_service.meth + | CDir + | CBuilder + | CTail + | CTypes of RPC_arg.descr * RPC_arg.descr + | CType of RPC_arg.descr * string list + +exception Conflict of step list * conflict + +(** Registering handler in service tree. + + The [chunked] parameter controls whether the answer to the RPC is chunk + encoded (i.e., the serialisation is split and the caller receives the answer + in multiple chunks) or not. Defaults to [false]. Set to [true] for RPCs that + return potentially large collections (e.g., unbounded lists). *) +val register : + chunked:bool -> + 'prefix directory -> + ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t -> + ('params -> 'query -> 'input -> 'output tzresult Lwt.t) -> + 'prefix directory + +val opt_register : + chunked:bool -> + 'prefix directory -> + ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t -> + ('params -> 'query -> 'input -> 'output option tzresult Lwt.t) -> + 'prefix directory + +val gen_register : + 'prefix directory -> + ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t -> + ('params -> 'query -> 'input -> [< 'output RPC_answer.t] Lwt.t) -> + 'prefix directory + +val lwt_register : + chunked:bool -> + 'prefix directory -> + ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t -> + ('params -> 'query -> 'input -> 'output Lwt.t) -> + 'prefix directory + +(** Registering handler in service tree. Curryfied variant. *) + +val register0 : + chunked:bool -> + unit directory -> + ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> + ('q -> 'i -> 'o tzresult Lwt.t) -> + unit directory + +val register1 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + +val register2 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + +val register3 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + +val register4 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + +val register5 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + +val opt_register0 : + chunked:bool -> + unit directory -> + ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> + ('q -> 'i -> 'o option tzresult Lwt.t) -> + unit directory + +val opt_register1 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'q -> 'i -> 'o option tzresult Lwt.t) -> + 'prefix directory + +val opt_register2 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'q -> 'i -> 'o option tzresult Lwt.t) -> + 'prefix directory + +val opt_register3 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'q -> 'i -> 'o option tzresult Lwt.t) -> + 'prefix directory + +val opt_register4 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o option tzresult Lwt.t) -> + 'prefix directory + +val opt_register5 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o option tzresult Lwt.t) -> + 'prefix directory + +val gen_register0 : + unit directory -> + ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> + ('q -> 'i -> [< 'o RPC_answer.t] Lwt.t) -> + unit directory + +val gen_register1 : + 'prefix directory -> + ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) -> + 'prefix directory + +val gen_register2 : + 'prefix directory -> + ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) -> + 'prefix directory + +val gen_register3 : + 'prefix directory -> + ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) -> + 'prefix directory + +val gen_register4 : + 'prefix directory -> + ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) -> + 'prefix directory + +val gen_register5 : + 'prefix directory -> + ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) -> + 'prefix directory + +val lwt_register0 : + chunked:bool -> + unit directory -> + ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> + ('q -> 'i -> 'o Lwt.t) -> + unit directory + +val lwt_register1 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register2 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register3 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register4 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register5 : + chunked:bool -> + 'prefix directory -> + ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q, 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +(** Registering dynamic subtree. *) +val register_dynamic_directory : + ?descr:string -> + 'prefix directory -> + ('prefix, 'a) RPC_path.t -> + ('a -> 'a directory Lwt.t) -> + 'prefix directory diff --git a/src/lib_protocol_environment/sigs/v5/RPC_path.mli b/src/lib_protocol_environment/sigs/v5/RPC_path.mli new file mode 100644 index 000000000000..4cfe075e3334 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_path.mli @@ -0,0 +1,50 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type ('prefix, 'params) t + +type ('prefix, 'params) path = ('prefix, 'params) t + +type 'prefix context = ('prefix, 'prefix) path + +val root : unit context + +val open_root : 'a context + +val add_suffix : ('prefix, 'params) path -> string -> ('prefix, 'params) path + +val ( / ) : ('prefix, 'params) path -> string -> ('prefix, 'params) path + +val add_arg : + ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a) path + +val ( /: ) : + ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a) path + +val add_final_args : + ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path + +val ( /:* ) : + ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path diff --git a/src/lib_protocol_environment/sigs/v5/RPC_query.mli b/src/lib_protocol_environment/sigs/v5/RPC_query.mli new file mode 100644 index 000000000000..b0e15c3121a1 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_query.mli @@ -0,0 +1,66 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type 'a t + +type 'a query = 'a t + +val empty : unit query + +type ('a, 'b) field + +val field : + ?descr:string -> string -> 'a RPC_arg.t -> 'a -> ('b -> 'a) -> ('b, 'a) field + +val opt_field : + ?descr:string -> + string -> + 'a RPC_arg.t -> + ('b -> 'a option) -> + ('b, 'a option) field + +val flag : ?descr:string -> string -> ('b -> bool) -> ('b, bool) field + +val multi_field : + ?descr:string -> + string -> + 'a RPC_arg.t -> + ('b -> 'a list) -> + ('b, 'a list) field + +type ('a, 'b, 'c) open_query + +val query : 'b -> ('a, 'b, 'b) open_query + +val ( |+ ) : + ('a, 'b, 'c -> 'd) open_query -> ('a, 'c) field -> ('a, 'b, 'd) open_query + +val seal : ('a, 'b, 'a) open_query -> 'a t + +type untyped = (string * string) list + +exception Invalid of string + +val parse : 'a query -> untyped -> 'a diff --git a/src/lib_protocol_environment/sigs/v5/RPC_service.mli b/src/lib_protocol_environment/sigs/v5/RPC_service.mli new file mode 100644 index 000000000000..828749243485 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/RPC_service.mli @@ -0,0 +1,71 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** HTTP methods. *) +type meth = [`GET | `POST | `DELETE | `PUT | `PATCH] + +type (+'meth, 'prefix, 'params, 'query, 'input, 'output) t + constraint 'meth = [< meth] + +type (+'meth, 'prefix, 'params, 'query, 'input, 'output) service = + ('meth, 'prefix, 'params, 'query, 'input, 'output) t + +val get_service : + ?description:string -> + query:'query RPC_query.t -> + output:'output Data_encoding.t -> + ('prefix, 'params) RPC_path.t -> + ([`GET], 'prefix, 'params, 'query, unit, 'output) service + +val post_service : + ?description:string -> + query:'query RPC_query.t -> + input:'input Data_encoding.t -> + output:'output Data_encoding.t -> + ('prefix, 'params) RPC_path.t -> + ([`POST], 'prefix, 'params, 'query, 'input, 'output) service + +val delete_service : + ?description:string -> + query:'query RPC_query.t -> + output:'output Data_encoding.t -> + ('prefix, 'params) RPC_path.t -> + ([`DELETE], 'prefix, 'params, 'query, unit, 'output) service + +val patch_service : + ?description:string -> + query:'query RPC_query.t -> + input:'input Data_encoding.t -> + output:'output Data_encoding.t -> + ('prefix, 'params) RPC_path.t -> + ([`PATCH], 'prefix, 'params, 'query, 'input, 'output) service + +val put_service : + ?description:string -> + query:'query RPC_query.t -> + input:'input Data_encoding.t -> + output:'output Data_encoding.t -> + ('prefix, 'params) RPC_path.t -> + ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service diff --git a/src/lib_protocol_environment/sigs/v5/base58.mli b/src/lib_protocol_environment/sigs/v5/base58.mli new file mode 100644 index 000000000000..145c91b6e4ef --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/base58.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type 'a encoding + +val simple_decode : 'a encoding -> string -> 'a option + +val simple_encode : 'a encoding -> 'a -> string + +type data = .. + +val register_encoding : + prefix:string -> + length:int -> + to_raw:('a -> string) -> + of_raw:(string -> 'a option) -> + wrap:('a -> data) -> + 'a encoding + +val check_encoded_prefix : 'a encoding -> string -> int -> unit + +val decode : string -> data option diff --git a/src/lib_protocol_environment/sigs/v5/bits.mli b/src/lib_protocol_environment/sigs/v5/bits.mli new file mode 100644 index 000000000000..1882f25c8e52 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/bits.mli @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Assuming [x >= 0], [numbits x] is the number of bits needed to + represent [x]. This is also the unique [k] such that [2^{k - 1} + <= x < 2^k] if [x > 0] and [0] otherwise. *) +val numbits : int -> int diff --git a/src/lib_protocol_environment/sigs/v5/blake2B.mli b/src/lib_protocol_environment/sigs/v5/blake2B.mli new file mode 100644 index 000000000000..29dcaab0e819 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/blake2B.mli @@ -0,0 +1,58 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Builds a new Hash type using Blake2B. *) + +(** The parameters for creating a new Hash type using + {!Make_Blake2B}. Both {!name} and {!title} are only informative, + used in error messages and serializers. *) + +module type Name = sig + val name : string + + val title : string + + val size : int option +end + +module type PrefixedName = sig + include Name + + val b58check_prefix : string +end + +module Make_minimal (Name : Name) : S.MINIMAL_HASH + +module type Register = sig + val register_encoding : + prefix:string -> + length:int -> + to_raw:('a -> string) -> + of_raw:(string -> 'a option) -> + wrap:('a -> Base58.data) -> + 'a Base58.encoding +end + +module Make (Register : Register) (Name : PrefixedName) : S.HASH diff --git a/src/lib_protocol_environment/sigs/v5/block_hash.mli b/src/lib_protocol_environment/sigs/v5/block_hash.mli new file mode 100644 index 000000000000..701c94cbbf1d --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/block_hash.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Blocks hashes / IDs. *) +include S.HASH diff --git a/src/lib_protocol_environment/sigs/v5/block_header.mli b/src/lib_protocol_environment/sigs/v5/block_header.mli new file mode 100644 index 000000000000..4a533311117c --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/block_header.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type shell_header = { + level : Int32.t; + (** The number of preceding block in this chain, i.e. the genesis + has level 0. *) + proto_level : int; + (** The number of preceding protocol change in the chain (modulo 256), + i.e. the genesis has proto_level 0. *) + predecessor : Block_hash.t; + timestamp : Time.t; + validation_passes : int; + operations_hash : Operation_list_list_hash.t; + fitness : Bytes.t list; + context : Context_hash.t; +} + +val shell_header_encoding : shell_header Data_encoding.t + +type t = {shell : shell_header; protocol_data : bytes} + +include S.HASHABLE with type t := t and type hash := Block_hash.t diff --git a/src/lib_protocol_environment/sigs/v5/bls12_381.mli b/src/lib_protocol_environment/sigs/v5/bls12_381.mli new file mode 100644 index 000000000000..cfa9d40e45d8 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/bls12_381.mli @@ -0,0 +1,32 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Fr : S.PRIME_FIELD + +module G1 : S.CURVE with type Scalar.t = Fr.t + +module G2 : S.CURVE with type Scalar.t = Fr.t + +val pairing_check : (G1.t * G2.t) list -> bool diff --git a/src/lib_protocol_environment/sigs/v5/bls_signature.mli b/src/lib_protocol_environment/sigs/v5/bls_signature.mli new file mode 100644 index 000000000000..ca4f59d42ea3 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/bls_signature.mli @@ -0,0 +1,62 @@ +(* MIT License +* +* Copyright (c) 2020 Danny Willems +* Copyright (c) 2020 Nomadic Labs +* +* Permission is hereby granted, free of charge, to any person obtaining a copy +* of this software and associated documentation files (the "Software"), to deal +* in the Software without restriction, including without limitation the rights +* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +* copies of the Software, and to permit persons to whom the Software is +* furnished to do so, subject to the following conditions: +* +* The above copyright notice and this permission notice shall be included in all +* copies or substantial portions of the Software. +* +* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +* SOFTWARE. *) + +(** Type of the public keys *) +type pk + +(* Not abstracting the type to avoid to write (de)serialisation routines *) +type signature = Bytes.t + +(** Build a value of type [pk] without performing any check on the input. + It is safe to use this function when verifying a signature as the + signature function verifies if the point is in the prime subgroup. Using + [unsafe_pk_of_bytes] removes a verification performed twice when used + [pk_of_bytes_exn] or [pk_of_bytes_opt]. + + The expected bytes format are the compressed form of a point on G1. *) + +val unsafe_pk_of_bytes : Bytes.t -> pk + +(** Build a value of type [pk] safely, i.e. the function checks the bytes + given in parameters represents a point on the curve and in the prime subgroup. + Return [None] if the bytes are not in the correct format or does + not represent a point in the prime subgroup. + + The expected bytes format are the compressed form of a point on G1. +*) +val pk_of_bytes_opt : Bytes.t -> pk option + +(** Returns a bytes representation of a value of type [pk]. The output is the + compressed form a the point G1.t the [pk] represents. +*) +val pk_to_bytes : pk -> Bytes.t + +(** [aggregate_signature_opt signatures] aggregates the signatures [signatures], following + https://datatracker.ietf.org/doc/html/draft-irtf-cfrg-bls-signature-04#section-2.8. + Return [None] if [INVALID] is expected in the specification +*) +val aggregate_signature_opt : Bytes.t list -> Bytes.t option + +val verify : pk -> Bytes.t -> signature -> bool + +val aggregate_verify : (pk * Bytes.t) list -> signature -> bool diff --git a/src/lib_protocol_environment/sigs/v5/bytes.mli b/src/lib_protocol_environment/sigs/v5/bytes.mli new file mode 100644 index 000000000000..b19a0d423d3b --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/bytes.mli @@ -0,0 +1,260 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Byte sequence operations. + + A byte sequence is a mutable data structure that contains a + fixed-length sequence of bytes. Each byte can be indexed in + constant time for reading or writing. + + Given a byte sequence [s] of length [l], we can access each of the + [l] bytes of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + bytes or at the beginning or end of the sequence. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the byte at index [n] is between positions + [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + range of [s] if [len >= 0] and [start] and [start+len] are valid + positions in [s]. + + Byte sequences can be modified in place, for instance via the [set] + and [blit] functions described below. See also strings (module + {!String}), which are almost the same data structure, but cannot be + modified in place. + + Bytes are represented by the OCaml type [char]. + + @since 4.02.0 + *) + +external length : bytes -> int = "%bytes_length" +(** Return the length (number of bytes) of the argument. *) + +external get : bytes -> int -> char = "%bytes_safe_get" +(** [get s n] returns the byte at index [n] in argument [s]. + + Raise [Invalid_argument] if [n] is not a valid index in [s]. *) + +external set : bytes -> int -> char -> unit = "%bytes_safe_set" +(** [set s n c] modifies [s] in place, replacing the byte at index [n] + with [c]. + + Raise [Invalid_argument] if [n] is not a valid index in [s]. *) + +val make : int -> char -> bytes +(** [make n c] returns a new byte sequence of length [n], filled with + the byte [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> (int -> char) -> bytes +(** [Bytes.init n f] returns a fresh byte sequence of length [n], with + character [i] initialized to the result of [f i] (in increasing + index order). + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val empty : bytes +(** A byte sequence of size 0. *) + +val copy : bytes -> bytes +(** Return a new byte sequence that contains the same bytes as the + argument. *) + +val of_string : string -> bytes +(** Return a new byte sequence that contains the same bytes as the + given string. *) + +val to_string : bytes -> string +(** Return a new string that contains the same bytes as the given byte + sequence. *) + +val sub : bytes -> int -> int -> bytes +(** [sub s start len] returns a new byte sequence of length [len], + containing the subsequence of [s] that starts at position [start] + and has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val sub_string : bytes -> int -> int -> string +(** Same as [sub] but return a string instead of a byte sequence. *) + +val extend : bytes -> int -> int -> bytes +(** [extend s left right] returns a new byte sequence that contains + the bytes of [s], with [left] uninitialized bytes prepended and + [right] uninitialized bytes appended to it. If [left] or [right] + is negative, then bytes are removed (instead of appended) from + the corresponding side of [s]. + + Raise [Invalid_argument] if the result length is negative or + longer than {!Sys.max_string_length} bytes. *) + +val fill : bytes -> int -> int -> char -> unit +(** [fill s start len c] modifies [s] in place, replacing [len] + characters with [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val blit : bytes -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from sequence + [src], starting at index [srcoff], to sequence [dst], starting at + index [dstoff]. It works correctly even if [src] and [dst] are the + same byte sequence, and the source and destination intervals + overlap. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val blit_string : string -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from string + [src], starting at index [srcoff], to byte sequence [dst], + starting at index [dstoff]. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val concat : bytes -> bytes list -> bytes +(** [concat sep sl] concatenates the list of byte sequences [sl], + inserting the separator byte sequence [sep] between each, and + returns the result as a new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val cat : bytes -> bytes -> bytes +(** [cat s1 s2] concatenates [s1] and [s2] and returns the result + as new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val iter : (char -> unit) -> bytes -> unit +(** [iter f s] applies function [f] in turn to all the bytes of [s]. + It is equivalent to [f (get s 0); f (get s 1); ...; f (get s + (length s - 1)); ()]. *) + +val iteri : (int -> char -> unit) -> bytes -> unit +(** Same as {!Bytes.iter}, but the function is applied to the index of + the byte as first argument and the byte itself as second + argument. *) + +val map : (char -> char) -> bytes -> bytes +(** [map f s] applies function [f] in turn to all the bytes of [s] + (in increasing index order) and stores the resulting bytes in + a new sequence that is returned as the result. *) + +val mapi : (int -> char -> char) -> bytes -> bytes +(** [mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the resulting bytes + in a new sequence that is returned as the result. *) + +val trim : bytes -> bytes +(** Return a copy of the argument, without leading and trailing + whitespace. The bytes regarded as whitespace are the ASCII + characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *) + +val escaped : bytes -> bytes +(** Return a copy of the argument, with special characters represented + by escape sequences, following the lexical conventions of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash and double-quote. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val index_opt: bytes -> char -> int option +(** [index_opt s c] returns the index of the first occurrence of byte [c] + in [s] or [None] if [c] does not occur in [s]. + @since 4.05 *) + +val rindex_opt: bytes -> char -> int option +(** [rindex_opt s c] returns the index of the last occurrence of byte [c] + in [s] or [None] if [c] does not occur in [s]. + @since 4.05 *) + +val index_from_opt: bytes -> int -> char -> int option +(** [index_from _opts i c] returns the index of the first occurrence of + byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] + after position [i]. + [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + @since 4.05 *) + +val rindex_from_opt: bytes -> int -> char -> int option +(** [rindex_from_opt s i c] returns the index of the last occurrence + of byte [c] in [s] before position [i+1] or [None] if [c] does not + occur in [s] before position [i+1]. [rindex_opt s c] is equivalent to + [rindex_from s (Bytes.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + @since 4.05 *) + +val contains : bytes -> char -> bool +(** [contains s c] tests if byte [c] appears in [s]. *) + +val contains_from : bytes -> int -> char -> bool +(** [contains_from s start c] tests if byte [c] appears in [s] after + position [start]. [contains s c] is equivalent to [contains_from + s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : bytes -> int -> char -> bool +(** [rcontains_from s stop c] tests if byte [c] appears in [s] before + position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase_ascii : bytes -> bytes +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) + +val lowercase_ascii : bytes -> bytes +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) + +val capitalize_ascii : bytes -> bytes +(** Return a copy of the argument, with the first character set to uppercase, + using the US-ASCII character set. + @since 4.03.0 *) + +val uncapitalize_ascii : bytes -> bytes +(** Return a copy of the argument, with the first character set to lowercase, + using the US-ASCII character set. + @since 4.03.0 *) + +type t = bytes +(** An alias for the type of byte sequences. *) + +val compare: t -> t -> int +(** The comparison function for byte sequences, with the same + specification as {!Stdlib.compare}. Along with the type [t], + this function [compare] allows the module [Bytes] to be passed as + argument to the functors {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equality function for byte sequences. + @since 4.03.0 *) diff --git a/src/lib_protocol_environment/sigs/v5/chain_id.mli b/src/lib_protocol_environment/sigs/v5/chain_id.mli new file mode 100644 index 000000000000..2203c82e602b --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/chain_id.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include S.HASH diff --git a/src/lib_protocol_environment/sigs/v5/char.mli b/src/lib_protocol_environment/sigs/v5/char.mli new file mode 100644 index 000000000000..638fd6e47f59 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/char.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Character operations. *) + +external code : char -> int = "%identity" +(** Return the ASCII code of the argument. *) + +val chr : int -> char +(** Return the character with the given ASCII code. + Raise [Invalid_argument "Char.chr"] if the argument is + outside the range 0--255. *) + +val escaped : char -> string +(** Return a string representing the given character, + with special characters escaped following the lexical conventions + of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash, double-quote, and single-quote. *) + +val lowercase_ascii : char -> char +(** Convert the given character to its equivalent lowercase character, + using the US-ASCII character set. + @since 4.03.0 *) + +val uppercase_ascii : char -> char +(** Convert the given character to its equivalent uppercase character, + using the US-ASCII character set. + @since 4.03.0 *) + +type t = char +(** An alias for the type of characters. *) + +val compare: t -> t -> int +(** The comparison function for characters, with the same specification as + {!Stdlib.compare}. Along with the type [t], this function [compare] + allows the module [Char] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equal function for chars. + @since 4.03.0 *) diff --git a/src/lib_protocol_environment/sigs/v5/compare.mli b/src/lib_protocol_environment/sigs/v5/compare.mli new file mode 100644 index 000000000000..73d6ad373c39 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/compare.mli @@ -0,0 +1,116 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type COMPARABLE = sig + type t + + val compare : t -> t -> int +end + +module type S = sig + type t + + val ( = ) : t -> t -> bool + + val ( <> ) : t -> t -> bool + + val ( < ) : t -> t -> bool + + val ( <= ) : t -> t -> bool + + val ( >= ) : t -> t -> bool + + val ( > ) : t -> t -> bool + + val compare : t -> t -> int + + val equal : t -> t -> bool + + val max : t -> t -> t + + val min : t -> t -> t +end + +module Make (P : COMPARABLE) : S with type t := P.t + +module Char : S with type t = char + +module Bool : S with type t = bool + +module Int : S with type t = int + +module Int32 : S with type t = int32 + +module Uint32 : S with type t = int32 + +module Int64 : S with type t = int64 + +module Uint64 : S with type t = int64 + +module String : S with type t = string + +module Bytes : S with type t = bytes + +module Z : S with type t = Z.t + +module List (P : COMPARABLE) : S with type t = P.t list + +module Option (P : COMPARABLE) : S with type t = P.t option + +module List_length_with : sig + val ( = ) : 'a list -> int -> bool + + val ( <> ) : 'a list -> int -> bool + + val ( < ) : 'a list -> int -> bool + + val ( <= ) : 'a list -> int -> bool + + val ( >= ) : 'a list -> int -> bool + + val ( > ) : 'a list -> int -> bool + + val compare : 'a list -> int -> int + + val equal : 'a list -> int -> bool +end + +module List_lengths : sig + val ( = ) : 'a list -> 'b list -> bool + + val ( <> ) : 'a list -> 'b list -> bool + + val ( < ) : 'a list -> 'b list -> bool + + val ( <= ) : 'a list -> 'b list -> bool + + val ( >= ) : 'a list -> 'b list -> bool + + val ( > ) : 'a list -> 'b list -> bool + + val compare : 'a list -> 'b list -> int + + val equal : 'a list -> 'b list -> bool +end diff --git a/src/lib_protocol_environment/sigs/v5/context.mli b/src/lib_protocol_environment/sigs/v5/context.mli new file mode 100644 index 000000000000..6114a50ed394 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/context.mli @@ -0,0 +1,324 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** View over the context store, restricted to types, access and + functional manipulation of an existing context. *) + +(* Copy/paste of Environment_context_sigs.Context.S *) + +(** The tree depth of a fold. See the [fold] function for more information. *) +type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] + +module type VIEW = sig + (** The type for context views. *) + type t + + (** The type for context keys. *) + type key + + (** The type for context values. *) + type value + + (** The type for context trees. *) + type tree + + (** {2 Getters} *) + + (** [mem t k] is an Lwt promise that resolves to [true] iff [k] is bound + to a value in [t]. *) + val mem : t -> key -> bool Lwt.t + + (** [mem_tree t k] is like {!mem} but for trees. *) + val mem_tree : t -> key -> bool Lwt.t + + (** [find t k] is an Lwt promise that resolves to [Some v] if [k] is + bound to the value [v] in [t] and [None] otherwise. *) + val find : t -> key -> value option Lwt.t + + (** [find_tree t k] is like {!find} but for trees. *) + val find_tree : t -> key -> tree option Lwt.t + + (** [list t key] is the list of files and sub-nodes stored under [k] in [t]. + The result order is not specified but is stable. + + [offset] and [length] are used for pagination. *) + val list : + t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t + + (** {2 Setters} *) + + (** [add t k v] is an Lwt promise that resolves to [c] such that: + + - [k] is bound to [v] in [c]; + - and [c] is similar to [t] otherwise. + + If [k] was already bound in [t] to a value that is physically equal + to [v], the result of the function is a promise that resolves to + [t]. Otherwise, the previous binding of [k] in [t] disappears. *) + val add : t -> key -> value -> t Lwt.t + + (** [add_tree] is like {!add} but for trees. *) + val add_tree : t -> key -> tree -> t Lwt.t + + (** [remove t k v] is an Lwt promise that resolves to [c] such that: + + - [k] is unbound in [c]; + - and [c] is similar to [t] otherwise. *) + val remove : t -> key -> t Lwt.t + + (** {2 Folding} *) + + (** [fold ?depth t root ~init ~f] recursively folds over the trees + and values of [t]. The [f] callbacks are called with a key relative + to [root]. [f] is never called with an empty key for values; i.e., + folding over a value is a no-op. + + Elements are traversed in lexical order of keys. + + The depth is 0-indexed. If [depth] is set (by default it is not), then [f] + is only called when the conditions described by the parameter is true: + + - [Eq d] folds over nodes and contents of depth exactly [d]. + - [Lt d] folds over nodes and contents of depth strictly less than [d]. + - [Le d] folds over nodes and contents of depth less than or equal to [d]. + - [Gt d] folds over nodes and contents of depth strictly more than [d]. + - [Ge d] folds over nodes and contents of depth more than or equal to [d]. + + If [order] is [`Sorted] (the default), the elements are traversed in + lexicographic order of their keys. For large nodes, these two modes are memory-consuming, + use [`Undefined] for a more memory efficient [fold]. *) + val fold : + ?depth:depth -> + t -> + key -> + order:[`Sorted | `Undefined] -> + init:'a -> + f:(key -> tree -> 'a -> 'a Lwt.t) -> + 'a Lwt.t +end + +module Kind : sig + type t = [`Value | `Tree] +end + +module type TREE = sig + (** [Tree] provides immutable, in-memory partial mirror of the + context, with lazy reads and delayed writes. + + Trees are immutable and non-persistent (they disappear if the + host crash), held in memory for efficiency, where reads are done + lazily and writes are done only when needed, e.g. on + [Context.commit]. If a key is modified twice, only the last + value will be written to disk on commit. *) + + (** The type for context views. *) + type t + + (** The type for context trees. *) + type tree + + include VIEW with type t := tree and type tree := tree + + (** [empty _] is the empty tree. *) + val empty : t -> tree + + (** [is_empty t] is true iff [t] is [empty _]. *) + val is_empty : tree -> bool + + (** [kind t] is [t]'s kind. It's either a tree node or a leaf + value. *) + val kind : tree -> Kind.t + + (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] + is a leaf tree and [None] otherwise. It is equivalent to [find t + []]. *) + val to_value : tree -> value option Lwt.t + + (** [of_value _ v] is an Lwt promise that resolves to the leaf tree + [v]. Is is equivalent to [add (empty _) [] v]. *) + val of_value : t -> value -> tree Lwt.t + + (** [hash t] is [t]'s Merkle hash. *) + val hash : tree -> Context_hash.t + + (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) + val equal : tree -> tree -> bool + + (** {2 Caches} *) + + (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a + depth higher than [depth]. If [depth] is not set, all of the subtrees are + cleared. *) + val clear : ?depth:int -> tree -> unit +end + +include VIEW with type key = string list and type value = bytes + +module Tree : + TREE + with type t := t + and type key := key + and type value := value + and type tree := tree + +val register_resolver : + 'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit + +val complete : t -> string -> string list Lwt.t + +(** Get the hash version used for the context *) +val get_hash_version : t -> Context_hash.Version.t + +(** Set the hash version used for the context. It may recalculate the hashes + of the whole context, which can be a long process. + Returns an Error if the hash version is unsupported. *) +val set_hash_version : + t -> Context_hash.Version.t -> t Error_monad.shell_tzresult Lwt.t + +type cache_key + +type cache_value = .. + +module type CACHE = sig + (** Type for context view. A context contains a cache. A cache is + made of subcaches. Each subcache has its own size limit. The + limit of its subcache is called a layout and can be initialized + via the [set_cache_layout] function. *) + type t + + (** Size for subcaches and values of the cache. Units are not + specified and left to the economic protocol. *) + type size + + (** Index type to index caches. *) + type index + + (** Identifier type for keys. *) + type identifier + + (** A key uniquely identifies a cached [value] in some subcache. *) + type key + + (** Cached values inhabit an extensible type. *) + type value = .. + + (** [key_of_identifier ~cache_index identifier] builds a key from the + [cache_index] and the [identifier]. + + No check are made to ensure the validity of the index. *) + val key_of_identifier : cache_index:index -> identifier -> key + + (** [identifier_of_key key] returns the identifier associated to the + [key]. *) + val identifier_of_key : key -> identifier + + (** [pp fmt cache] is a pretty printter for a [cache]. *) + val pp : Format.formatter -> t -> unit + + (** [find ctxt k = Some v] if [v] is the value associated to [k] in + in the cache where [k] is. Returns [None] if there is no such + value in the cache of [k]. This function is in the Lwt monad + because if the value has not been constructed, it is constructed + on the fly. *) + val find : t -> key -> value option Lwt.t + + (** [set_cache_layout ctxt layout] sets the caches of [ctxt] to + comply with given [layout]. If there was already a cache in + [ctxt], it is erased by the new layout. + + Otherwise, a fresh collection of empty caches is reconstructed + from the new [layout]. Notice that cache [key]s are invalidated + in that case, i.e., [get t k] will return [None]. *) + val set_cache_layout : t -> size list -> t Lwt.t + + (** [update ctxt k (Some (e, size))] returns a cache where the value + [e] of [size] is associated to key [k]. If [k] is already in the + cache, the cache entry is updated. + + [update ctxt k None] removes [k] from the cache. *) + val update : t -> key -> (value * size) option -> t + + (** [sync ctxt ~cache_nonce] updates the context with the domain of + the cache computed so far. Such function is expected to be called + at the end of the validation of a block, when there is no more + accesses to the cache. + + [cache_nonce] identifies the block that introduced new cache + entries. The nonce should identify uniquely the block which + modifies this value. It cannot be the block hash for circularity + reasons: The value of the nonce is stored onto the context and + consequently influences the context hash of the very same + block. Such nonce cannot be determined by the shell and its + computation is delegated to the economic protocol. + *) + val sync : t -> cache_nonce:Bytes.t -> t Lwt.t + + (** [clear ctxt] removes all cache entries. *) + val clear : t -> t + + (** {3 Cache introspection} *) + + (** [list_keys ctxt ~cache_index] returns the list of cached keys in + cache numbered [cache_index] along with their respective + [size]. The returned list is sorted in terms of their age in the + cache, the oldest coming first. If [cache_index] is invalid, + then this function returns [None]. *) + val list_keys : t -> cache_index:index -> (key * size) list option + + (** [key_rank index ctxt key] returns the number of cached value older + than the given [key]; or, [None] if the [key] is not a cache key. *) + val key_rank : t -> key -> int option + + (** {3 Cache helpers for RPCs} *) + + (** [future_cache_expectation ctxt ~time_in_blocks] returns [ctxt] except + that the entries of the caches that are presumably too old to + still be in the caches in [n_blocks] are removed. + + This function is based on a heuristic. The context maintains + the median of the number of removed entries: this number is + multipled by `n_blocks` to determine the entries that are + likely to be removed in `n_blocks`. *) + val future_cache_expectation : t -> time_in_blocks:int -> t + + (** [cache_size ctxt ~cache_index] returns an overapproximation of + the size of the cache. Returns [None] if [cache_index] is not a + valid cache index. *) + val cache_size : t -> cache_index:index -> size option + + (** [cache_size_limit ctxt ~cache_index] returns the maximal size of + the cache indexed by [cache_index]. Returns [None] if + [cache_index] is not a valid cache index. *) + val cache_size_limit : t -> cache_index:index -> size option +end + +module Cache : + CACHE + with type t := t + and type size := int + and type index := int + and type identifier := string + and type key = cache_key + and type value = cache_value diff --git a/src/lib_protocol_environment/sigs/v5/context_hash.mli b/src/lib_protocol_environment/sigs/v5/context_hash.mli new file mode 100644 index 000000000000..104973b3519b --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/context_hash.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Committed context hashes / IDs. *) +include S.HASH + +(** The module for representing the hash version of a context *) +module Version : sig + (** The type for hash versions. *) + type t = private int + + include Compare.S with type t := t + + (** [pp] is the pretty-printer for hash versions. *) + val pp : Format.formatter -> t -> unit + + (** [encoding] is the data encoding for hash versions. *) + val encoding : t Data_encoding.t + + (** [of_int i] is the hash version equivalent to [i]. + This function raises [Invalid_argument] if [i] is not an unsigned 16-bit integer. *) + val of_int : int -> t +end + +type version = Version.t diff --git a/src/lib_protocol_environment/sigs/v5/data_encoding.mli b/src/lib_protocol_environment/sigs/v5/data_encoding.mli new file mode 100644 index 000000000000..3d769e970673 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/data_encoding.mli @@ -0,0 +1,445 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** In memory JSON data *) +type json = + [ `O of (string * json) list + | `Bool of bool + | `Float of float + | `A of json list + | `Null + | `String of string ] + +type json_schema + +type 'a t + +type 'a encoding = 'a t + +val classify : 'a encoding -> [`Fixed of int | `Dynamic | `Variable] + +val splitted : json:'a encoding -> binary:'a encoding -> 'a encoding + +val null : unit encoding + +val empty : unit encoding + +val unit : unit encoding + +val constant : string -> unit encoding + +val int8 : int encoding + +val uint8 : int encoding + +val int16 : int encoding + +val uint16 : int encoding + +val int31 : int encoding + +val int32 : int32 encoding + +val int64 : int64 encoding + +val n : Z.t encoding + +val z : Z.t encoding + +val bool : bool encoding + +val string : string encoding + +val bytes : bytes encoding + +val option : 'a encoding -> 'a option encoding + +val string_enum : (string * 'a) list -> 'a encoding + +module Fixed : sig + val string : int -> string encoding + + val bytes : int -> bytes encoding + + val add_padding : 'a encoding -> int -> 'a encoding +end + +module Variable : sig + val string : string encoding + + val bytes : bytes encoding + + val array : ?max_length:int -> 'a encoding -> 'a array encoding + + val list : ?max_length:int -> 'a encoding -> 'a list encoding +end + +module Bounded : sig + val string : int -> string encoding + + val bytes : int -> bytes encoding +end + +val dynamic_size : + ?kind:[`Uint30 | `Uint16 | `Uint8] -> 'a encoding -> 'a encoding + +val json : json encoding + +val json_schema : json_schema encoding + +type 'a field + +val req : + ?title:string -> ?description:string -> string -> 't encoding -> 't field + +val opt : + ?title:string -> + ?description:string -> + string -> + 't encoding -> + 't option field + +val varopt : + ?title:string -> + ?description:string -> + string -> + 't encoding -> + 't option field + +val dft : + ?title:string -> + ?description:string -> + string -> + 't encoding -> + 't -> + 't field + +val obj1 : 'f1 field -> 'f1 encoding + +val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding + +val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding + +val obj4 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + ('f1 * 'f2 * 'f3 * 'f4) encoding + +val obj5 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + 'f5 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding + +val obj6 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + 'f5 field -> + 'f6 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding + +val obj7 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + 'f5 field -> + 'f6 field -> + 'f7 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding + +val obj8 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + 'f5 field -> + 'f6 field -> + 'f7 field -> + 'f8 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding + +val obj9 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + 'f5 field -> + 'f6 field -> + 'f7 field -> + 'f8 field -> + 'f9 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding + +val obj10 : + 'f1 field -> + 'f2 field -> + 'f3 field -> + 'f4 field -> + 'f5 field -> + 'f6 field -> + 'f7 field -> + 'f8 field -> + 'f9 field -> + 'f10 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +val tup1 : 'f1 encoding -> 'f1 encoding + +val tup2 : 'f1 encoding -> 'f2 encoding -> ('f1 * 'f2) encoding + +val tup3 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> ('f1 * 'f2 * 'f3) encoding + +val tup4 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + ('f1 * 'f2 * 'f3 * 'f4) encoding + +val tup5 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + 'f5 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding + +val tup6 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + 'f5 encoding -> + 'f6 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding + +val tup7 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + 'f5 encoding -> + 'f6 encoding -> + 'f7 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding + +val tup8 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + 'f5 encoding -> + 'f6 encoding -> + 'f7 encoding -> + 'f8 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding + +val tup9 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + 'f5 encoding -> + 'f6 encoding -> + 'f7 encoding -> + 'f8 encoding -> + 'f9 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding + +val tup10 : + 'f1 encoding -> + 'f2 encoding -> + 'f3 encoding -> + 'f4 encoding -> + 'f5 encoding -> + 'f6 encoding -> + 'f7 encoding -> + 'f8 encoding -> + 'f9 encoding -> + 'f10 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding + +val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding + +val array : ?max_length:int -> 'a encoding -> 'a array encoding + +val list : ?max_length:int -> 'a encoding -> 'a list encoding + +val assoc : 'a encoding -> (string * 'a) list encoding + +type case_tag = Tag of int | Json_only + +type 't case + +val case : + title:string -> + ?description:string -> + case_tag -> + 'a encoding -> + ('t -> 'a option) -> + ('a -> 't) -> + 't case + +type match_result + +type 'a matching_function = 'a -> match_result + +(* [tag_size] is not declared in the upstream library, instead, the expanded + polymorphic-variant type-expression is used as is. We include it in the + protocol environment to help coq-of-ocaml process the files. *) +type tag_size = [`Uint8 | `Uint16] + +val matched : ?tag_size:tag_size -> int -> 'a encoding -> 'a -> match_result + +val matching : + ?tag_size:tag_size -> 't matching_function -> 't case list -> 't encoding + +val union : ?tag_size:tag_size -> 't case list -> 't encoding + +val def : + string -> ?title:string -> ?description:string -> 't encoding -> 't encoding + +val conv : + ('a -> 'b) -> ('b -> 'a) -> ?schema:json_schema -> 'b encoding -> 'a encoding + +val conv_with_guard : + ('a -> 'b) -> + ('b -> ('a, string) result) -> + ?schema:json_schema -> + 'b encoding -> + 'a encoding + +val with_decoding_guard : + ('a -> (unit, string) result) -> 'a encoding -> 'a encoding + +val mu : + string -> + ?title:string -> + ?description:string -> + ('a encoding -> 'a encoding) -> + 'a encoding + +type 'a lazy_t + +val lazy_encoding : 'a encoding -> 'a lazy_t encoding + +val force_decode : 'a lazy_t -> 'a option + +val force_bytes : 'a lazy_t -> bytes + +val make_lazy : 'a encoding -> 'a -> 'a lazy_t + +val apply_lazy : + fun_value:('a -> 'b) -> + fun_bytes:(bytes -> 'b) -> + fun_combine:('b -> 'b -> 'b) -> + 'a lazy_t -> + 'b + +module Json : sig + val schema : ?definitions_path:string -> 'a encoding -> json_schema + + val construct : 't encoding -> 't -> json + + val destruct : 't encoding -> json -> 't + + (** JSON Error *) + + type path = path_item list + + and path_item = + [ `Field of string (** A field in an object. *) + | `Index of int (** An index in an array. *) + | `Star (** Any / every field or index. *) + | `Next (** The next element after an array. *) ] + + (** Exception raised by destructors, with the location in the original + JSON structure and the specific error. *) + exception Cannot_destruct of (path * exn) + + (** Unexpected kind of data encountered (w/ the expectation). *) + exception Unexpected of string * string + + (** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *) + exception No_case_matched of exn list + + (** Array of unexpected size encountered (w/ the expectation). *) + exception Bad_array_size of int * int + + (** Missing field in an object. *) + exception Missing_field of string + + (** Supernumerary field in an object. *) + exception Unexpected_field of string + + val print_error : + ?print_unknown:(Format.formatter -> exn -> unit) -> + Format.formatter -> + exn -> + unit + + (** Helpers for writing encoders. *) + val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a + + val wrap_error : ('a -> 'b) -> 'a -> 'b + + val pp : Format.formatter -> json -> unit +end + +module Binary : sig + val fixed_length : 'a encoding -> int option + + val maximum_length : 'a encoding -> int option + + val length : 'a encoding -> 'a -> int + + val to_bytes_opt : ?buffer_size:int -> 'a encoding -> 'a -> bytes option + + val to_bytes_exn : ?buffer_size:int -> 'a encoding -> 'a -> bytes + + val of_bytes_opt : 'a encoding -> bytes -> 'a option + + val to_string_opt : ?buffer_size:int -> 'a encoding -> 'a -> string option + + val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string + + val of_string_opt : 'a encoding -> string -> 'a option +end + +(** [check_size size encoding] ensures that the binary encoding + of a value will not be allowed to exceed [size] bytes. The reader + and the writer fails otherwise. This function do not modify + the JSON encoding. *) +val check_size : int -> 'a encoding -> 'a encoding diff --git a/src/lib_protocol_environment/sigs/v5/ed25519.mli b/src/lib_protocol_environment/sigs/v5/ed25519.mli new file mode 100644 index 000000000000..2d96e41b1546 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/ed25519.mli @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos - Ed25519 cryptography *) + +include S.SIGNATURE with type watermark := bytes diff --git a/src/lib_protocol_environment/sigs/v5/equality_witness.mli b/src/lib_protocol_environment/sigs/v5/equality_witness.mli new file mode 100644 index 000000000000..9c3ea56fd2ac --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/equality_witness.mli @@ -0,0 +1,62 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + + This module provides support for type equalities and runtime type identifiers. + + For two types [a] and [b], [(a, b) eq] is a witness that [a = b]. This is + a standard generalized algebraic datatype on top of which type-level + programming techniques can be implemented. + + Given a type [a], an inhabitant of [a t] is a dynamic identifier for [a]. + Identifiers can be compared for equality. They are also equipped with a + hash function. + + WARNING: the hash function changes at every run. Therefore, the result + of the hash function should never be stored. + + Notice that dynamic identifiers are not unique: two identifiers for [a] + can have distinct hash and can be physically distinct. Hence, only [eq] + can decide if two type identifiers correspond to the same type. + +*) + +(** A proof witness that two types are equal. *) +type (_, _) eq = Refl : ('a, 'a) eq + +(** A dynamic representation for ['a]. *) +type 'a t + +(** [make ()] is a dynamic representation for ['a]. A fresh identifier + is returned each time [make ()] is evaluated. *) +val make : unit -> 'a t + +(** [eq ida idb] returns a proof that [a = b] if [ida] and [idb] + identify the same type. *) +val eq : 'a t -> 'b t -> ('a, 'b) eq option + +(** [hash id] returns a hash for [id]. *) +val hash : 'a t -> int diff --git a/src/lib_protocol_environment/sigs/v5/error_monad.mli b/src/lib_protocol_environment/sigs/v5/error_monad.mli new file mode 100644 index 000000000000..4858b5924602 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/error_monad.mli @@ -0,0 +1,224 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error_category = [`Branch | `Temporary | `Permanent | `Outdated] + +(** CORE : errors *) + +type error = .. + +val error_encoding : error Data_encoding.t + +val pp : Format.formatter -> error -> unit + +(** EXT : error registration/query *) + +val register_error_kind : + error_category -> + id:string -> + title:string -> + description:string -> + ?pp:(Format.formatter -> 'err -> unit) -> + 'err Data_encoding.t -> + (error -> 'err option) -> + ('err -> error) -> + unit + +val json_of_error : error -> Data_encoding.json + +val error_of_json : Data_encoding.json -> error + +type error_info = { + category : error_category; + id : string; + title : string; + description : string; + schema : Data_encoding.json_schema; +} + +val pp_info : Format.formatter -> error_info -> unit + +(** Retrieves information of registered errors *) +val get_registered_errors : unit -> error_info list + +(** MONAD : trace, monad, etc. *) + +type 'err trace + +type 'a tzresult = ('a, error trace) result + +val make_trace_encoding : 'error Data_encoding.t -> 'error trace Data_encoding.t + +val trace_encoding : error trace Data_encoding.t + +val pp_trace : Format.formatter -> error trace -> unit + +val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t + +val ok : 'a -> ('a, 'trace) result + +val return : 'a -> ('a, 'trace) result Lwt.t + +val return_unit : (unit, 'trace) result Lwt.t + +val return_none : ('a option, 'trace) result Lwt.t + +val return_some : 'a -> ('a option, 'trace) result Lwt.t + +val return_nil : ('a list, 'trace) result Lwt.t + +val return_true : (bool, 'trace) result Lwt.t + +val return_false : (bool, 'trace) result Lwt.t + +val error : 'err -> ('a, 'err trace) result + +val trace_of_error : 'err -> 'err trace + +val fail : 'err -> ('a, 'err trace) result Lwt.t + +val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + +val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t + +val ( >>? ) : + ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result + +val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result + +val ( >>=? ) : + ('a, 'trace) result Lwt.t -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t + +val ( >|=? ) : + ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) result Lwt.t + +val ( >>?= ) : + ('a, 'trace) result -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t + +val ( >|?= ) : + ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t + +val record_trace : 'err -> ('a, 'err trace) result -> ('a, 'err trace) result + +val trace : + 'err -> ('b, 'err trace) result Lwt.t -> ('b, 'err trace) result Lwt.t + +val record_trace_eval : + (unit -> 'err) -> ('a, 'err trace) result -> ('a, 'err trace) result + +val trace_eval : + (unit -> 'err) -> + ('b, 'err trace) result Lwt.t -> + ('b, 'err trace) result Lwt.t + +val error_unless : bool -> 'err -> (unit, 'err trace) result + +val error_when : bool -> 'err -> (unit, 'err trace) result + +val fail_unless : bool -> 'err -> (unit, 'err trace) result Lwt.t + +val fail_when : bool -> 'err -> (unit, 'err trace) result Lwt.t + +val unless : + bool -> (unit -> (unit, 'trace) result Lwt.t) -> (unit, 'trace) result Lwt.t + +val when_ : + bool -> (unit -> (unit, 'trace) result Lwt.t) -> (unit, 'trace) result Lwt.t + +val dont_wait : + (exn -> unit) -> + ('trace -> unit) -> + (unit -> (unit, 'trace) result Lwt.t) -> + unit + +(** [catch f] executes [f] within a try-with block and wraps exceptions within + a [tzresult]. [catch f] is equivalent to + [try Ok (f ()) with e -> Error (error_of_exn e)]. + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] is + [true] are caught. + + Whether [catch_only] is set or not, this function never catches + non-deterministic runtime exceptions of OCaml such as {!Stack_overflow} and + {!Out_of_memory} nor system-exceptions such as {!Unix.Unix_error} and + {!Sys_error}. *) +val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a tzresult + +(** [catch_f f handler] is equivalent to [map_error (catch f) handler]. + In other words, it catches exceptions in [f ()] and either returns the + value in an [Ok] or passes the exception to [handler] for the [Error]. + + [catch_only] has the same use as with [catch]. The same restriction on + catching non-deterministic runtime exceptions applies. *) +val catch_f : + ?catch_only:(exn -> bool) -> (unit -> 'a) -> (exn -> error) -> 'a tzresult + +(** [catch_s] is like [catch] but when [f] returns a promise. It is equivalent + to + +{[ +Lwt.try_bind f + (fun v -> Lwt.return (Ok v)) + (fun e -> Lwt.return (Error (error_of_exn e))) +]} + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] is + [true] are caught. + + Whether [catch_only] is set or not, this function never catches + non-deterministic runtime exceptions of OCaml such as {!Stack_overflow} and + {!Out_of_memory} nor system-exceptions such as {!Unix.Unix_error} and + {!Sys_error}. *) +val catch_s : + ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a tzresult Lwt.t + +(* Synchronisation *) + +val join_e : (unit, 'err trace) result list -> (unit, 'err trace) result + +val all_e : ('a, 'err trace) result list -> ('a list, 'err trace) result + +val both_e : + ('a, 'err trace) result -> + ('b, 'err trace) result -> + ('a * 'b, 'err trace) result + +(**/**) + +(* The protocol environment needs to know about shell's tzresult because they are + used for in-protocol RPCs. Moreover, some light processing on these results + is done in the protocol which requires the type to be concrete. + + The type is kept private because the environment is sole responsible for + wrapping the protocol's errors into the shell's. *) + +type shell_tztrace + +type 'a shell_tzresult = ('a, shell_tztrace) result diff --git a/src/lib_protocol_environment/sigs/v5/fallbackArray.mli b/src/lib_protocol_environment/sigs/v5/fallbackArray.mli new file mode 100644 index 000000000000..71dd14d3c3e7 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/fallbackArray.mli @@ -0,0 +1,70 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + + This module implements arrays equipped with accessors that cannot + raise exceptions. Reading out of the bounds of the arrays return a + fallback value fixed at array construction time, writing out of the + bounds of the arrays is ignored. + +*) + +(** The type for array containing values of type ['a]. *) +type 'a t + +(** [make len v] builds an array [a] initialized [len] cells with + [v]. The value [v] is the fallback value for [a]. *) +val make : int -> 'a -> 'a t + +(** [fallback a] returns the fallback value for [a]. *) +val fallback : 'a t -> 'a + +(** [length a] returns the length of [a]. *) +val length : 'a t -> int + +(** [get a idx] returns the contents of the cell of index [idx] in + [a]. If [idx] < 0 or [idx] >= [length a], [get a idx] = + [fallback a]. *) +val get : 'a t -> int -> 'a + +(** [set a idx value] updates the cell of index [idx] with [value]. + If [idx] < 0 or [idx] >= [length a], [a] is unchanged. *) +val set : 'a t -> int -> 'a -> unit + +(** [iter f a] iterates [f] over the cells of [a] from the + cell indexed [0] to the cell indexed [length a - 1]. *) +val iter : ('a -> unit) -> 'a t -> unit + +(** [map f a] computes a new array obtained by applying [f] to each + cell contents of [a]. Notice that the fallback value of the new + array is [f (fallback a)]. *) +val map : ('a -> 'b) -> 'a t -> 'b t + +(** [fold a init f] traverses [a] from the cell indexed [0] to the + cell indexed [length a - 1] and transforms [accu] into [f accu x] + where [x] is the content of the cell under focus. [accu] is + [init] on the first iteration. *) +val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b diff --git a/src/lib_protocol_environment/sigs/v5/fitness.mli b/src/lib_protocol_environment/sigs/v5/fitness.mli new file mode 100644 index 000000000000..3408d03a94fe --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/fitness.mli @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The fitness of a block is defined as a list of bytes, + compared in a lexicographical order (longer list are greater). *) +include S.T with type t = bytes list diff --git a/src/lib_protocol_environment/sigs/v5/format.mli b/src/lib_protocol_environment/sigs/v5/format.mli new file mode 100644 index 000000000000..e5b04e2bcab6 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/format.mli @@ -0,0 +1,747 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Pretty-printing. + + This module implements a pretty-printing facility to format values + within {{!boxes}'pretty-printing boxes'} and {{!tags}'semantic tags'} + combined with a set of {{!fpp}printf-like functions}. + The pretty-printer splits lines at specified {{!breaks}break hints}, + and indents lines according to the box structure. + Similarly, {{!tags}semantic tags} can be used to decouple text + presentation from its contents. + + This pretty-printing facility is implemented as an overlay on top of + abstract {{!section:formatter}formatters} which provide basic output + functions. + Some formatters are predefined, notably: + - {!std_formatter} outputs to {{!Stdlib.stdout}stdout} + - {!err_formatter} outputs to {{!Stdlib.stderr}stderr} + + Most functions in the {!Format} module come in two variants: + a short version that operates on {!std_formatter} and the + generic version prefixed by [pp_] that takes a formatter + as its first argument. + + More formatters can be created with {!formatter_of_out_channel}, + {!formatter_of_buffer}, {!formatter_of_symbolic_output_buffer} + or using {{!section:formatter}custom formatters}. + +*) + +(** {1 Introduction} + For a gentle introduction to the basics of pretty-printing using + [Format], read + {{:http://caml.inria.fr/resources/doc/guides/format.en.html} + http://caml.inria.fr/resources/doc/guides/format.en.html}. + + You may consider this module as providing an extension to the + [printf] facility to provide automatic line splitting. The addition of + pretty-printing annotations to your regular [printf] format strings gives + you fancy indentation and line breaks. + Pretty-printing annotations are described below in the documentation of + the function {!Format.fprintf}. + + You may also use the explicit pretty-printing box management and printing + functions provided by this module. This style is more basic but more + verbose than the concise [fprintf] format strings. + + For instance, the sequence + [open_box 0; print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()] + that prints [x = 1] within a pretty-printing box, can be + abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter + [printf "@[x =@ %i@]@." 1]. + + Rule of thumb for casual users of this library: + - use simple pretty-printing boxes (as obtained by [open_box 0]); + - use simple break hints as obtained by [print_cut ()] that outputs a + simple break hint, or by [print_space ()] that outputs a space + indicating a break hint; + - once a pretty-printing box is open, display its material with basic + printing functions (e. g. [print_int] and [print_string]); + - when the material for a pretty-printing box has been printed, call + [close_box ()] to close the box; + - at the end of pretty-printing, flush the pretty-printer to display all + the remaining material, e.g. evaluate [print_newline ()]. + + The behavior of pretty-printing commands is unspecified + if there is no open pretty-printing box. Each box opened by + one of the [open_] functions below must be closed using [close_box] + for proper formatting. Otherwise, some of the material printed in the + boxes may not be output, or may be formatted incorrectly. + + In case of interactive use, each phrase is executed in the initial state + of the standard pretty-printer: after each phrase execution, the + interactive system closes all open pretty-printing boxes, flushes all + pending text, and resets the standard pretty-printer. + + Warning: mixing calls to pretty-printing functions of this module with + calls to {!Stdlib} low level output functions is error prone. + + The pretty-printing functions output material that is delayed in the + pretty-printer queue and stacks in order to compute proper line + splitting. In contrast, basic I/O output functions write directly in + their output device. As a consequence, the output of a basic I/O function + may appear before the output of a pretty-printing function that has been + called before. For instance, + [ + Stdlib.print_string "<"; + Format.print_string "PRETTY"; + Stdlib.print_string ">"; + Format.print_string "TEXT"; + ] + leads to output [<>PRETTYTEXT]. + +*) + +type formatter +(** Abstract data corresponding to a pretty-printer (also called a + formatter) and all its machinery. See also {!section:formatter}. *) + +(** {1:boxes Pretty-printing boxes} *) + +(** The pretty-printing engine uses the concepts of pretty-printing box and + break hint to drive indentation and line splitting behavior of the + pretty-printer. + + Each different pretty-printing box kind introduces a specific line splitting + policy: + + - within an {e horizontal} box, break hints never split the line (but the + line may be split in a box nested deeper), + - within a {e vertical} box, break hints always split the line, + - within an {e horizontal/vertical} box, if the box fits on the current line + then break hints never split the line, otherwise break hint always split + the line, + - within a {e compacting} box, a break hint never splits the line, + unless there is no more room on the current line. + + Note that line splitting policy is box specific: the policy of a box does + not rule the policy of inner boxes. For instance, if a vertical box is + nested in an horizontal box, all break hints within the vertical box will + split the line. +*) + +val pp_open_box : formatter -> int -> unit +(** [pp_open_box ppf d] opens a new compacting pretty-printing box with + offset [d] in the formatter [ppf]. + + Within this box, the pretty-printer prints as much as possible material on + every line. + + A break hint splits the line if there is no more room on the line to + print the remainder of the box. + + Within this box, the pretty-printer emphasizes the box structure: a break + hint also splits the line if the splitting ``moves to the left'' + (i.e. the new line gets an indentation smaller than the one of the current + line). + + This box is the general purpose pretty-printing box. + + If the pretty-printer splits the line in the box, offset [d] is added to + the current indentation. +*) + + +val pp_close_box : formatter -> unit -> unit +(** Closes the most recently open pretty-printing box. *) + +val pp_open_hbox : formatter -> unit -> unit +(** [pp_open_hbox ppf ()] opens a new 'horizontal' pretty-printing box. + + This box prints material on a single line. + + Break hints in a horizontal box never split the line. + (Line splitting may still occur inside boxes nested deeper). +*) + +val pp_open_vbox : formatter -> int -> unit +(** [pp_open_vbox ppf d] opens a new 'vertical' pretty-printing box + with offset [d]. + + This box prints material on as many lines as break hints in the box. + + Every break hint in a vertical box splits the line. + + If the pretty-printer splits the line in the box, [d] is added to the + current indentation. +*) + +val pp_open_hvbox : formatter -> int -> unit +(** [pp_open_hvbox ppf d] opens a new 'horizontal/vertical' pretty-printing box + with offset [d]. + + This box behaves as an horizontal box if it fits on a single line, + otherwise it behaves as a vertical box. + + If the pretty-printer splits the line in the box, [d] is added to the + current indentation. +*) + +val pp_open_hovbox : formatter -> int -> unit +(** [pp_open_hovbox ppf d] opens a new 'horizontal-or-vertical' + pretty-printing box with offset [d]. + + This box prints material as much as possible on every line. + + A break hint splits the line if there is no more room on the line to + print the remainder of the box. + + If the pretty-printer splits the line in the box, [d] is added to the + current indentation. +*) + +(** {1 Formatting functions} *) + +val pp_print_string : formatter -> string -> unit +(** [pp_print_string ppf s] prints [s] in the current pretty-printing box. *) + +val pp_print_as : formatter -> int -> string -> unit +(** [pp_print_as ppf len s] prints [s] in the current pretty-printing box. + The pretty-printer formats [s] as if it were of length [len]. +*) + +val pp_print_int : formatter -> int -> unit +(** Print an integer in the current pretty-printing box. *) + +val pp_print_char : formatter -> char -> unit +(** Print a character in the current pretty-printing box. *) + +val pp_print_bool : formatter -> bool -> unit +(** Print a boolean in the current pretty-printing box. *) + +(** {1:breaks Break hints} *) + +(** A 'break hint' tells the pretty-printer to output some space or split the + line whichever way is more appropriate to the current pretty-printing box + splitting rules. + + Break hints are used to separate printing items and are mandatory to let + the pretty-printer correctly split lines and indent items. + + Simple break hints are: + - the 'space': output a space or split the line if appropriate, + - the 'cut': split the line if appropriate. + + Note: the notions of space and line splitting are abstract for the + pretty-printing engine, since those notions can be completely redefined + by the programmer. + However, in the pretty-printer default setting, ``output a space'' simply + means printing a space character (ASCII code 32) and ``split the line'' + means printing a newline character (ASCII code 10). +*) + +val pp_print_space : formatter -> unit -> unit +(** [pp_print_space ppf ()] emits a 'space' break hint: + the pretty-printer may split the line at this point, + otherwise it prints one space. + + [pp_print_space ppf ()] is equivalent to [pp_print_break ppf 1 0]. +*) + +val pp_print_cut : formatter -> unit -> unit +(** [pp_print_cut ppf ()] emits a 'cut' break hint: + the pretty-printer may split the line at this point, + otherwise it prints nothing. + + [pp_print_cut ppf ()] is equivalent to [pp_print_break ppf 0 0]. +*) + +val pp_print_break : formatter -> int -> int -> unit +(** [pp_print_break ppf nspaces offset] emits a 'full' break hint: + the pretty-printer may split the line at this point, + otherwise it prints [nspaces] spaces. + + If the pretty-printer splits the line, [offset] is added to + the current indentation. +*) + +val pp_print_custom_break : + formatter -> + fits:(string * int * string) -> + breaks:(string * int * string) -> + unit +(** [pp_print_custom_break ppf ~fits:(s1, n, s2) ~breaks:(s3, m, s4)] emits a + custom break hint: the pretty-printer may split the line at this point. + + If it does not split the line, then the [s1] is emitted, then [n] spaces, + then [s2]. + + If it splits the line, then it emits the [s3] string, then an indent + (according to the box rules), then an offset of [m] spaces, then the [s4] + string. + + While [n] and [m] are handled by [formatter_out_functions.out_indent], the + strings will be handled by [formatter_out_functions.out_string]. This allows + for a custom formatter that handles indentation distinctly, for example, + outputs [
] tags or [ ] entities. + + The custom break is useful if you want to change which visible + (non-whitespace) characters are printed in case of break or no break. For + example, when printing a list {[ [a; b; c] ]}, you might want to add a + trailing semicolon when it is printed vertically: + + {[ +[ + a; + b; + c; +] + ]} + + You can do this as follows: + {[ +printf "@[[@;<0 2>@[a;@,b;@,c@]%t]@]@\n" + (pp_print_custom_break ~fits:("", 0, "") ~breaks:(";", 0, "")) + ]} + + @since 4.08.0 +*) + +val pp_force_newline : formatter -> unit -> unit +(** Force a new line in the current pretty-printing box. + + The pretty-printer must split the line at this point, + + Not the normal way of pretty-printing, since imperative line splitting may + interfere with current line counters and box size calculation. + Using break hints within an enclosing vertical box is a better + alternative. +*) + +val pp_print_if_newline : formatter -> unit -> unit +(** Execute the next formatting command if the preceding line + has just been split. Otherwise, ignore the next formatting + command. +*) + +(** {1 Pretty-printing termination} *) + +val pp_print_flush : formatter -> unit -> unit +(** End of pretty-printing: resets the pretty-printer to initial state. + + All open pretty-printing boxes are closed, all pending text is printed. + In addition, the pretty-printer low level output device is flushed to + ensure that all pending text is really displayed. + + Note: never use [print_flush] in the normal course of a pretty-printing + routine, since the pretty-printer uses a complex buffering machinery to + properly indent the output; manually flushing those buffers at random + would conflict with the pretty-printer strategy and result to poor + rendering. + + Only consider using [print_flush] when displaying all pending material is + mandatory (for instance in case of interactive use when you want the user + to read some text) and when resetting the pretty-printer state will not + disturb further pretty-printing. + + Warning: If the output device of the pretty-printer is an output channel, + repeated calls to [print_flush] means repeated calls to {!Stdlib.flush} + to flush the out channel; these explicit flush calls could foil the + buffering strategy of output channels and could dramatically impact + efficiency. +*) + +val pp_print_newline : formatter -> unit -> unit +(** End of pretty-printing: resets the pretty-printer to initial state. + + All open pretty-printing boxes are closed, all pending text is printed. + + Equivalent to {!print_flush} followed by a new line. + See corresponding words of caution for {!print_flush}. + + Note: this is not the normal way to output a new line; + the preferred method is using break hints within a vertical pretty-printing + box. +*) + +(** {1 Margin} *) + +val pp_set_margin : formatter -> int -> unit +(** [pp_set_margin ppf d] sets the right margin to [d] (in characters): + the pretty-printer splits lines that overflow the right margin according to + the break hints given. + Nothing happens if [d] is smaller than 2. + If [d] is too large, the right margin is set to the maximum + admissible value (which is greater than [10 ^ 9]). + If [d] is less than the current maximum indentation limit, the + maximum indentation limit is decreased while trying to preserve + a minimal ratio [max_indent/margin>=50%] and if possible + the current difference [margin - max_indent]. + + See also {!pp_set_geometry}. +*) + +val pp_get_margin : formatter -> unit -> int +(** Returns the position of the right margin. *) + +(** {1 Maximum indentation limit} *) + +val pp_set_max_indent : formatter -> int -> unit +(** [pp_set_max_indent ppf d] sets the maximum indentation limit of lines + to [d] (in characters): + once this limit is reached, new pretty-printing boxes are rejected to the + left, unless the enclosing box fully fits on the current line. + As an illustration, + {[ set_margin 10; set_max_indent 5; printf "@[123456@[7@]89A@]@." ]} + yields + {[ + 123456 + 789A + ]} + because the nested box ["@[7@]"] is opened after the maximum indentation + limit ([7>5]) and its parent box does not fit on the current line. + Either decreasing the length of the parent box to make it fit on a line: + {[ printf "@[123456@[7@]89@]@." ]} + or opening an intermediary box before the maximum indentation limit which + fits on the current line + {[ printf "@[123@[456@[7@]89@]A@]@." ]} + avoids the rejection to the left of the inner boxes and print respectively + ["123456789"] and ["123456789A"] . + Note also that vertical boxes never fit on a line whereas horizontal boxes + always fully fit on the current line. + + Nothing happens if [d] is smaller than 2. + + If [d] is too large, the limit is set to the maximum + admissible value (which is greater than [10 ^ 9]). + + If [d] is greater or equal than the current margin, it is ignored, + and the current maximum indentation limit is kept. + + See also {!pp_set_geometry}. +*) + +val pp_get_max_indent : formatter -> unit -> int +(** Return the maximum indentation limit (in characters). *) + +(** {1 Maximum formatting depth} *) + +(** The maximum formatting depth is the maximum number of pretty-printing + boxes simultaneously open. + + Material inside boxes nested deeper is printed as an ellipsis (more + precisely as the text returned by {!get_ellipsis_text} [()]). +*) + +val pp_set_max_boxes : formatter -> int -> unit +(** [pp_set_max_boxes ppf max] sets the maximum number of pretty-printing + boxes simultaneously open. + + Material inside boxes nested deeper is printed as an ellipsis (more + precisely as the text returned by {!get_ellipsis_text} [()]). + + Nothing happens if [max] is smaller than 2. +*) + +val pp_get_max_boxes : formatter -> unit -> int +(** Returns the maximum number of pretty-printing boxes allowed before + ellipsis. +*) + +val pp_over_max_boxes : formatter -> unit -> bool +(** Tests if the maximum number of pretty-printing boxes allowed have already + been opened. +*) + +(** {1 Tabulation boxes} *) + +(** + + A {e tabulation box} prints material on lines divided into cells of fixed + length. A tabulation box provides a simple way to display vertical columns + of left adjusted text. + + This box features command [set_tab] to define cell boundaries, and command + [print_tab] to move from cell to cell and split the line when there is no + more cells to print on the line. + + Note: printing within tabulation box is line directed, so arbitrary line + splitting inside a tabulation box leads to poor rendering. Yet, controlled + use of tabulation boxes allows simple printing of columns within + module {!Format}. +*) + +val pp_open_tbox : formatter -> unit -> unit +(** [open_tbox ()] opens a new tabulation box. + + This box prints lines separated into cells of fixed width. + + Inside a tabulation box, special {e tabulation markers} defines points of + interest on the line (for instance to delimit cell boundaries). + Function {!Format.set_tab} sets a tabulation marker at insertion point. + + A tabulation box features specific {e tabulation breaks} to move to next + tabulation marker or split the line. Function {!Format.print_tbreak} prints + a tabulation break. +*) + +val pp_close_tbox : formatter -> unit -> unit +(** Closes the most recently opened tabulation box. *) + +val pp_set_tab : formatter -> unit -> unit +(** Sets a tabulation marker at current insertion point. *) + +val pp_print_tab : formatter -> unit -> unit +(** [print_tab ()] emits a 'next' tabulation break hint: if not already set on + a tabulation marker, the insertion point moves to the first tabulation + marker on the right, or the pretty-printer splits the line and insertion + point moves to the leftmost tabulation marker. + + It is equivalent to [print_tbreak 0 0]. *) + +val pp_print_tbreak : formatter -> int -> int -> unit +(** [print_tbreak nspaces offset] emits a 'full' tabulation break hint. + + If not already set on a tabulation marker, the insertion point moves to the + first tabulation marker on the right and the pretty-printer prints + [nspaces] spaces. + + If there is no next tabulation marker on the right, the pretty-printer + splits the line at this point, then insertion point moves to the leftmost + tabulation marker of the box. + + If the pretty-printer splits the line, [offset] is added to + the current indentation. +*) + +(** {1 Ellipsis} *) + +val pp_set_ellipsis_text : formatter -> string -> unit +(** Set the text of the ellipsis printed when too many pretty-printing boxes + are open (a single dot, [.], by default). +*) + +val pp_get_ellipsis_text : formatter -> unit -> string +(** Return the text of the ellipsis. *) + +(** {1 Convenience formatting functions.} *) + +val pp_print_list: + ?pp_sep:(formatter -> unit -> unit) -> + (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit) +(** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l], + using [pp_v] to print each item, and calling [pp_sep] + between items ([pp_sep] defaults to {!pp_print_cut}. + Does nothing on empty lists. + + @since 4.02.0 +*) + +val pp_print_text : formatter -> string -> unit +(** [pp_print_text ppf s] prints [s] with spaces and newlines respectively + printed using {!pp_print_space} and {!pp_force_newline}. + + @since 4.02.0 +*) + +val pp_print_option : + ?none:(formatter -> unit -> unit) -> + (formatter -> 'a -> unit) -> (formatter -> 'a option -> unit) +(** [pp_print_option ?none pp_v ppf o] prints [o] on [ppf] + using [pp_v] if [o] is [Some v] and [none] if it is [None]. [none] + prints nothing by default. + + @since 4.08 *) + +val pp_print_result : + ok:(formatter -> 'a -> unit) -> error:(formatter -> 'e -> unit) -> + formatter -> ('a, 'e) result -> unit +(** [pp_print_result ~ok ~error ppf r] prints [r] on [ppf] using + [ok] if [r] is [Ok _] and [error] if [r] is [Error _]. + + @since 4.08 *) + +(** {1:fpp Formatted pretty-printing} *) + +(** + Module [Format] provides a complete set of [printf] like functions for + pretty-printing using format string specifications. + + Specific annotations may be added in the format strings to give + pretty-printing commands to the pretty-printing engine. + + Those annotations are introduced in the format strings using the [@] + character. For instance, [@ ] means a space break, [@,] means a cut, + [@\[] opens a new box, and [@\]] closes the last open box. + +*) + +val fprintf : formatter -> ('a, formatter, unit) format -> 'a + +(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] + according to the format string [fmt], and outputs the resulting string on + the formatter [ff]. + + The format string [fmt] is a character string which contains three types of + objects: plain characters and conversion specifications as specified in + the {!Printf} module, and pretty-printing indications specific to the + [Format] module. + + The pretty-printing indication characters are introduced by + a [@] character, and their meanings are: + - [@\[]: open a pretty-printing box. The type and offset of the + box may be optionally specified with the following syntax: + the [<] character, followed by an optional box type indication, + then an optional integer offset, and the closing [>] character. + Pretty-printing box type is one of [h], [v], [hv], [b], or [hov]. + '[h]' stands for an 'horizontal' pretty-printing box, + '[v]' stands for a 'vertical' pretty-printing box, + '[hv]' stands for an 'horizontal/vertical' pretty-printing box, + '[b]' stands for an 'horizontal-or-vertical' pretty-printing box + demonstrating indentation, + '[hov]' stands a simple 'horizontal-or-vertical' pretty-printing box. + For instance, [@\[] opens an 'horizontal-or-vertical' + pretty-printing box with indentation 2 as obtained with [open_hovbox 2]. + For more details about pretty-printing boxes, see the various box opening + functions [open_*box]. + - [@\]]: close the most recently opened pretty-printing box. + - [@,]: output a 'cut' break hint, as with [print_cut ()]. + - [@ ]: output a 'space' break hint, as with [print_space ()]. + - [@;]: output a 'full' break hint as with [print_break]. The + [nspaces] and [offset] parameters of the break hint may be + optionally specified with the following syntax: + the [<] character, followed by an integer [nspaces] value, + then an integer [offset], and a closing [>] character. + If no parameters are provided, the good break defaults to a + 'space' break hint. + - [@.]: flush the pretty-printer and split the line, as with + [print_newline ()]. + - [@]: print the following item as if it were of length [n]. + Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string. + If [@] is not followed by a conversion specification, + then the following character of the format is printed as if + it were of length [n]. + - [@\{]: open a semantic tag. The name of the tag may be optionally + specified with the following syntax: + the [<] character, followed by an optional string + specification, and the closing [>] character. The string + specification is any character string that does not contain the + closing character ['>']. If omitted, the tag name defaults to the + empty string. + For more details about semantic tags, see the functions {!open_stag} and + {!close_stag}. + - [@\}]: close the most recently opened semantic tag. + - [@?]: flush the pretty-printer as with [print_flush ()]. + This is equivalent to the conversion [%!]. + - [@\n]: force a newline, as with [force_newline ()], not the normal way + of pretty-printing, you should prefer using break hints inside a vertical + pretty-printing box. + + Note: To prevent the interpretation of a [@] character as a + pretty-printing indication, escape it with a [%] character. + Old quotation mode [@@] is deprecated since it is not compatible with + formatted input interpretation of character ['@']. + + Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to + [open_box (); print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()]. + It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box. + +*) + +val sprintf : ('a, unit, string) format -> 'a +(** Same as [printf] above, but instead of printing on a formatter, + returns a string containing the result of formatting the arguments. + Note that the pretty-printer queue is flushed at the end of {e each + call} to [sprintf]. + + In case of multiple and related calls to [sprintf] to output + material on a single string, you should consider using [fprintf] + with the predefined formatter [str_formatter] and call + [flush_str_formatter ()] to get the final result. + + Alternatively, you can use [Format.fprintf] with a formatter writing to a + buffer of your own: flushing the formatter and the buffer at the end of + pretty-printing returns the desired string. +*) + +val asprintf : ('a, formatter, unit, string) format4 -> 'a +(** Same as [printf] above, but instead of printing on a formatter, + returns a string containing the result of formatting the arguments. + The type of [asprintf] is general enough to interact nicely with [%a] + conversions. + + @since 4.01.0 +*) + +val dprintf : + ('a, formatter, unit, formatter -> unit) format4 -> 'a +(** Same as {!fprintf}, except the formatter is the last argument. + [dprintf "..." a b c] is a function of type + [formatter -> unit] which can be given to a format specifier [%t]. + + This can be used as a replacement for {!asprintf} to delay + formatting decisions. Using the string returned by {!asprintf} in a + formatting context forces formatting decisions to be taken in + isolation, and the final string may be created + prematurely. {!dprintf} allows delay of formatting decisions until + the final formatting context is known. + For example: +{[ + let t = Format.dprintf "%i@ %i@ %i" 1 2 3 in + ... + Format.printf "@[%t@]" t +]} + + @since 4.08.0 +*) + + +val ifprintf : formatter -> ('a, formatter, unit) format -> 'a +(** Same as [fprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. + + @since 3.10.0 +*) + +(** Formatted Pretty-Printing with continuations. *) + +val kfprintf : + (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b +(** Same as [fprintf] above, but instead of returning immediately, + passes the formatter to its first argument at the end of printing. *) + +val kdprintf : + ((formatter -> unit) -> 'a) -> + ('b, formatter, unit, 'a) format4 -> 'b +(** Same as {!dprintf} above, but instead of returning immediately, + passes the suspended printer to its first argument at the end of printing. + + @since 4.08.0 +*) + +val ikfprintf : + (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b +(** Same as [kfprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. + + @since 3.12.0 +*) + +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b +(** Same as [sprintf] above, but instead of returning the string, + passes it to the first argument. *) + +val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b +(** Same as [asprintf] above, but instead of returning the string, + passes it to the first argument. + + @since 4.03 +*) diff --git a/src/lib_protocol_environment/sigs/v5/hex.mli b/src/lib_protocol_environment/sigs/v5/hex.mli new file mode 100644 index 000000000000..3bc46cf1a71b --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/hex.mli @@ -0,0 +1,82 @@ +(* + * Copyright (c) 2015 Trevor Summers Smith + * Copyright (c) 2014 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Hexadecimal encoding. + + [Hex] defines hexadecimal encodings for {{!char}characters}, + {{!string}strings} and {{!cstruct}Cstruct.t} buffers. *) + +type t = [`Hex of string] +(** The type var hexadecimal values. *) + +(** {1:char Characters} *) + +val of_char: char -> char * char +(** [of_char c] is the the hexadecimal encoding of the character + [c]. *) + +val to_char: char -> char -> char option +(** [to_char x y] is the character corresponding to the [xy] + hexadecimal encoding. + + Returns [None] if [x] or [y] are not in the ranges ['0'..'9'], + ['a'..'f'], or ['A'..'F']. *) + +(** {1:string Strings} *) + +val of_string: ?ignore:char list -> string -> t +(** [of_string s] is the hexadecimal representation of the binary + string [s]. If [ignore] is set, skip the characters in the list + when converting. Eg [of_string ~ignore:[' '] "a f"]. The default + value of [ignore] is [[]]). *) + +val to_string: t -> string option +(** [to_string t] is the binary string [s] such that [of_string s] is + [t]. + + Returns [None] if [t] contains a character that is not in the range ['0'..'9'], + ['a'..'f'], or ['A'..'F']. *) + +(** {1:byte Bytes} *) + +val of_bytes: ?ignore:char list -> bytes -> t +(** [of_bytes s] is the hexadecimal representation of the binary + string [s]. If [ignore] is set, skip the characters in the list + when converting. Eg [of_bytes ~ignore:[' '] "a f"]. The default + value of [ignore] is [[]]). *) + +val to_bytes: t -> bytes option +(** [to_bytes t] is the binary string [s] such that [of_bytes s] is + [t]. + + Returns [None] if [t] contains a character that is not in the range ['0'..'9'], + ['a'..'f'], or ['A'..'F']. *) + +(** {1 Debugging} *) + +val hexdump_s: ?print_row_numbers:bool -> ?print_chars:bool -> t -> string +(** Same as [hexdump] except returns a string. *) + +(** {1 Pretty printing} *) + +val pp : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] +(** [pp fmt t] will output a human-readable hex representation of [t] + to the formatter [fmt]. *) + +val show : t -> string +(** [show t] will return a human-readable hex representation of [t] as + a string. *) diff --git a/src/lib_protocol_environment/sigs/v5/int32.mli b/src/lib_protocol_environment/sigs/v5/int32.mli new file mode 100644 index 000000000000..cddc53f23b0f --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/int32.mli @@ -0,0 +1,144 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** 32-bit integers. + + This module provides operations on the type [int32] + of signed 32-bit integers. Unlike the built-in [int] type, + the type [int32] is guaranteed to be exactly 32-bit wide on all + platforms. All arithmetic operations over [int32] are taken + modulo 2{^32}. + + Performance notice: values of type [int32] occupy more memory + space than values of type [int], and arithmetic operations on + [int32] are generally slower than those on [int]. Use [int32] + only when the application requires exact 32-bit arithmetic. + + Literals for 32-bit integers are suffixed by l: + {[ + let zero: int32 = 0l + let one: int32 = 1l + let m_one: int32 = -1l + ]} +*) + +val zero : int32 +(** The 32-bit integer 0. *) + +val one : int32 +(** The 32-bit integer 1. *) + +val minus_one : int32 +(** The 32-bit integer -1. *) + +external neg : int32 -> int32 = "%int32_neg" +(** Unary negation. *) + +external add : int32 -> int32 -> int32 = "%int32_add" +(** Addition. *) + +external sub : int32 -> int32 -> int32 = "%int32_sub" +(** Subtraction. *) + +external mul : int32 -> int32 -> int32 = "%int32_mul" +(** Multiplication. *) + +external div : int32 -> int32 -> int32 = "%int32_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Stdlib.(/)}. *) + +external rem : int32 -> int32 -> int32 = "%int32_mod" +(** Integer remainder. If [y] is not zero, the result + of [Int32.rem x y] satisfies the following property: + [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. + If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) + +val succ : int32 -> int32 +(** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) + +val pred : int32 -> int32 +(** Predecessor. [Int32.pred x] is [Int32.sub x Int32.one]. *) + +val abs : int32 -> int32 +(** Return the absolute value of its argument. *) + +val max_int : int32 +(** The greatest representable 32-bit integer, 2{^31} - 1. *) + +val min_int : int32 +(** The smallest representable 32-bit integer, -2{^31}. *) + + +external logand : int32 -> int32 -> int32 = "%int32_and" +(** Bitwise logical and. *) + +external logor : int32 -> int32 -> int32 = "%int32_or" +(** Bitwise logical or. *) + +external logxor : int32 -> int32 -> int32 = "%int32_xor" +(** Bitwise logical exclusive or. *) + +val lognot : int32 -> int32 +(** Bitwise logical negation. *) + +external shift_left : int32 -> int -> int32 = "%int32_lsl" +(** [Int32.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external shift_right : int32 -> int -> int32 = "%int32_asr" +(** [Int32.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" +(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external of_int : int -> int32 = "%int32_of_int" +(** Convert the given integer (type [int]) to a 32-bit integer + (type [int32]). On 64-bit platforms, the argument is taken + modulo 2{^32}. *) + +external to_int : int32 -> int = "%int32_to_int" +(** Convert the given 32-bit integer (type [int32]) to an + integer (type [int]). On 32-bit platforms, the 32-bit integer + is taken modulo 2{^31}, i.e. the high-order bit is lost + during the conversion. On 64-bit platforms, the conversion + is exact. *) + +val of_string_opt: string -> int32 option +(** Same as [of_string], but return [None] instead of raising. + @since 4.05 *) + + +val to_string : int32 -> string +(** Return the string representation of its argument, in signed decimal. *) + +type t = int32 +(** An alias for the type of 32-bit integers. *) + +val compare: t -> t -> int +(** The comparison function for 32-bit integers, with the same specification as + {!Stdlib.compare}. Along with the type [t], this function [compare] + allows the module [Int32] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equal function for int32s. + @since 4.03.0 *) diff --git a/src/lib_protocol_environment/sigs/v5/int64.mli b/src/lib_protocol_environment/sigs/v5/int64.mli new file mode 100644 index 000000000000..5eb4db0154f7 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/int64.mli @@ -0,0 +1,152 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** 64-bit integers. + + This module provides operations on the type [int64] of + signed 64-bit integers. Unlike the built-in [int] type, + the type [int64] is guaranteed to be exactly 64-bit wide on all + platforms. All arithmetic operations over [int64] are taken + modulo 2{^64} + + Performance notice: values of type [int64] occupy more memory + space than values of type [int], and arithmetic operations on + [int64] are generally slower than those on [int]. Use [int64] + only when the application requires exact 64-bit arithmetic. + + Literals for 64-bit integers are suffixed by L: + {[ + let zero: int64 = 0L + let one: int64 = 1L + let m_one: int64 = -1L + ]} +*) + +val zero : int64 +(** The 64-bit integer 0. *) + +val one : int64 +(** The 64-bit integer 1. *) + +val minus_one : int64 +(** The 64-bit integer -1. *) + +external neg : int64 -> int64 = "%int64_neg" +(** Unary negation. *) + +external add : int64 -> int64 -> int64 = "%int64_add" +(** Addition. *) + +external sub : int64 -> int64 -> int64 = "%int64_sub" +(** Subtraction. *) + +external mul : int64 -> int64 -> int64 = "%int64_mul" +(** Multiplication. *) + +external div : int64 -> int64 -> int64 = "%int64_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Stdlib.(/)}. *) + +external rem : int64 -> int64 -> int64 = "%int64_mod" +(** Integer remainder. If [y] is not zero, the result + of [Int64.rem x y] satisfies the following property: + [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. + If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) + +val succ : int64 -> int64 +(** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) + +val pred : int64 -> int64 +(** Predecessor. [Int64.pred x] is [Int64.sub x Int64.one]. *) + +val abs : int64 -> int64 +(** Return the absolute value of its argument. *) + +val max_int : int64 +(** The greatest representable 64-bit integer, 2{^63} - 1. *) + +val min_int : int64 +(** The smallest representable 64-bit integer, -2{^63}. *) + +external logand : int64 -> int64 -> int64 = "%int64_and" +(** Bitwise logical and. *) + +external logor : int64 -> int64 -> int64 = "%int64_or" +(** Bitwise logical or. *) + +external logxor : int64 -> int64 -> int64 = "%int64_xor" +(** Bitwise logical exclusive or. *) + +val lognot : int64 -> int64 +(** Bitwise logical negation. *) + +external shift_left : int64 -> int -> int64 = "%int64_lsl" +(** [Int64.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external shift_right : int64 -> int -> int64 = "%int64_asr" +(** [Int64.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" +(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external of_int : int -> int64 = "%int64_of_int" +(** Convert the given integer (type [int]) to a 64-bit integer + (type [int64]). *) + +external to_int : int64 -> int = "%int64_to_int" +(** Convert the given 64-bit integer (type [int64]) to an + integer (type [int]). On 64-bit platforms, the 64-bit integer + is taken modulo 2{^63}, i.e. the high-order bit is lost + during the conversion. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^31}, i.e. the top 33 bits are lost + during the conversion. *) + +external of_int32 : int32 -> int64 = "%int64_of_int32" +(** Convert the given 32-bit integer (type [int32]) + to a 64-bit integer (type [int64]). *) + +external to_int32 : int64 -> int32 = "%int64_to_int32" +(** Convert the given 64-bit integer (type [int64]) to a + 32-bit integer (type [int32]). The 64-bit integer + is taken modulo 2{^32}, i.e. the top 32 bits are lost + during the conversion. *) + +val of_string_opt: string -> int64 option +(** Same as [of_string], but return [None] instead of raising. + @since 4.05 *) + +val to_string : int64 -> string +(** Return the string representation of its argument, in decimal. *) + +type t = int64 +(** An alias for the type of 64-bit integers. *) + +val compare: t -> t -> int +(** The comparison function for 64-bit integers, with the same specification as + {!Stdlib.compare}. Along with the type [t], this function [compare] + allows the module [Int64] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equal function for int64s. + @since 4.03.0 *) diff --git a/src/lib_protocol_environment/sigs/v5/json.mli b/src/lib_protocol_environment/sigs/v5/json.mli new file mode 100644 index 000000000000..5af3ac389f4f --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/json.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** In memory JSON data *) +type json = + [ `O of (string * json) list + | `Bool of bool + | `Float of float + | `A of json list + | `Null + | `String of string ] + +(** Read a JSON document from a string. *) +val from_string : string -> (json, string) result + +(** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) +val to_string : json -> string + +(** Helpers for [Data_encoding] *) +val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a + +val wrap_error : ('a -> 'b) -> 'a -> 'b diff --git a/src/lib_protocol_environment/sigs/v5/list.mli b/src/lib_protocol_environment/sigs/v5/list.mli new file mode 100644 index 000000000000..d61fe10776ba --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/list.mli @@ -0,0 +1,938 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 List} + + A replacement for {!Stdlib.List} which: + - replaces the exception-raising functions by exception-safe variants, + - provides Lwt-, result- and Lwt-result-aware traversors. + + [List] is intended to shadow both {!Stdlib.List} and {!Lwt_list}. *) + +(** {2 Basics} + + Checkout {!Lwtreslib} for an introduction to the naming and semantic + convention of Lwtreslib. In a nutshell: + - Stdlib functions that raise exceptions are replaced by safe variants + (typically returning [option]). + - The [_e] suffix is for result-aware traversors ("e" stands for "error"), + [_s] and [_p] are for Lwt-aware, and [_es] and [_ep] are for + Lwt-result-aware. + - [_e], [_s], and [_es] traversors are {i fail-early}: they stop traversal + as soon as a failure ([Error] or [Fail]) occurs; [_p] and [_ep] + traversors are {i best-effort}: they only resolve once all of the + intermediate promises have, even if a failure occurs. *) + +(** {2 Double-traversal and combine} + + Note that double-list traversors ([iter2], [map2], etc., and also [combine]) + take an additional [when_different_lengths] parameter. This is to control + the error that is returned when the two lists passed as arguments have + different lengths. + + This mechanism is a replacement for {!Stdlib.List.iter2} (etc.) raising + [Invalid_argument]. + + Note that, as per the fail-early behaviour mentioned above, [_e], [_s], and + [_es] traversors will have already processed the common-prefix before the + error is returned. + + Because the best-effort behaviour of [_p] and [_ep] is unsatisfying for this + failure case, double parallel traversors are omitted from this library. + (Specifically, it is not obvious whether nor how the + [when_different_lengths] error should be composed with the other errors.) + + To obtain a different behaviour for sequential traversors, or to process + two lists in parallel, you can use {!combine} or any of the alternatives + that handles the error differently: {!combine_drop}, + {!combine_with_leftovers}. Finally, the {!rev_combine} is provided to allow + to avoid multiple-reversing. + + {3 Special considerations} + + Because they traverse the list from right-to-left, the {!fold_right2} + function and all its variants fail with [when_different_lengths] before any + of the processing starts. Whilst this is still within the fail-early + behaviour, it may be surprising enough that it requires mentioning here. + + Because they may return early, {!for_all2} and {!exists2} and all their + variants may return [Ok _] even though the arguments have different lengths. +*) + +(** {3 Trivial values} *) + +type 'a t = 'a list = [] | ( :: ) of 'a * 'a list + +(** in-monad, preallocated nil *) + +(** [nil] is [[]] *) +val nil : 'a list + +(** [nil_e] is [Ok []] *) +val nil_e : ('a list, 'trace) result + +(** [nil_s] is [Lwt.return_nil] *) +val nil_s : 'a list Lwt.t + +(** [nil_es] is [Lwt.return (Ok [])] *) +val nil_es : ('a list, 'trace) result Lwt.t + +(** {3 Safe wrappers} + + Shadowing unsafe functions to avoid all exceptions. *) + +(** {4 Safe lookups, scans, retrievals} + + Return option rather than raise [Not_found], [Failure _], or + [Invalid_argument _] *) + +(** [hd xs] is the head (first element) of the list or [None] if the list is + empty. *) +val hd : 'a list -> 'a option + +(** [tl xs] is the tail of the list (the whole list except the first element) + or [None] if the list is empty. *) +val tl : 'a list -> 'a list option + +(** [nth xs n] is the [n]th element of the list or [None] if the list has + fewer than [n] elements. + + [nth xs 0 = hd xs] *) +val nth : 'a list -> int -> 'a option + +(** [nth_opt] is an alias for [nth] provided for backwards compatibility. *) +val nth_opt : 'a list -> int -> 'a option + +(** [last x xs] is the last element of the list [xs] or [x] if [xs] is empty. + + The primary intended use for [last] is after destructing a list: + [match l with | None -> … | Some x :: xs -> last x xs] + but it can also be used for a default value: + [last default_value_if_empty xs]. *) +val last : 'a -> 'a list -> 'a + +(** [last_opt xs] is the last element of the list [xs] or [None] if the list + [xs] is empty. *) +val last_opt : 'a list -> 'a option + +(** [find predicate xs] is the first element [x] of the list [xs] such that + [predicate x] is [true] or [None] if the list [xs] has no such element. *) +val find : ('a -> bool) -> 'a list -> 'a option + +(** [find_opt] is an alias for [find] provided for backwards compatibility. *) +val find_opt : ('a -> bool) -> 'a list -> 'a option + +(** [mem ~equal a l] is [true] iff there is an element [e] of [l] such that + [equal a e]. *) +val mem : equal:('a -> 'a -> bool) -> 'a -> 'a list -> bool + +(** [assoc ~equal k kvs] is [Some v] such that [(k', v)] is the first pair in + the list such that [equal k' k] or [None] if the list contains no such + pair. *) +val assoc : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option + +(** [assoc_opt] is an alias for [assoc] provided for backwards compatibility. *) +val assoc_opt : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option + +(** [assq k kvs] is the same as [assoc ~equal:Stdlib.( == ) k kvs]: it uses + the physical equality. *) +val assq : 'a -> ('a * 'b) list -> 'b option + +(** [assq_opt] is an alias for [assq] provided for backwards compatibility. *) +val assq_opt : 'a -> ('a * 'b) list -> 'b option + +(** [mem_assoc ~equal k l] is equivalent to + [Option.is_some @@ assoc ~equal k l]. *) +val mem_assoc : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> bool + +(** [mem_assq k l] is [mem_assoc ~equal:Stdlib.( == ) k l]. *) +val mem_assq : 'a -> ('a * 'b) list -> bool + +(** [remove_assoc ~equal k l] is [l] without the first element [(k', _)] such + that [equal k k']. *) +val remove_assoc : + equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> ('a * 'b) list + +(** [remove_assoq k l] is [remove_assoc ~equal:Stdlib.( == ) k l]. *) +val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + +(** {4 Initialisation} *) + +(** [init ~when_negative_length n f] is [Error when_negative_length] if [n] is + strictly negative and [Ok (Stdlib.List.init n f)] otherwise. *) +val init : + when_negative_length:'trace -> + int -> + (int -> 'a) -> + ('a list, 'trace) result + +(** {4 Basic traversal} *) + +val length : 'a list -> int + +val rev : 'a list -> 'a list + +val concat : 'a list list -> 'a list + +val append : 'a list -> 'a list -> 'a list + +val rev_append : 'a list -> 'a list -> 'a list + +val flatten : 'a list list -> 'a list + +(** {4 Double-list traversals} + + These safe-wrappers take an explicit value to handle the case of lists of + unequal length. +*) + +(** [combine ~when_different_lengths l1 l2] is either + - [Error when_different_lengths] if [List.length l1 <> List.length l2] + - a list of pairs of elements from [l1] and [l2] + + E.g., [combine ~when_different_lengths [] [] = Ok []] + + E.g., [combine ~when_different_lengths [1; 2] ['a'; 'b'] = Ok [(1,'a'); (2, 'b')]] + + E.g., [combine ~when_different_lengths:() [1] [] = Error ()] + + Note: [combine ~when_different_lengths l1 l2] is equivalent to + [try Ok (Stdlib.List.combine l1 l2) + with Invalid_argument _ -> when_different_lengths] + + The same equivalence almost holds for the other double traversors below. + The notable difference is if the functions passed as argument to the + traversors raise the [Invalid_argument _] exception. *) +val combine : + when_different_lengths:'trace -> + 'a list -> + 'b list -> + (('a * 'b) list, 'trace) result + +(** [rev_combine ~when_different_lengths xs ys] is + [rev (combine ~when_different_lengths xs ys)] but more efficient. *) +val rev_combine : + when_different_lengths:'trace -> + 'a list -> + 'b list -> + (('a * 'b) list, 'trace) result + +val split : ('a * 'b) list -> 'a list * 'b list + +val iter2 : + when_different_lengths:'trace -> + ('a -> 'b -> unit) -> + 'a list -> + 'b list -> + (unit, 'trace) result + +val map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + +val rev_map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + +val fold_left2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result + +(** This function is not tail-recursive *) +val fold_right2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result + +(** [fold_left_map f a xs] is a combination of [fold_left] and [map] that maps + over all elements of [xs] and threads an accumulator with initial value [a] + through calls to [f]. *) +val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + +val for_all2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a list -> + 'b list -> + (bool, 'trace) result + +val exists2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a list -> + 'b list -> + (bool, 'trace) result + +(** {3 Monad-aware variants} + + The functions below are strict extensions of the standard {!Stdlib.List} + module. It is for result-, lwt- and lwt-result-aware variants. The meaning + of the suffix is as described above, in {!Lwtreslib}, and in {!Sigs.Seq}. *) + +(** {4 Initialisation variants} + + Note that for asynchronous variants ([_s], [_es], [_p], and [_ep]), if the + length parameter is negative, then the promise is returned already + fulfilled with [Error when_different_lengths]. *) + +val init_e : + when_negative_length:'trace -> + int -> + (int -> ('a, 'trace) result) -> + ('a list, 'trace) result + +val init_s : + when_negative_length:'trace -> + int -> + (int -> 'a Lwt.t) -> + ('a list, 'trace) result Lwt.t + +val init_es : + when_negative_length:'trace -> + int -> + (int -> ('a, 'trace) result Lwt.t) -> + ('a list, 'trace) result Lwt.t + +val init_p : + when_negative_length:'trace -> + int -> + (int -> 'a Lwt.t) -> + ('a list, 'trace) result Lwt.t + +(** {4 Query variants} *) + +val find_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a option, 'trace) result + +val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a option Lwt.t + +val find_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a option, 'trace) result Lwt.t + +val filter : ('a -> bool) -> 'a list -> 'a list + +(** [rev_filter f l] is [rev (filter f l)] but more efficient. *) +val rev_filter : ('a -> bool) -> 'a list -> 'a list + +val rev_filter_some : 'a option list -> 'a list + +val filter_some : 'a option list -> 'a list + +val rev_filter_ok : ('a, 'b) result list -> 'a list + +val filter_ok : ('a, 'b) result list -> 'a list + +val rev_filter_error : ('a, 'b) result list -> 'b list + +val filter_error : ('a, 'b) result list -> 'b list + +val rev_filter_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result + +val filter_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result + +val rev_filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + +val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + +val rev_filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t + +val filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t + +val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + +val rev_partition : ('a -> bool) -> 'a list -> 'a list * 'a list + +val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + +val rev_partition_result : ('a, 'b) result list -> 'a list * 'b list + +val partition_result : ('a, 'b) result list -> 'a list * 'b list + +val rev_partition_e : + ('a -> (bool, 'trace) result) -> + 'a list -> + ('a list * 'a list, 'trace) result + +val partition_e : + ('a -> (bool, 'trace) result) -> + 'a list -> + ('a list * 'a list, 'trace) result + +val rev_partition_s : + ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + +val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + +val rev_partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'trace) result Lwt.t + +val partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'trace) result Lwt.t + +val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + +(** {4 Traversal variants} *) +val iter : ('a -> unit) -> 'a list -> unit + +val iter_e : ('a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result + +val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val iter_es : + ('a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t + +val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val iteri : (int -> 'a -> unit) -> 'a list -> unit + +val iteri_e : + (int -> 'a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result + +val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val iteri_es : + (int -> 'a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t + +val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val map : ('a -> 'b) -> 'a list -> 'b list + +val map_e : ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + +val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + +val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + +val mapi_e : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + +val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val mapi_es : + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + +val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_map : ('a -> 'b) -> 'a list -> 'b list + +val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + +val rev_map_e : + ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + +val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + +val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_mapi_e : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + +val rev_mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_mapi_es : + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + +val rev_mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_filter_map : ('a -> 'b option) -> 'a list -> 'b list + +val rev_filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a list -> ('b list, 'trace) result + +val filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a list -> ('b list, 'trace) result + +val rev_filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + +val filter_map : ('a -> 'b option) -> 'a list -> 'b list + +val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + +val filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + +val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + +val concat_map : ('a -> 'b list) -> 'a list -> 'b list + +val concat_map_s : ('a -> 'b list Lwt.t) -> 'a list -> 'b list Lwt.t + +val concat_map_e : + ('a -> ('b list, 'error) result) -> 'a list -> ('b list, 'error) result + +val concat_map_es : + ('a -> ('b list, 'error) result Lwt.t) -> + 'a list -> + ('b list, 'error) result Lwt.t + +val concat_map_p : ('a -> 'b list Lwt.t) -> 'a list -> 'b list Lwt.t + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + +val fold_left_e : + ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b list -> ('a, 'trace) result + +val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + +val fold_left_es : + ('a -> 'b -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + ('a, 'trace) result Lwt.t + +(** [fold_left_map_e f a xs] is a combination of [fold_left_e] and [map_e] that + maps over all elements of [xs] and threads an accumulator with initial + value [a] through calls to [f]. The list is traversed from left to right + and the first encountered error is returned. *) +val fold_left_map_e : + ('a -> 'b -> ('a * 'c, 'trace) result) -> + 'a -> + 'b list -> + ('a * 'c list, 'trace) result + +(** [fold_left_map_s f a xs] is a combination of [fold_left_s] and [map_s] that + maps over all elements of [xs] and threads an accumulator with initial + value [a] through calls to [f]. *) +val fold_left_map_s : + ('a -> 'b -> ('a * 'c) Lwt.t) -> 'a -> 'b list -> ('a * 'c list) Lwt.t + +(** [fold_left_map_es f a xs] is a combination of [fold_left_es] and [map_es] that + maps over all elements of [xs] and threads an accumulator with initial + value [a] through calls to [f]. The list is traversed from left to right + and the first encountered error is returned. *) +val fold_left_map_es : + ('a -> 'b -> ('a * 'c, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + ('a * 'c list, 'trace) result Lwt.t + +val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a + +val fold_left_i_e : + (int -> 'a -> 'b -> ('a, 'trace) result) -> + 'a -> + 'b list -> + ('a, 'trace) result + +val fold_left_i_s : (int -> 'a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + +val fold_left_i_es : + (int -> 'a -> 'b -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + ('a, 'trace) result Lwt.t + +(** This function is not tail-recursive *) +val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + +(** This function is not tail-recursive *) +val fold_right_e : + ('a -> 'b -> ('b, 'trace) result) -> 'a list -> 'b -> ('b, 'trace) result + +(** This function is not tail-recursive *) +val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t + +(** This function is not tail-recursive *) +val fold_right_es : + ('a -> 'b -> ('b, 'trace) result Lwt.t) -> + 'a list -> + 'b -> + ('b, 'trace) result Lwt.t + +(** {4 Double-traversal variants} + + As mentioned above, there are no [_p] and [_ep] double-traversors. Use + {!combine} (and variants) to circumvent this. *) + +val iter2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result) -> + 'a list -> + 'b list -> + (unit, 'trace) result + +val iter2_s : + when_different_lengths:'trace -> + ('a -> 'b -> unit Lwt.t) -> + 'a list -> + 'b list -> + (unit, 'trace) result Lwt.t + +val iter2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (unit, 'trace) result Lwt.t + +val map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + +val map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + +val map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + +val rev_map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + +val rev_map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + +val rev_map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + +val fold_left2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result + +val fold_left2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result Lwt.t + +val fold_left2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result Lwt.t + +(** This function is not tail-recursive *) +val fold_right2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result + +(** This function is not tail-recursive *) +val fold_right2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c Lwt.t) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result Lwt.t + +(** This function is not tail-recursive *) +val fold_right2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result Lwt.t + +(** {4 Scanning variants} *) + +val for_all : ('a -> bool) -> 'a list -> bool + +val for_all_e : + ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result + +val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +val for_all_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + (bool, 'trace) result Lwt.t + +val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +val exists : ('a -> bool) -> 'a list -> bool + +val exists_e : + ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result + +val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +val exists_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + (bool, 'trace) result Lwt.t + +val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +(** {4 Double-scanning variants} + + As mentioned above, there are no [_p] and [_ep] double-scanners. Use + {!combine} (and variants) to circumvent this. *) + +val for_all2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a list -> + 'b list -> + (bool, 'trace) result + +val for_all2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + +val for_all2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + +val exists2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a list -> + 'b list -> + (bool, 'trace) result + +val exists2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + +val exists2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + +(** {3 Combine variants} + + These are primarily intended to be used for preprocessing before applying + a traversor to the resulting list of pairs. They give alternatives to the + [when_different_lengths] mechanism of the immediate double-traversors + above. + + In case the semantic of, say, [map2_es] was unsatisfying, one can use + [map_es] on a [combine]-preprocessed pair of lists. The different variants + of [combine] give different approaches to different-length handling. *) + +(** [combine_drop ll lr] is a list [l] of pairs of elements taken from the + common-length prefix of [ll] and [lr]. The suffix of whichever list is + longer (if any) is dropped. + + More formally [nth l n] is: + - [None] if [n >= min (length ll) (length lr)] + - [Some (Option.get @@ nth ll n, Option.get @@ nth lr n)] otherwise + *) +val combine_drop : 'a list -> 'b list -> ('a * 'b) list + +(** A type like [result] but which is symmetric *) +type ('a, 'b) left_or_right_list = [`Left of 'a list | `Right of 'b list] + +(** [combine_with_leftovers ll lr] is a tuple [(combined, leftover)] + where [combined] is [combine_drop ll lr] + and [leftover] is either [`Left lsuffix] or [`Right rsuffix] depending on + which of [ll] or [lr] is longer. [leftover] is [None] if the two lists + have the same length. *) +val combine_with_leftovers : + 'a list -> + 'b list -> + ('a * 'b) list * ('a, 'b) left_or_right_list option + +(** {3 compare / equal} *) + +val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int + +val compare_lengths : 'a list -> 'b list -> int + +val compare_length_with : 'a list -> int -> int + +val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool + +(** {3 Sorting} *) + +val sort : ('a -> 'a -> int) -> 'a list -> 'a list + +val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + +val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + +val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list + +(** {3 conversion} *) + +val to_seq : 'a list -> 'a Seq.t + +val of_seq : 'a Seq.t -> 'a list + +val init_ep : + when_negative_length:'error -> + int -> + (int -> ('a, 'error Error_monad.trace) result Lwt.t) -> + ('a list, 'error Error_monad.trace) result Lwt.t + +val filter_ep : + ('a -> (bool, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('a list, 'error Error_monad.trace) result Lwt.t + +val partition_ep : + ('a -> (bool, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'error Error_monad.trace) result Lwt.t + +val iter_ep : + ('a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + (unit, 'error Error_monad.trace) result Lwt.t + +val iteri_ep : + (int -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + (unit, 'error Error_monad.trace) result Lwt.t + +val map_ep : + ('a -> ('b, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('b list, 'error Error_monad.trace) result Lwt.t + +val mapi_ep : + (int -> 'a -> ('b, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('b list, 'error Error_monad.trace) result Lwt.t + +val rev_map_ep : + ('a -> ('b, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('b list, 'error Error_monad.trace) result Lwt.t + +val rev_mapi_ep : + (int -> 'a -> ('b, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('b list, 'error Error_monad.trace) result Lwt.t + +val filter_map_ep : + ('a -> ('b option, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + ('b list, 'error Error_monad.trace) result Lwt.t + +val concat_map_ep : + ('a -> ('b list, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + +val for_all_ep : + ('a -> (bool, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + (bool, 'error Error_monad.trace) result Lwt.t + +val exists_ep : + ('a -> (bool, 'error Error_monad.trace) result Lwt.t) -> + 'a list -> + (bool, 'error Error_monad.trace) result Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/logging.mli b/src/lib_protocol_environment/sigs/v5/logging.mli new file mode 100644 index 000000000000..36aff78bda73 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/logging.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Logging levels. See [docs/developer/guidelines.rst] for their meaning *) +type level = Debug | Info | Notice | Warning | Error | Fatal + +(** Logs a message. It is the shell's responsibility to manage the actual + logging. + + Even though logging may involve system calls, formatting, or other work, the + shell guarantees that calling this function doesn't transfer control over + another promise. Consequently, the performance of this function can be + considered predictable from the point of view of gas-consumption. + + Note that the function call has predictable performance, but that it is the + caller's responsibility to ensure that argument evaluation has predictable + performance too. E.g., [log Notice "%s" (Format.asprint …)] may spend time + formatting the argument string. *) +val log : level -> ('a, Format.formatter, unit, unit) format4 -> 'a + +(** Same as [log] but more efficient with a simpler interface. *) +val log_string : level -> string -> unit diff --git a/src/lib_protocol_environment/sigs/v5/lwt.mli b/src/lib_protocol_environment/sigs/v5/lwt.mli new file mode 100644 index 000000000000..5361fc293adc --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/lwt.mli @@ -0,0 +1,265 @@ +(* This file is part of Lwt, released under the MIT license. See LICENSE.md for + details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) + + +(** {2 Fundamentals} *) + +(** {3 Promises} *) + +type +'a t +(** Promises for values of type ['a]. + + A {b promise} is a memory cell that is always in one of three {b states}: + + - {e fulfilled}, and containing one value of type ['a], + - {e rejected}, and containing one exception, or + - {e pending}, in which case it may become fulfilled or rejected later. + + A {e resolved} promise is one that is either fulfilled or rejected, i.e. not + pending. Once a promise is resolved, its content cannot change. So, promises + are {e write-once references}. The only possible state changes are (1) from + pending to fulfilled and (2) from pending to rejected. + + Promises are typically “read” by attaching {b callbacks} to them. The most + basic functions for that are {!Lwt.bind}, which attaches a callback that is + called when a promise becomes fulfilled, and {!Lwt.catch}, for rejection. + + Promise variables of this type, ['a Lwt.t], are actually {b read-only} in + Lwt. Separate {e resolvers} of type ['a ]{!Lwt.u} are used to write to them. + Promises and their resolvers are created together by calling {!Lwt.wait}. + There is one exception to this: most promises can be {e canceled} by calling + {!Lwt.cancel}, without going through a resolver. *) + +val return : 'a -> 'a t +(** [Lwt.return v] creates a new {{: #TYPEt} promise} that is {e already + fulfilled} with value [v]. + + This is needed to satisfy the type system in some cases. For example, in a + [match] expression where one case evaluates to a promise, the other cases + have to evaluate to promises as well: + +{[ +match need_input with +| true -> Lwt_io.(read_line stdin) (* Has type string Lwt.t... *) +| false -> Lwt.return "" (* ...so wrap empty string in a promise. *) +]} + + Another typical usage is in {{: #VALbind} [let%lwt]}. The expression after + the “[in]” has to evaluate to a promise. So, if you compute an ordinary + value instead, you have to wrap it: + +{[ +let%lwt line = Lwt_io.(read_line stdin) in +Lwt.return (line ^ ".") +]} *) + + +(** {3 Callbacks} *) + +val bind : 'a t -> ('a -> 'b t) -> 'b t +(** [Lwt.bind p_1 f] makes it so that [f] will run when [p_1] is {{: #TYPEt} + {e fulfilled}}. + + When [p_1] is fulfilled with value [v_1], the callback [f] is called with + that same value [v_1]. Eventually, after perhaps starting some I/O or other + computation, [f] returns promise [p_2]. + + [Lwt.bind] itself returns immediately. It only attaches the callback [f] to + [p_1] – it does not wait for [p_2]. {e What} [Lwt.bind] returns is yet a + third promise, [p_3]. Roughly speaking, fulfillment of [p_3] represents both + [p_1] and [p_2] becoming fulfilled, one after the other. + + A minimal example of this is an echo program: + +{[ +let () = + let p_3 = + Lwt.bind + Lwt_io.(read_line stdin) + (fun line -> Lwt_io.printl line) + in + Lwt_main.run p_3 + +(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) +]} + + Rejection of [p_1] and [p_2], and raising an exception in [f], are all + forwarded to rejection of [p_3]. + + {b Precise behavior} + + [Lwt.bind] returns a promise [p_3] immediately. [p_3] starts out pending, + and is resolved as follows: + + - The first condition to wait for is that [p_1] becomes resolved. It does + not matter whether [p_1] is already resolved when [Lwt.bind] is called, or + becomes resolved later – the rest of the behavior is the same. + - If and when [p_1] becomes resolved, it will, by definition, be either + fulfilled or rejected. + - If [p_1] is rejected, [p_3] is rejected with the same exception. + - If [p_1] is fulfilled, with value [v], [f] is applied to [v]. + - [f] may finish by returning the promise [p_2], or raising an exception. + - If [f] raises an exception, [p_3] is rejected with that exception. + - Finally, the remaining case is when [f] returns [p_2]. From that point on, + [p_3] is effectively made into a reference to [p_2]. This means they have + the same state, undergo the same state changes, and performing any + operation on one is equivalent to performing it on the other. + + {b Syntactic sugar} + + [Lwt.bind] is almost never written directly, because sequences of [Lwt.bind] + result in growing indentation and many parentheses: + +{[ +let () = + Lwt_main.run begin + Lwt.bind Lwt_io.(read_line stdin) (fun line -> + Lwt.bind (Lwt_unix.sleep 1.) (fun () -> + Lwt_io.printf "One second ago, you entered %s\n" line)) + end + +(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) +]} + + The recommended way to write [Lwt.bind] is using the [let%lwt] syntactic + sugar: + +{[ +let () = + Lwt_main.run begin + let%lwt line = Lwt_io.(read_line stdin) in + let%lwt () = Lwt_unix.sleep 1. in + Lwt_io.printf "One second ago, you entered %s\n" line + end + +(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) +]} + + This uses the Lwt {{: Ppx_lwt.html} PPX} (preprocessor). Note that we had to + add package [lwt_ppx] to the command line for building this program. We will + do that throughout this manual. + + Another way to write [Lwt.bind], that you may encounter while reading code, + is with the [>>=] operator: + +{[ +open Lwt.Infix + +let () = + Lwt_main.run begin + Lwt_io.(read_line stdin) >>= fun line -> + Lwt_unix.sleep 1. >>= fun () -> + Lwt_io.printf "One second ago, you entered %s\n" line + end + +(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) +]} + + The [>>=] operator comes from the module {!Lwt.Infix}, which is why we + opened it at the beginning of the program. + + See also {!Lwt.map}. *) + + + +(** {2 Convenience} *) + +(** {3 Callback helpers} *) + +val map : ('a -> 'b) -> 'a t -> 'b t +(** [Lwt.map f p_1] is similar to {!Lwt.bind}[ p_1 f], but [f] is not expected + to return a promise. + + This function is more convenient that {!Lwt.bind} when [f] inherently does + not return a promise. An example is [Stdlib.int_of_string]: + +{[ +let read_int : unit -> int Lwt.t = fun () -> + Lwt.map + int_of_string + Lwt_io.(read_line stdin) + +let () = + Lwt_main.run begin + let%lwt number = read_int () in + Lwt_io.printf "%i\n" number + end + +(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) +]} + + By comparison, the {!Lwt.bind} version is more awkward: + +{[ +let read_int : unit -> int Lwt.t = fun () -> + Lwt.bind + Lwt_io.(read_line stdin) + (fun line -> Lwt.return (int_of_string line)) +]} + + As with {!Lwt.bind}, sequences of calls to [Lwt.map] result in excessive + indentation and parentheses. The recommended syntactic sugar for avoiding + this is the {{: #VAL(>|=)} [>|=]} operator, which comes from module + [Lwt.Infix]: + +{[ +open Lwt.Infix + +let read_int : unit -> int Lwt.t = fun () -> + Lwt_io.(read_line stdin) >|= int_of_string +]} + + The detailed operation follows. For consistency with the promises in + {!Lwt.bind}, the {e two} promises involved are named [p_1] and [p_3]: + + - [p_1] is the promise passed to [Lwt.map]. + - [p_3] is the promise returned by [Lwt.map]. + + [Lwt.map] returns a promise [p_3]. [p_3] starts out pending. It is resolved + as follows: + + - [p_1] may be, or become, resolved. In that case, by definition, it will + become fulfilled or rejected. Fulfillment is the interesting case, but the + behavior on rejection is simpler, so we focus on rejection first. + - When [p_1] becomes rejected, [p_3] is rejected with the same exception. + - When [p_1] instead becomes fulfilled, call the value it is fulfilled with + [v]. + - [f v] is applied. If this finishes, it may either return another value, or + raise an exception. + - If [f v] returns another value [v'], [p_3] is fulfilled with [v']. + - If [f v] raises exception [exn], [p_3] is rejected with [exn]. *) + + +(** {3 Pre-allocated promises} *) + +val return_unit : unit t +(** [Lwt.return_unit] is defined as {!Lwt.return}[ ()], but this definition is + evaluated only once, during initialization of module [Lwt], at the beginning + of your program. + + This means the promise is allocated only once. By contrast, each time + {!Lwt.return}[ ()] is evaluated, it allocates a new promise. + + It is recommended to use [Lwt.return_unit] only where you know the + allocations caused by an instance of {!Lwt.return}[ ()] are a performance + bottleneck. Generally, the cost of I/O tends to dominate the cost of + {!Lwt.return}[ ()] anyway. + + In future Lwt, we hope to perform this optimization, of using a single, + pre-allocated promise, automatically, wherever {!Lwt.return}[ ()] is + written. *) + +val return_none : (_ option) t +(** [Lwt.return_none] is like {!Lwt.return_unit}, but for + {!Lwt.return}[ None]. *) + +val return_nil : (_ list) t +(** [Lwt.return_nil] is like {!Lwt.return_unit}, but for {!Lwt.return}[ []]. *) + +val return_true : bool t +(** [Lwt.return_true] is like {!Lwt.return_unit}, but for + {!Lwt.return}[ true]. *) + +val return_false : bool t +(** [Lwt.return_false] is like {!Lwt.return_unit}, but for + {!Lwt.return}[ false]. *) diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli new file mode 100644 index 000000000000..8a6371e35962 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/map.mli @@ -0,0 +1,152 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* From Lwtreslib *) + +module type S = sig + + type key + + type +!'a t + + (**/**) + module Legacy : Stdlib.Map.S with type key = key and type 'a t = 'a t + (**/**) + + val empty : 'a t + + val is_empty : 'a t -> bool + + val mem : key -> 'a t -> bool + + val add : key -> 'a -> 'a t -> 'a t + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + + val singleton : key -> 'a -> 'a t + + val remove : key -> 'a t -> 'a t + + val merge : + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + + val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + (** [iter_e f m] applies [f] to the bindings of [m] one by one in an + unspecified order. If all the applications result in [Ok ()], then the + result of the iteration is [Ok ()]. If any of the applications results in + [Error e] then the iteration stops and the result of the iteration is + [Error e]. *) + val iter_e : + (key -> 'a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result + + val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + (** [iter_es f m] applies [f] to the bindings of [m] in an unspecified order, + one after the other as the promises resolve. If all the applications + result in [Ok ()], then the result of the iteration is [Ok ()]. If any of + the applications results in [Error e] then the iteration stops and the + result of the iteration is [Error e]. *) + val iter_es : + (key -> 'a -> (unit, 'trace) result Lwt.t) -> + 'a t -> + (unit, 'trace) result Lwt.t + + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + (** [fold_e f m init] is + [f k1 d1 init >>? fun acc -> f k2 d2 acc >>? fun acc -> …] where [kN] is + the key bound to [dN] in [m]. *) + val fold_e : + (key -> 'a -> 'b -> ('b, 'trace) result) -> + 'a t -> + 'b -> + ('b, 'trace) result + + val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t + + (** [fold_es f m init] is + [f k1 d1 init >>=? fun acc -> f k2 d2 acc >>=? fun acc -> …] where [kN] is + the key bound to [dN] in [m]. *) + val fold_es : + (key -> 'a -> 'b -> ('b, 'trace) result Lwt.t) -> + 'a t -> + 'b -> + ('b, 'trace) result Lwt.t + + val for_all : (key -> 'a -> bool) -> 'a t -> bool + + val exists : (key -> 'a -> bool) -> 'a t -> bool + + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + + val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + + val cardinal : 'a t -> int + + val bindings : 'a t -> (key * 'a) list + + val min_binding : 'a t -> (key * 'a) option + + val max_binding : 'a t -> (key * 'a) option + + val choose : 'a t -> (key * 'a) option + + val split : key -> 'a t -> 'a t * 'a option * 'a t + + val find : key -> 'a t -> 'a option + + val find_first : (key -> bool) -> 'a t -> (key * 'a) option + + val find_last : (key -> bool) -> 'a t -> (key * 'a) option + + val map : ('a -> 'b) -> 'a t -> 'b t + + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + + val to_seq : 'a t -> (key * 'a) Seq.t + + val to_seq_from : key -> 'a t -> (key * 'a) Seq.t + + val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t + + val of_seq : (key * 'a) Seq.t -> 'a t + + val iter_ep : + (key -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + 'a t -> + (unit, 'error Error_monad.trace) result Lwt.t + +end + +module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t diff --git a/src/lib_protocol_environment/sigs/v5/micheline.mli b/src/lib_protocol_environment/sigs/v5/micheline.mli new file mode 100644 index 000000000000..29f9ef5c47a8 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/micheline.mli @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type annot = string list + +type ('l, 'p) node = + | Int of 'l * Z.t + | String of 'l * string + | Bytes of 'l * bytes + | Prim of 'l * 'p * ('l, 'p) node list * annot + | Seq of 'l * ('l, 'p) node list + +type 'p canonical + +type canonical_location + +val dummy_location : canonical_location + +val root : 'p canonical -> (canonical_location, 'p) node + +val canonical_location_encoding : canonical_location Data_encoding.encoding + +val canonical_encoding : + variant:string -> + 'l Data_encoding.encoding -> + 'l canonical Data_encoding.encoding + +val location : ('l, 'p) node -> 'l + +val annotations : ('l, 'p) node -> string list + +val strip_locations : (_, 'p) node -> 'p canonical diff --git a/src/lib_protocol_environment/sigs/v5/operation.mli b/src/lib_protocol_environment/sigs/v5/operation.mli new file mode 100644 index 000000000000..f87670b4b149 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/operation.mli @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos operations. *) + +type shell_header = { + branch : Block_hash.t; + (** The operation is only valid in a branch containing the + block [branch]. *) +} + +val shell_header_encoding : shell_header Data_encoding.t + +type t = {shell : shell_header; proto : bytes} + +include S.HASHABLE with type t := t and type hash := Operation_hash.t diff --git a/src/lib_protocol_environment/sigs/v5/operation_hash.mli b/src/lib_protocol_environment/sigs/v5/operation_hash.mli new file mode 100644 index 000000000000..15967e9d742e --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/operation_hash.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Operations hashes / IDs. *) +include S.HASH diff --git a/src/lib_protocol_environment/sigs/v5/operation_list_hash.mli b/src/lib_protocol_environment/sigs/v5/operation_list_hash.mli new file mode 100644 index 000000000000..f5c95720ae37 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/operation_list_hash.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Blocks hashes / IDs. *) +include S.MERKLE_TREE with type elt = Operation_hash.t diff --git a/src/lib_protocol_environment/sigs/v5/operation_list_list_hash.mli b/src/lib_protocol_environment/sigs/v5/operation_list_list_hash.mli new file mode 100644 index 000000000000..949a197839ea --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/operation_list_list_hash.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Blocks hashes / IDs. *) +include S.MERKLE_TREE with type elt = Operation_list_hash.t diff --git a/src/lib_protocol_environment/sigs/v5/option.mli b/src/lib_protocol_environment/sigs/v5/option.mli new file mode 100644 index 000000000000..a86b7946caaa --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/option.mli @@ -0,0 +1,142 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Signature from Lwtreslib's option module *) + +type 'a t = 'a option = None | Some of 'a + +val none : 'a option + +val none_e : ('a option, 'trace) result + +val none_s : 'a option Lwt.t + +val none_es : ('a option, 'trace) result Lwt.t + +val some : 'a -> 'a option + +val some_unit : unit option + +val some_nil : 'a list option + +val some_e : 'a -> ('a option, 'trace) result + +val some_s : 'a -> 'a option Lwt.t + +val some_es : 'a -> ('a option, 'trace) result Lwt.t + +val value : 'a option -> default:'a -> 'a + +val value_e : 'a option -> error:'trace -> ('a, 'trace) result + +val value_f : 'a option -> default:(unit -> 'a) -> 'a + +val value_fe : 'a option -> error:(unit -> 'trace) -> ('a, 'trace) result + +val bind : 'a option -> ('a -> 'b option) -> 'b option + +val join : 'a option option -> 'a option + +val either : 'a option -> 'a option -> 'a option + +val map : ('a -> 'b) -> 'a option -> 'b option + +val map_s : ('a -> 'b Lwt.t) -> 'a option -> 'b option Lwt.t + +val map_e : + ('a -> ('b, 'trace) result) -> 'a option -> ('b option, 'trace) result + +val map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a option -> + ('b option, 'trace) result Lwt.t + +val fold : none:'a -> some:('b -> 'a) -> 'b option -> 'a + +val fold_s : none:'a -> some:('b -> 'a Lwt.t) -> 'b option -> 'a Lwt.t + +val fold_f : none:(unit -> 'a) -> some:('b -> 'a) -> 'b option -> 'a + +val iter : ('a -> unit) -> 'a option -> unit + +val iter_s : ('a -> unit Lwt.t) -> 'a option -> unit Lwt.t + +val iter_e : + ('a -> (unit, 'trace) result) -> 'a option -> (unit, 'trace) result + +val iter_es : + ('a -> (unit, 'trace) result Lwt.t) -> + 'a option -> + (unit, 'trace) result Lwt.t + +val is_none : 'a option -> bool + +val is_some : 'a option -> bool + +val equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool + +val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int + +val to_result : none:'trace -> 'a option -> ('a, 'trace) result + +val of_result : ('a, 'e) result -> 'a option + +val to_list : 'a option -> 'a list + +val to_seq : 'a option -> 'a Seq.t + +(** [catch f] is [Some (f ())] if [f] does not raise an exception, it is + [None] otherwise. + + You should only use [catch] when you truly do not care about + what exception may be raised during the evaluation of [f ()]. If you need + to inspect the raised exception, or if you need to pass it along, consider + {!Result.catch} instead. + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] + is [true] are caught. + + Whether [catch_only] is set or not, you cannot catch non-deterministic + runtime exceptions of OCaml such as {!Stack_overflow} and + {!Out_of_memory} nor system exceptions such as {!Unix.Unix_error}. *) +val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option + +(** [catch_s f] is a promise that resolves to [Some x] if and when [f ()] + resolves to [x]. Alternatively, it resolves to [None] if and when [f ()] + is rejected. + + You should only use [catch_s] when you truly do not care about + what exception may be raised during the evaluation of [f ()]. If you need + to inspect the raised exception, or if you need to pass it along, consider + {!Result.catch_s} instead. + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] + is [true] are caught. + + Whether [catch_only] is set or not, you cannot catch non-deterministic + runtime exceptions of OCaml such as {!Stack_overflow} and + {!Out_of_memory} nor system exceptions such as {!Unix.Unix_error}. *) +val catch_s : + ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/p256.mli b/src/lib_protocol_environment/sigs/v5/p256.mli new file mode 100644 index 000000000000..cc7ded3e5a41 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/p256.mli @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos - P256 cryptography *) + +include S.SIGNATURE with type watermark := bytes diff --git a/src/lib_protocol_environment/sigs/v5/pervasives.mli b/src/lib_protocol_environment/sigs/v5/pervasives.mli new file mode 100644 index 000000000000..f1a8eacdca5d --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/pervasives.mli @@ -0,0 +1,482 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The OCaml Standard library. + + This module is automatically opened at the beginning of each + compilation. All components of this module can therefore be + referred by their short name, without prefixing them by [Stdlib]. + + It particular, it provides the basic operations over the built-in + types (numbers, booleans, byte sequences, strings, exceptions, + references, lists, arrays, input-output channels, ...) and the + {{!modules}standard library modules}. +*) + +(** {1 Exceptions} *) + +external raise : exn -> 'a = "%raise" +(** Raise the given exception value *) + +external raise_notrace : exn -> 'a = "%raise_notrace" +(** A faster version [raise] which does not record the backtrace. + @since 4.02.0 +*) + +val invalid_arg : string -> 'a +(** Raise exception [Invalid_argument] with the given string. *) + +val failwith : string -> 'a +(** Raise exception [Failure] with the given string. *) + +exception Exit +(** The [Exit] exception is not raised by any library function. It is + provided for use in your programs. *) + +(** {1 Boolean operations} *) + +external not : bool -> bool = "%boolnot" +(** The boolean negation. *) + +external ( && ) : bool -> bool -> bool = "%sequand" +(** The boolean 'and'. Evaluation is sequential, left-to-right: + in [e1 && e2], [e1] is evaluated first, and if it returns [false], + [e2] is not evaluated at all. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( || ) : bool -> bool -> bool = "%sequor" +(** The boolean 'or'. Evaluation is sequential, left-to-right: + in [e1 || e2], [e1] is evaluated first, and if it returns [true], + [e2] is not evaluated at all. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +(** {1 Debugging} *) + +external __LOC__ : string = "%loc_LOC" +(** [__LOC__] returns the location at which this expression appears in + the file currently being parsed by the compiler, with the standard + error format of OCaml: "File %S, line %d, characters %d-%d". + @since 4.02.0 +*) + +external __FILE__ : string = "%loc_FILE" +(** [__FILE__] returns the name of the file currently being + parsed by the compiler. + @since 4.02.0 +*) + +external __LINE__ : int = "%loc_LINE" +(** [__LINE__] returns the line number at which this expression + appears in the file currently being parsed by the compiler. + @since 4.02.0 +*) + +external __MODULE__ : string = "%loc_MODULE" +(** [__MODULE__] returns the module name of the file being + parsed by the compiler. + @since 4.02.0 +*) + +external __POS__ : string * int * int * int = "%loc_POS" +(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding + to the location at which this expression appears in the file + currently being parsed by the compiler. [file] is the current + filename, [lnum] the line number, [cnum] the character position in + the line and [enum] the last character position in the line. + @since 4.02.0 + *) + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the + location of [expr] in the file currently being parsed by the + compiler, with the standard error format of OCaml: "File %S, line + %d, characters %d-%d". + @since 4.02.0 +*) + +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +(** [__LINE_OF__ expr] returns a pair [(line, expr)], where [line] is the + line number at which the expression [expr] appears in the file + currently being parsed by the compiler. + @since 4.02.0 + *) + +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" +(** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a + tuple [(file,lnum,cnum,enum)] corresponding to the location at + which the expression [expr] appears in the file currently being + parsed by the compiler. [file] is the current filename, [lnum] the + line number, [cnum] the character position in the line and [enum] + the last character position in the line. + @since 4.02.0 + *) + +(** {1 Composition operators} *) + +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" +(** Reverse-application operator: [x |> f |> g] is exactly equivalent + to [g (f (x))]. + Left-associative operator, see {!Ocaml_operators} for more information. + @since 4.01 +*) + +external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(** Application operator: [g @@ f @@ x] is exactly equivalent to + [g (f (x))]. + Right-associative operator, see {!Ocaml_operators} for more information. + @since 4.01 +*) + +(** {1 Integer arithmetic} *) + +(** Integers are [Sys.int_size] bits wide. + All operations are taken modulo 2{^[Sys.int_size]}. + They do not fail on overflow. *) + +external ( ~- ) : int -> int = "%negint" +(** Unary negation. You can also write [- e] instead of [~- e]. + Unary operator, see {!Ocaml_operators} for more information. +*) + + +external ( ~+ ) : int -> int = "%identity" +(** Unary addition. You can also write [+ e] instead of [~+ e]. + Unary operator, see {!Ocaml_operators} for more information. + @since 3.12.0 +*) + +external succ : int -> int = "%succint" +(** [succ x] is [x + 1]. *) + +external pred : int -> int = "%predint" +(** [pred x] is [x - 1]. *) + +external ( + ) : int -> int -> int = "%addint" +(** Integer addition. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( - ) : int -> int -> int = "%subint" +(** Integer subtraction. + Left-associative operator, , see {!Ocaml_operators} for more information. +*) + +external ( * ) : int -> int -> int = "%mulint" +(** Integer multiplication. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( / ) : int -> int -> int = "%divint" +(** Integer division. + Raise [Division_by_zero] if the second argument is 0. + Integer division rounds the real quotient of its arguments towards zero. + More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer + less than or equal to the real quotient of [x] by [y]. Moreover, + [(- x) / y = x / (- y) = - (x / y)]. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( mod ) : int -> int -> int = "%modint" +(** Integer remainder. If [y] is not zero, the result + of [x mod y] satisfies the following properties: + [x = (x / y) * y + x mod y] and + [abs(x mod y) <= abs(y) - 1]. + If [y = 0], [x mod y] raises [Division_by_zero]. + Note that [x mod y] is negative only if [x < 0]. + Raise [Division_by_zero] if [y] is zero. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +val abs : int -> int +(** Return the absolute value of the argument. Note that this may be + negative if the argument is [min_int]. *) + +val max_int : int +(** The greatest representable integer. *) + +val min_int : int +(** The smallest representable integer. *) + + +(** {2 Bitwise operations} *) + +external ( land ) : int -> int -> int = "%andint" +(** Bitwise logical and. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( lor ) : int -> int -> int = "%orint" +(** Bitwise logical or. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( lxor ) : int -> int -> int = "%xorint" +(** Bitwise logical exclusive or. + Left-associative operator, see {!Ocaml_operators} for more information. +*) + +val lnot : int -> int +(** Bitwise logical negation. *) + +external ( lsl ) : int -> int -> int = "%lslint" +(** [n lsl m] shifts [n] to the left by [m] bits. + The result is unspecified if [m < 0] or [m > Sys.int_size]. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( lsr ) : int -> int -> int = "%lsrint" +(** [n lsr m] shifts [n] to the right by [m] bits. + This is a logical shift: zeroes are inserted regardless of + the sign of [n]. + The result is unspecified if [m < 0] or [m > Sys.int_size]. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +external ( asr ) : int -> int -> int = "%asrint" +(** [n asr m] shifts [n] to the right by [m] bits. + This is an arithmetic shift: the sign bit of [n] is replicated. + The result is unspecified if [m < 0] or [m > Sys.int_size]. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +(** {1 String operations} + + More string operations are provided in module {!String}. +*) + +val ( ^ ) : string -> string -> string +(** String concatenation. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +(** {1 Character operations} + + More character operations are provided in module {!Char}. +*) + +external int_of_char : char -> int = "%identity" +(** Return the ASCII code of the argument. *) + +val char_of_int : int -> char +(** Return the character with the given ASCII code. + Raise [Invalid_argument "char_of_int"] if the argument is + outside the range 0--255. *) + + +(** {1 Unit operations} *) + +external ignore : 'a -> unit = "%ignore" +(** Discard the value of its argument and return [()]. + For instance, [ignore(f x)] discards the result of + the side-effecting function [f]. It is equivalent to + [f x; ()], except that the latter may generate a + compiler warning; writing [ignore(f x)] instead + avoids the warning. *) + + +(** {1 String conversion functions} *) + +val string_of_bool : bool -> string +(** Return the string representation of a boolean. As the returned values + may be shared, the user should not modify them directly. +*) + +val bool_of_string_opt: string -> bool option +(** Convert the given string to a boolean. + + Return [None] if the string is not ["true"] or ["false"]. + @since 4.05 +*) + +val string_of_int : int -> string +(** Return the string representation of an integer, in decimal. *) + +val int_of_string_opt: string -> int option +(** Convert the given string to an integer. + The string is read in decimal (by default, or if the string + begins with [0u]), in hexadecimal (if it begins with [0x] or + [0X]), in octal (if it begins with [0o] or [0O]), or in binary + (if it begins with [0b] or [0B]). + + The [0u] prefix reads the input as an unsigned integer in the range + [[0, 2*max_int+1]]. If the input exceeds {!max_int} + it is converted to the signed integer + [min_int + input - max_int - 1]. + + The [_] (underscore) character can appear anywhere in the string + and is ignored. + + Return [None] if the given string is not a valid representation of an + integer, or if the integer represented exceeds the range of integers + representable in type [int]. + @since 4.05 +*) + +(** {1 Pair operations} *) + +external fst : 'a * 'b -> 'a = "%field0" +(** Return the first component of a pair. *) + +external snd : 'a * 'b -> 'b = "%field1" +(** Return the second component of a pair. *) + + +(** {1 List operations} + + More list operations are provided in module {!List}. +*) + +val ( @ ) : 'a list -> 'a list -> 'a list +(** List concatenation. Not tail-recursive (length of the first argument). + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +(** {1 References} *) + +type 'a ref = { mutable contents : 'a } +(** The type of references (mutable indirection cells) containing + a value of type ['a]. *) + +external ref : 'a -> 'a ref = "%makemutable" +(** Return a fresh reference containing the given value. *) + +external ( ! ) : 'a ref -> 'a = "%field0" +(** [!r] returns the current contents of reference [r]. + Equivalent to [fun r -> r.contents]. + Unary operator, see {!Ocaml_operators} for more information. +*) + +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +(** [r := a] stores the value of [a] in reference [r]. + Equivalent to [fun r v -> r.contents <- v]. + Right-associative operator, see {!Ocaml_operators} for more information. +*) + +external incr : int ref -> unit = "%incr" +(** Increment the integer contained in the given reference. + Equivalent to [fun r -> r := succ !r]. *) + +external decr : int ref -> unit = "%decr" +(** Decrement the integer contained in the given reference. + Equivalent to [fun r -> r := pred !r]. *) + +(** {1 Result type} *) + +(** @since 4.03.0 *) +type ('a,'b) result = Ok of 'a | Error of 'b + +(** {1 Operations on format strings} *) + +(** Format strings are character strings with special lexical conventions + that defines the functionality of formatted input/output functions. Format + strings are used to read data with formatted input functions from module + {!Scanf} and to print data with formatted output functions from modules + {!Printf} and {!Format}. + + Format strings are made of three kinds of entities: + - {e conversions specifications}, introduced by the special character ['%'] + followed by one or more characters specifying what kind of argument to + read or print, + - {e formatting indications}, introduced by the special character ['@'] + followed by one or more characters specifying how to read or print the + argument, + - {e plain characters} that are regular characters with usual lexical + conventions. Plain characters specify string literals to be read in the + input or printed in the output. + + There is an additional lexical rule to escape the special characters ['%'] + and ['@'] in format strings: if a special character follows a ['%'] + character, it is treated as a plain character. In other words, ["%%"] is + considered as a plain ['%'] and ["%@"] as a plain ['@']. + + For more information about conversion specifications and formatting + indications available, read the documentation of modules {!Scanf}, + {!Printf} and {!Format}. +*) + +(** Format strings have a general and highly polymorphic type + [('a, 'b, 'c, 'd, 'e, 'f) format6]. + The two simplified types, [format] and [format4] below are + included for backward compatibility with earlier releases of + OCaml. + + The meaning of format string type parameters is as follows: + + - ['a] is the type of the parameters of the format for formatted output + functions ([printf]-style functions); + ['a] is the type of the values read by the format for formatted input + functions ([scanf]-style functions). + + - ['b] is the type of input source for formatted input functions and the + type of output target for formatted output functions. + For [printf]-style functions from module {!Printf}, ['b] is typically + [out_channel]; + for [printf]-style functions from module {!Format}, ['b] is typically + {!Format.formatter}; + for [scanf]-style functions from module {!Scanf}, ['b] is typically + {!Scanf.Scanning.in_channel}. + + Type argument ['b] is also the type of the first argument given to + user's defined printing functions for [%a] and [%t] conversions, + and user's defined reading functions for [%r] conversion. + + - ['c] is the type of the result of the [%a] and [%t] printing + functions, and also the type of the argument transmitted to the + first argument of [kprintf]-style functions or to the + [kscanf]-style functions. + + - ['d] is the type of parameters for the [scanf]-style functions. + + - ['e] is the type of the receiver function for the [scanf]-style functions. + + - ['f] is the final result type of a formatted input/output function + invocation: for the [printf]-style functions, it is typically [unit]; + for the [scanf]-style functions, it is typically the result type of the + receiver function. +*) + +type ('a, 'b, 'c, 'd, 'e, 'f) format6 = + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 + +val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string +(** Converts a format string into a string. *) + +external format_of_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" +(** [format_of_string s] returns a format string read from the string + literal [s]. + Note: [format_of_string] can not convert a string argument that is not a + literal. If you need this functionality, use the more general + {!Scanf.format_from_string} function. +*) + +val ( ^^ ) : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6 +(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a + format string that behaves as the concatenation of format strings [f1] and + [f2]: in case of formatted output, it accepts arguments from [f1], then + arguments from [f2]; in case of formatted input, it returns results from + [f1], then results from [f2]. + Right-associative operator, see {!Ocaml_operators} for more information. +*) diff --git a/src/lib_protocol_environment/sigs/v5/protocol.mli b/src/lib_protocol_environment/sigs/v5/protocol.mli new file mode 100644 index 000000000000..35bf38a36c1f --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/protocol.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = {expected_env : env_version; components : component list} + +(** An OCaml source component of a protocol implementation. *) +and component = { + (* The OCaml module name. *) + name : string; + (* The OCaml interface source code *) + interface : string option; + (* The OCaml source code *) + implementation : string; +} + +and env_version = V0 | V1 | V2 | V3 | V4 | V5 + +val component_encoding : component Data_encoding.t + +val env_version_encoding : env_version Data_encoding.t + +include S.HASHABLE with type t := t and type hash := Protocol_hash.t diff --git a/src/lib_protocol_environment/sigs/v5/protocol_hash.mli b/src/lib_protocol_environment/sigs/v5/protocol_hash.mli new file mode 100644 index 000000000000..4b50414f898a --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/protocol_hash.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Protocol hashes / IDs. *) +include S.HASH diff --git a/src/lib_protocol_environment/sigs/v5/pvss_secp256k1.mli b/src/lib_protocol_environment/sigs/v5/pvss_secp256k1.mli new file mode 100644 index 000000000000..49f1026bd6cb --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/pvss_secp256k1.mli @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos - PVSS Secp256k1 cryptography *) + +include S.PVSS diff --git a/src/lib_protocol_environment/sigs/v5/raw_hashes.mli b/src/lib_protocol_environment/sigs/v5/raw_hashes.mli new file mode 100644 index 000000000000..e493f7cdc622 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/raw_hashes.mli @@ -0,0 +1,36 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val blake2b : bytes -> bytes + +val sha256 : bytes -> bytes + +val sha512 : bytes -> bytes + +val keccak256 : bytes -> bytes + +val sha3_256 : bytes -> bytes + +val sha3_512 : bytes -> bytes diff --git a/src/lib_protocol_environment/sigs/v5/result.mli b/src/lib_protocol_environment/sigs/v5/result.mli new file mode 100644 index 000000000000..818dd2a07108 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/result.mli @@ -0,0 +1,160 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e (***) + +val ok : 'a -> ('a, 'e) result + +val ok_s : 'a -> ('a, 'e) result Lwt.t + +val error : 'e -> ('a, 'e) result + +val error_s : 'e -> ('a, 'e) result Lwt.t + +val return : 'a -> ('a, 'e) result + +val return_unit : (unit, 'e) result + +val return_none : ('a option, 'e) result + +val return_some : 'a -> ('a option, 'e) result + +val return_nil : ('a list, 'e) result + +val return_true : (bool, 'e) result + +val return_false : (bool, 'e) result + +val value : ('a, 'e) result -> default:'a -> 'a + +val value_f : ('a, 'e) result -> default:(unit -> 'a) -> 'a + +val bind : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result + +val bind_s : + ('a, 'e) result -> ('a -> ('b, 'e) result Lwt.t) -> ('b, 'e) result Lwt.t + +val bind_error : ('a, 'e) result -> ('e -> ('a, 'f) result) -> ('a, 'f) result + +val bind_error_s : + ('a, 'e) result -> ('e -> ('a, 'f) result Lwt.t) -> ('a, 'f) result Lwt.t + +val join : (('a, 'e) result, 'e) result -> ('a, 'e) result + +val map : ('a -> 'b) -> ('a, 'e) result -> ('b, 'e) result + +(* NOTE: [map_e] is [bind] *) +val map_e : ('a -> ('b, 'e) result) -> ('a, 'e) result -> ('b, 'e) result + +val map_s : ('a -> 'b Lwt.t) -> ('a, 'e) result -> ('b, 'e) result Lwt.t + +(* NOTE: [map_es] is [bind_s] *) +val map_es : + ('a -> ('b, 'e) result Lwt.t) -> ('a, 'e) result -> ('b, 'e) result Lwt.t + +val map_error : ('e -> 'f) -> ('a, 'e) result -> ('a, 'f) result + +(* NOTE: [map_error_e] is [bind_error] *) +val map_error_e : ('e -> ('a, 'f) result) -> ('a, 'e) result -> ('a, 'f) result + +val map_error_s : ('e -> 'f Lwt.t) -> ('a, 'e) result -> ('a, 'f) result Lwt.t + +(* NOTE: [map_error_es] is [bind_error_s] *) +val map_error_es : + ('e -> ('a, 'f) result Lwt.t) -> ('a, 'e) result -> ('a, 'f) result Lwt.t + +val fold : ok:('a -> 'c) -> error:('e -> 'c) -> ('a, 'e) result -> 'c + +val iter : ('a -> unit) -> ('a, 'e) result -> unit + +val iter_s : ('a -> unit Lwt.t) -> ('a, 'e) result -> unit Lwt.t + +val iter_error : ('e -> unit) -> ('a, 'e) result -> unit + +val iter_error_s : ('e -> unit Lwt.t) -> ('a, 'e) result -> unit Lwt.t + +val is_ok : ('a, 'e) result -> bool + +val is_error : ('a, 'e) result -> bool + +val equal : + ok:('a -> 'a -> bool) -> + error:('e -> 'e -> bool) -> + ('a, 'e) result -> + ('a, 'e) result -> + bool + +val compare : + ok:('a -> 'a -> int) -> + error:('e -> 'e -> int) -> + ('a, 'e) result -> + ('a, 'e) result -> + int + +val to_option : ('a, 'e) result -> 'a option + +val of_option : error:'e -> 'a option -> ('a, 'e) result + +val to_list : ('a, 'e) result -> 'a list + +val to_seq : ('a, 'e) result -> 'a Seq.t + +(** [catch f] is [try Ok (f ()) with e -> Error e]: it is [Ok x] if [f ()] + evaluates to [x], and it is [Error e] if [f ()] raises [e]. + + See {!WithExceptions.S.Result.to_exn} for a converse function. + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] + is [true] are caught. + + Whether [catch_only] is set or not, you cannot catch non-deterministic + runtime exceptions of OCaml such as {!Stack_overflow} and + {!Out_of_memory} nor system exceptions such as {!Unix.Unix_error}. *) +val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> ('a, exn) result + +(** [catch_f f handler] is equivalent to [map_error (catch f) handler]. + In other words, it catches exceptions in [f ()] and either returns the + value in an [Ok] or passes the exception to [handler] for the [Error]. + + [catch_only] has the same use as with [catch]. The same restriction on + catching non-deterministic runtime exceptions applies. *) +val catch_f : + ?catch_only:(exn -> bool) -> + (unit -> 'a) -> + (exn -> 'error) -> + ('a, 'error) result + +(** [catch_s] is [catch] but for Lwt promises. Specifically, [catch_s f] + returns a promise that resolves to [Ok x] if and when [f ()] resolves to + [x], or to [Error exc] if and when [f ()] is rejected with [exc]. + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] + is [true] are caught. + + Whether [catch_only] is set or not, you cannot catch non-deterministic + runtime exceptions of OCaml such as {!Stack_overflow} and + {!Out_of_memory} nor system exceptions such as {!Unix.Unix_error}. *) +val catch_s : + ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/s.mli b/src/lib_protocol_environment/sigs/v5/s.mli new file mode 100644 index 000000000000..3bca106e31cb --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/s.mli @@ -0,0 +1,406 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Generic interface for a datatype with comparison, pretty-printer + and serialization functions. *) +module type T = sig + type t + + include Compare.S with type t := t + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t + + val to_bytes : t -> bytes + + val of_bytes : bytes -> t option +end + +(** Generic interface for a datatype with comparison, pretty-printer, + serialization functions and a hashing function. *) +module type HASHABLE = sig + include T + + type hash + + val hash : t -> hash + + val hash_raw : bytes -> hash +end + +(** {2 Hash Types} *) + +(** The signature of an abstract hash type, as produced by functor + {!Make_SHA256}. The {!t} type is abstracted for separating the + various kinds of hashes in the system at typing time. Each type is + equipped with functions to use it as is of as keys in the database + or in memory sets and maps. *) + +module type MINIMAL_HASH = sig + type t + + val name : string + + val title : string + + val pp : Format.formatter -> t -> unit + + val pp_short : Format.formatter -> t -> unit + + include Compare.S with type t := t + + val hash_bytes : ?key:bytes -> bytes list -> t + + val hash_string : ?key:string -> string list -> t + + val zero : t +end + +module type RAW_DATA = sig + type t + + val size : int (* in bytes *) + + val to_bytes : t -> bytes + + val of_bytes_opt : bytes -> t option + + val of_bytes_exn : bytes -> t +end + +module type B58_DATA = sig + type t + + val to_b58check : t -> string + + val to_short_b58check : t -> string + + val of_b58check_exn : string -> t + + val of_b58check_opt : string -> t option + + type Base58.data += Data of t + + val b58check_encoding : t Base58.encoding +end + +module type ENCODER = sig + type t + + val encoding : t Data_encoding.t + + val rpc_arg : t RPC_arg.t +end + +module type INDEXES_SET = sig + include Set.S + + val random_elt : t -> elt + + val encoding : t Data_encoding.t +end + +module type INDEXES_MAP = sig + include Map.S + + val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t +end + +module type INDEXES = sig + type t + + module Set : INDEXES_SET with type elt = t + + module Map : INDEXES_MAP with type key = t +end + +module type HASH = sig + include MINIMAL_HASH + + include RAW_DATA with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + include INDEXES with type t := t +end + +module type MERKLE_TREE = sig + type elt + + include HASH + + val compute : elt list -> t + + val empty : t + + type path = Left of path * t | Right of t * path | Op + + val compute_path : elt list -> int -> path + + val check_path : path -> elt -> t * int + + val path_encoding : path Data_encoding.t +end + +module type SIGNATURE_PUBLIC_KEY_HASH = sig + type t + + val pp : Format.formatter -> t -> unit + + val pp_short : Format.formatter -> t -> unit + + include Compare.S with type t := t + + include RAW_DATA with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + include INDEXES with type t := t + + val zero : t +end + +module type SIGNATURE_PUBLIC_KEY = sig + type t + + val pp : Format.formatter -> t -> unit + + include Compare.S with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + type public_key_hash_t + + val hash : t -> public_key_hash_t + + val size : t -> int (* in bytes *) + + val of_bytes_without_validation : bytes -> t option +end + +module type SIGNATURE = sig + module Public_key_hash : SIGNATURE_PUBLIC_KEY_HASH + + module Public_key : + SIGNATURE_PUBLIC_KEY with type public_key_hash_t := Public_key_hash.t + + type t + + val pp : Format.formatter -> t -> unit + + include RAW_DATA with type t := t + + include Compare.S with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t + + val zero : t + + type watermark + + (** Check a signature *) + val check : ?watermark:watermark -> Public_key.t -> t -> bytes -> bool +end + +module type FIELD = sig + type t + + (** The order of the finite field *) + val order : Z.t + + (** minimal number of bytes required to encode a value of the field. *) + val size_in_bytes : int + + (** [check_bytes bs] returns [true] if [bs] is a correct byte + representation of a field element *) + val check_bytes : Bytes.t -> bool + + (** The neutral element for the addition *) + val zero : t + + (** The neutral element for the multiplication *) + val one : t + + (** [add a b] returns [a + b mod order] *) + val add : t -> t -> t + + (** [mul a b] returns [a * b mod order] *) + val mul : t -> t -> t + + (** [eq a b] returns [true] if [a = b mod order], else [false] *) + val eq : t -> t -> bool + + (** [negate x] returns [-x mod order]. Equivalently, [negate x] returns the + unique [y] such that [x + y mod order = 0] + *) + val negate : t -> t + + (** [inverse_opt x] returns [x^-1] if [x] is not [0] as an option, else [None] *) + val inverse_opt : t -> t option + + (** [pow x n] returns [x^n] *) + val pow : t -> Z.t -> t + + (** From a predefined bytes representation, construct a value t. It is not + required that to_bytes [(Option.get (of_bytes_opt t)) = t]. By default, + little endian encoding is used and the given element is modulo the prime + order *) + val of_bytes_opt : Bytes.t -> t option + + (** Convert the value t to a bytes representation which can be used for + hashing for instance. It is not required that [to_bytes (Option.get + (of_bytes_opt t)) = t]. By default, little endian encoding is used, and + length of the resulting bytes may vary depending on the order. + *) + val to_bytes : t -> Bytes.t +end + +(** Module type for the prime fields GF(p) *) +module type PRIME_FIELD = sig + include FIELD + + (** [of_z x] builds an element t from the Zarith element [x]. [mod order] is + applied if [x >= order] or [x < 0]. *) + val of_z : Z.t -> t + + (** [to_z x] builds a Zarith element, using the decimal representation. + Arithmetic on the result can be done using the modular functions on + integers *) + val to_z : t -> Z.t +end + +module type CURVE = sig + (** The type of the element in the elliptic curve *) + type t + + (** The size of a point representation, in bytes *) + val size_in_bytes : int + + module Scalar : FIELD + + (** Check if a point, represented as a byte array, is on the curve **) + val check_bytes : Bytes.t -> bool + + (** Attempt to construct a point from a byte array *) + val of_bytes_opt : Bytes.t -> t option + + (** Return a representation in bytes *) + val to_bytes : t -> Bytes.t + + (** Zero of the elliptic curve *) + val zero : t + + (** A fixed generator of the elliptic curve *) + val one : t + + (** Return the addition of two element *) + val add : t -> t -> t + + (** Double the element *) + val double : t -> t + + (** Return the opposite of the element *) + val negate : t -> t + + (** Return [true] if the two elements are algebraically the same *) + val eq : t -> t -> bool + + (** Multiply an element by a scalar *) + val mul : t -> Scalar.t -> t +end + +module type PVSS_ELEMENT = sig + type t + + include B58_DATA with type t := t + + include ENCODER with type t := t +end + +module type PVSS_PUBLIC_KEY = sig + type t + + val pp : Format.formatter -> t -> unit + + include Compare.S with type t := t + + include RAW_DATA with type t := t + + include B58_DATA with type t := t + + include ENCODER with type t := t +end + +module type PVSS_SECRET_KEY = sig + type public_key + + type t + + include ENCODER with type t := t + + val to_public_key : t -> public_key +end + +module type PVSS = sig + type proof + + module Clear_share : PVSS_ELEMENT + + module Commitment : PVSS_ELEMENT + + module Encrypted_share : PVSS_ELEMENT + + module Public_key : PVSS_PUBLIC_KEY + + module Secret_key : PVSS_SECRET_KEY with type public_key := Public_key.t + + val proof_encoding : proof Data_encoding.t + + val check_dealer_proof : + Encrypted_share.t list -> + Commitment.t list -> + proof:proof -> + public_keys:Public_key.t list -> + bool + + val check_revealed_share : + Encrypted_share.t -> + Clear_share.t -> + public_key:Public_key.t -> + proof -> + bool + + val reconstruct : Clear_share.t list -> int list -> Public_key.t +end diff --git a/src/lib_protocol_environment/sigs/v5/sapling.mli b/src/lib_protocol_environment/sigs/v5/sapling.mli new file mode 100644 index 000000000000..682a86746479 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/sapling.mli @@ -0,0 +1,125 @@ +(* The MIT License (MIT) + * + * Copyright (c) 2019-2020 Nomadic Labs + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. *) + +module Ciphertext : sig + type t + + val encoding : t Data_encoding.t + + val get_memo_size : t -> int +end + +module Commitment : sig + type t + + val encoding : t Data_encoding.t + + val valid_position : int64 -> bool +end + +module CV : sig + type t + + val encoding : t Data_encoding.t +end + +module Hash : sig + type t + + val compare : t -> t -> int + + val encoding : t Data_encoding.t + + val to_bytes : t -> Bytes.t + + val of_bytes_exn : Bytes.t -> t + + val uncommitted : height:int -> t + + val merkle_hash : height:int -> t -> t -> t + + val of_commitment : Commitment.t -> t + + val to_commitment : t -> Commitment.t +end + +module Nullifier : sig + type t + + val encoding : t Data_encoding.t + + val compare : t -> t -> int +end + +module UTXO : sig + type rk + + type spend_proof + + type spend_sig + + type output_proof + + type input = { + cv : CV.t; + nf : Nullifier.t; + rk : rk; + proof_i : spend_proof; + signature : spend_sig; + } + + val input_encoding : input Data_encoding.t + + type output = { + cm : Commitment.t; + proof_o : output_proof; + ciphertext : Ciphertext.t; + } + + val output_encoding : output Data_encoding.t + + type binding_sig + + type transaction = { + inputs : input list; + outputs : output list; + binding_sig : binding_sig; + balance : Int64.t; + root : Hash.t; + } + + val transaction_encoding : transaction Data_encoding.t + + val binding_sig_encoding : binding_sig Data_encoding.t +end + +module Verification : sig + type t + + val with_verification_ctx : (t -> 'a) -> 'a + + val check_spend : t -> UTXO.input -> Hash.t -> string -> bool + + val check_output : t -> UTXO.output -> bool + + val final_check : t -> UTXO.transaction -> string -> bool +end diff --git a/src/lib_protocol_environment/sigs/v5/secp256k1.mli b/src/lib_protocol_environment/sigs/v5/secp256k1.mli new file mode 100644 index 000000000000..a7fe44818500 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/secp256k1.mli @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos - Secp256k1 cryptography *) + +include S.SIGNATURE with type watermark := bytes diff --git a/src/lib_protocol_environment/sigs/v5/seq.mli b/src/lib_protocol_environment/sigs/v5/seq.mli new file mode 100644 index 000000000000..74d5054d4b28 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/seq.mli @@ -0,0 +1,119 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* From Lwtreslib *) + +type 'a t = unit -> 'a node + +and +'a node = 'a Stdlib.Seq.node = Nil | Cons of 'a * 'a t + +val empty : 'a t + +val return : 'a -> 'a t + +val cons : 'a -> 'a t -> 'a t + +val append : 'a t -> 'a t -> 'a t + +val map : ('a -> 'b) -> 'a t -> 'b t + +val filter : ('a -> bool) -> 'a t -> 'a t + +val filter_map : ('a -> 'b option) -> 'a t -> 'b t + +val flat_map : ('a -> 'b t) -> 'a t -> 'b t + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + +val iter : ('a -> unit) -> 'a t -> unit + +val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t + +(** {3 Lwtreslib-specific extensions} *) + +(** [first s] is [None] if [s] is empty, it is [Some x] where [x] is the + first element of [s] otherwise. + + Note that [first] forces the first element of the sequence, which can have + side-effects or be computationally expensive. Consider, e.g., the case + where [s = filter (fun …) s']: [first s] can force multiple of the values + from [s']. *) +val first : 'a t -> 'a option + +(** Similar to {!fold_left} but wraps the traversal in {!result}. The + traversal is interrupted if one of the step returns an [Error _]. *) +val fold_left_e : + ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b t -> ('a, 'trace) result + +(** Similar to {!fold_left} but wraps the traversing in {!Lwt}. Each step of + the traversal is started after the previous one has resolved. The + traversal is interrupted if one of the promise is rejected. *) +val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t + +(** Similar to {!fold_left} but wraps the traversing in [result Lwt.t]. + Each step of the traversal is started after the previous one resolved. The + traversal is interrupted if one of the step is rejected or is fulfilled + with [Error _]. *) +val fold_left_es : + ('a -> 'b -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b t -> + ('a, 'trace) result Lwt.t + +(** Similar to {!iter} but wraps the iteration in {!result}. The iteration + is interrupted if one of the step returns an [Error _]. *) +val iter_e : ('a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result + +(** Similar to {!iter} but wraps the iteration in {!Lwt}. Each step + of the iteration is started after the previous one resolved. The iteration + is interrupted if one of the promise is rejected. *) +val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + +(** Similar to {!iter} but wraps the iteration in [result Lwt.t]. Each step + of the iteration is started after the previous one resolved. The iteration + is interrupted if one of the promise is rejected of fulfilled with an + [Error _]. *) +val iter_es : + ('a -> (unit, 'trace) result Lwt.t) -> 'a t -> (unit, 'trace) result Lwt.t + +(** Similar to {!iter} but wraps the iteration in [result Lwt.t]. All the + steps of the iteration are started concurrently. The promise [iter_ep] + resolves once all the promises of the traversal resolve. At this point it + either: + - is rejected if at least one of the promises is, otherwise + - is fulfilled with [Error _] if at least one of the promises is, + otherwise + - is fulfilled with [Ok ()] if all the promises are. *) +val iter_ep : + ('a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + 'a t -> + (unit, 'error Error_monad.trace) result Lwt.t + +(** Similar to {!iter} but wraps the iteration in {!Lwt}. All the + steps of the iteration are started concurrently. The promise [iter_p f s] + is resolved only once all the promises of the iteration are. At this point + it is either fulfilled if all promises are, or rejected if at least one of + them is. *) +val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/set.mli b/src/lib_protocol_environment/sigs/v5/set.mli new file mode 100644 index 000000000000..ade4bb1cff97 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/set.mli @@ -0,0 +1,131 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* From Lwtreslib *) + +module type S = sig + type elt + + type t + + (**/**) + module Legacy : Stdlib.Set.S with type elt = elt and type t = t + (**/**) + + val empty : t + + val is_empty : t -> bool + + val mem : elt -> t -> bool + + val add : elt -> t -> t + + val singleton : elt -> t + + val remove : elt -> t -> t + + val union : t -> t -> t + + val inter : t -> t -> t + + val disjoint : t -> t -> bool + + val diff : t -> t -> t + + val compare : t -> t -> int + + val equal : t -> t -> bool + + val subset : t -> t -> bool + + val iter : (elt -> unit) -> t -> unit + + val iter_e : (elt -> (unit, 'trace) result) -> t -> (unit, 'trace) result + + val iter_s : (elt -> unit Lwt.t) -> t -> unit Lwt.t + + val iter_p : (elt -> unit Lwt.t) -> t -> unit Lwt.t + + val iter_es : + (elt -> (unit, 'trace) result Lwt.t) -> t -> (unit, 'trace) result Lwt.t + + val map : (elt -> elt) -> t -> t + + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + + val fold_e : + (elt -> 'a -> ('a, 'trace) result) -> t -> 'a -> ('a, 'trace) result + + val fold_s : (elt -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t + + val fold_es : + (elt -> 'a -> ('a, 'trace) result Lwt.t) -> + t -> + 'a -> + ('a, 'trace) result Lwt.t + + val for_all : (elt -> bool) -> t -> bool + + val exists : (elt -> bool) -> t -> bool + + val filter : (elt -> bool) -> t -> t + + val partition : (elt -> bool) -> t -> t * t + + val cardinal : t -> int + + val elements : t -> elt list + + val min_elt : t -> elt option + + val max_elt : t -> elt option + + val choose : t -> elt option + + val split : elt -> t -> t * bool * t + + val find : elt -> t -> elt option + + val find_first : (elt -> bool) -> t -> elt option + + val find_last : (elt -> bool) -> t -> elt option + + val of_list : elt list -> t + + val to_seq_from : elt -> t -> elt Seq.t + + val to_seq : t -> elt Seq.t + + val add_seq : elt Seq.t -> t -> t + + val of_seq : elt Seq.t -> t + + val iter_ep : + (elt -> (unit, 'error Error_monad.trace) result Lwt.t) -> + t -> + (unit, 'error Error_monad.trace) result Lwt.t +end + +module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t diff --git a/src/lib_protocol_environment/sigs/v5/signature.mli b/src/lib_protocol_environment/sigs/v5/signature.mli new file mode 100644 index 000000000000..1a1d295d6025 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/signature.mli @@ -0,0 +1,46 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type public_key_hash = + | Ed25519 of Ed25519.Public_key_hash.t + | Secp256k1 of Secp256k1.Public_key_hash.t + | P256 of P256.Public_key_hash.t + +type public_key = + | Ed25519 of Ed25519.Public_key.t + | Secp256k1 of Secp256k1.Public_key.t + | P256 of P256.Public_key.t + +type watermark = + | Block_header of Chain_id.t + | Endorsement of Chain_id.t + | Generic_operation + | Custom of bytes + +include + S.SIGNATURE + with type Public_key_hash.t = public_key_hash + and type Public_key.t = public_key + and type watermark := watermark diff --git a/src/lib_protocol_environment/sigs/v5/string.mli b/src/lib_protocol_environment/sigs/v5/string.mli new file mode 100644 index 000000000000..e18c5afa07e6 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/string.mli @@ -0,0 +1,242 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** String operations. + + A string is an immutable data structure that contains a + fixed-length sequence of (single-byte) characters. Each character + can be accessed in constant time through its index. + + Given a string [s] of length [l], we can access each of the [l] + characters of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + characters or at the beginning or end of the string. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the character at index [n] is between + positions [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. + + Note: OCaml strings used to be modifiable in place, for instance via + the {!String.set} and {!String.blit} functions described below. This + usage is only possible when the compiler is put in "unsafe-string" + mode by giving the [-unsafe-string] command-line option. This + compatibility mode makes the types [string] and [bytes] (see module + {!Bytes}) interchangeable so that functions expecting byte sequences + can also accept strings as arguments and modify them. + + The distinction between [bytes] and [string] was introduced in OCaml + 4.02, and the "unsafe-string" compatibility mode was the default + until OCaml 4.05. Starting with 4.06, the compatibility mode is + opt-in; we intend to remove the option in the future. +*) + +external length : string -> int = "%string_length" +(** Return the length (number of characters) of the given string. *) + +external get : string -> int -> char = "%string_safe_get" +(** [String.get s n] returns the character at index [n] in string [s]. + You can also write [s.[n]] instead of [String.get s n]. + + Raise [Invalid_argument] if [n] not a valid index in [s]. *) + + +val make : int -> char -> string +(** [String.make n c] returns a fresh string of length [n], + filled with the character [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> (int -> char) -> string +(** [String.init n f] returns a string of length [n], with character + [i] initialized to the result of [f i] (called in increasing + index order). + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. + + @since 4.02.0 +*) + +val sub : string -> int -> int -> string +(** [String.sub s start len] returns a fresh string of length [len], + containing the substring of [s] that starts at position [start] and + has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) + +val blit : string -> int -> bytes -> int -> int -> unit +(** Same as {!Bytes.blit_string}. *) + +val concat : string -> string list -> string +(** [String.concat sep sl] concatenates the list of strings [sl], + inserting the separator string [sep] between each. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val iter : (char -> unit) -> string -> unit +(** [String.iter f s] applies function [f] in turn to all + the characters of [s]. It is equivalent to + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) + +val iteri : (int -> char -> unit) -> string -> unit +(** Same as {!String.iter}, but the + function is applied to the index of the element as first argument + (counting from 0), and the character itself as second argument. + @since 4.00.0 *) + +val map : (char -> char) -> string -> string +(** [String.map f s] applies function [f] in turn to all the + characters of [s] (in increasing index order) and stores the + results in a new string that is returned. + @since 4.00.0 *) + +val mapi : (int -> char -> char) -> string -> string +(** [String.mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the results in a new + string that is returned. + @since 4.02.0 *) + +val trim : string -> string +(** Return a copy of the argument, without leading and trailing + whitespace. The characters regarded as whitespace are: [' '], + ['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor + trailing whitespace character in the argument, return the original + string itself, not a copy. + @since 4.00.0 *) + +val escaped : string -> string +(** Return a copy of the argument, with special characters + represented by escape sequences, following the lexical + conventions of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash and double-quote. + + If there is no special character in the argument that needs + escaping, return the original string itself, not a copy. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. + + The function {!Scanf.unescaped} is a left inverse of [escaped], + i.e. [Scanf.unescaped (escaped s) = s] for any string [s] (unless + [escape s] fails). *) + +val index_opt: string -> char -> int option +(** [String.index_opt s c] returns the index of the first + occurrence of character [c] in string [s], or + [None] if [c] does not occur in [s]. + @since 4.05 *) + +val rindex_opt: string -> char -> int option +(** [String.rindex_opt s c] returns the index of the last occurrence + of character [c] in string [s], or [None] if [c] does not occur in + [s]. + @since 4.05 *) + +val index_from_opt: string -> int -> char -> int option +(** [String.index_from_opt s i c] returns the index of the + first occurrence of character [c] in string [s] after position [i] + or [None] if [c] does not occur in [s] after position [i]. + + [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c]. + Raise [Invalid_argument] if [i] is not a valid position in [s]. + + @since 4.05 +*) + +val rindex_from_opt: string -> int -> char -> int option +(** [String.rindex_from_opt s i c] returns the index of the + last occurrence of character [c] in string [s] before position [i+1] + or [None] if [c] does not occur in [s] before position [i+1]. + + [String.rindex_opt s c] is equivalent to + [String.rindex_from_opt s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + + @since 4.05 +*) + +val contains : string -> char -> bool +(** [String.contains s c] tests if character [c] + appears in the string [s]. *) + +val contains_from : string -> int -> char -> bool +(** [String.contains_from s start c] tests if character [c] + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : string -> int -> char -> bool +(** [String.rcontains_from s stop c] tests if character [c] + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase_ascii : string -> string +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) + +val lowercase_ascii : string -> string +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) + +val capitalize_ascii : string -> string +(** Return a copy of the argument, with the first character set to uppercase, + using the US-ASCII character set. + @since 4.03.0 *) + +val uncapitalize_ascii : string -> string +(** Return a copy of the argument, with the first character set to lowercase, + using the US-ASCII character set. + @since 4.03.0 *) + +type t = string +(** An alias for the type of strings. *) + +val compare: t -> t -> int +(** The comparison function for strings, with the same specification as + {!Stdlib.compare}. Along with the type [t], this function [compare] + allows the module [String] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equal function for strings. + @since 4.03.0 *) + +val split_on_char: char -> string -> string list +(** [String.split_on_char sep s] returns the list of all (possibly empty) + substrings of [s] that are delimited by the [sep] character. + + The function's output is specified by the following invariants: + + - The list is not empty. + - Concatenating its elements using [sep] as a separator returns a + string equal to the input ([String.concat (String.make 1 sep) + (String.split_on_char sep s) = s]). + - No string in the result contains the [sep] character. + + @since 4.04.0 +*) diff --git a/src/lib_protocol_environment/sigs/v5/tezos_data.mli b/src/lib_protocol_environment/sigs/v5/tezos_data.mli new file mode 100644 index 000000000000..f14e14044b89 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/tezos_data.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Protocol : sig end diff --git a/src/lib_protocol_environment/sigs/v5/time.mli b/src/lib_protocol_environment/sigs/v5/time.mli new file mode 100644 index 000000000000..d555494d2b7a --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/time.mli @@ -0,0 +1,48 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t + +include Compare.S with type t := t + +val add : t -> int64 -> t + +val diff : t -> t -> int64 + +val of_seconds : int64 -> t + +val to_seconds : t -> int64 + +val of_notation : string -> t option + +val of_notation_exn : string -> t + +val to_notation : t -> string + +val encoding : t Data_encoding.t + +val rfc_encoding : t Data_encoding.t + +val pp_hum : Format.formatter -> t -> unit diff --git a/src/lib_protocol_environment/sigs/v5/timelock.mli b/src/lib_protocol_environment/sigs/v5/timelock.mli new file mode 100644 index 000000000000..4151d194a004 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/timelock.mli @@ -0,0 +1,53 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs, chest_key -> time:int -> opening_result + +(** Gives the size of the underlying plaintext in a chest in bytes. + Used for gas accounting*) +val get_plaintext_size : chest -> int diff --git a/src/lib_protocol_environment/sigs/v5/tzEndian.mli b/src/lib_protocol_environment/sigs/v5/tzEndian.mli new file mode 100644 index 000000000000..4766e9e73fa6 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/tzEndian.mli @@ -0,0 +1,60 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2019 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val get_int32 : bytes -> int -> int32 + +val get_int32_string : string -> int -> int32 + +val set_int32 : bytes -> int -> int32 -> unit + +val set_int8 : bytes -> int -> int -> unit + +val get_int8 : bytes -> int -> int + +val get_int8_string : string -> int -> int + +val set_int16 : bytes -> int -> int -> unit + +val get_int16 : bytes -> int -> int + +val get_int16_string : string -> int -> int + +val set_int64 : bytes -> int -> int64 -> unit + +val get_int64 : bytes -> int -> int64 + +val get_int64_string : string -> int -> int64 + +val get_uint8 : bytes -> int -> int + +val get_uint8_string : string -> int -> int + +val set_uint8 : bytes -> int -> int -> unit + +val get_uint16 : bytes -> int -> int + +val get_uint16_string : string -> int -> int + +val set_uint16 : bytes -> int -> int -> unit diff --git a/src/lib_protocol_environment/sigs/v5/updater.mli b/src/lib_protocol_environment/sigs/v5/updater.mli new file mode 100644 index 000000000000..d1858539ba55 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/updater.mli @@ -0,0 +1,295 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Environment - Protocol updater. *) + +(** Validation result: the record returned by the protocol + on the successful validation of a block. *) +type validation_result = { + context : Context.t; + (** The resulting context, it will be used for the next block. *) + fitness : Fitness.t; + (** The effective fitness of the block (to be compared with the one + 'announced' in the block header). *) + message : string option; + (** An optional informative message, akin to a 'git commit' message, + which can be attached to the [context] when it's being commited. *) + max_operations_ttl : int; + (** The "time-to-live" of operations for the next block: any + operation whose 'branch' is older than 'ttl' blocks in the past + cannot be included in the next block. *) + last_allowed_fork_level : Int32.t; + (** The level of the last block for which the node might consider an + alternate branch. The shell should consider as invalid any branch + whose fork point is older (has a lower level) than the + given value. *) +} + +type quota = { + max_size : int; + (** The maximum size (in bytes) of the serialized list of + operations. *) + max_op : int option; + (** The maximum number of operations in a block. + [None] means no limit. *) +} + +type rpc_context = { + block_hash : Block_hash.t; + block_header : Block_header.shell_header; + context : Context.t; +} + +(** This is the signature of a Tezos protocol implementation. It has + access to the standard library and the Environment module. *) +module type PROTOCOL = sig + (** The maximum size of a block header in bytes. *) + val max_block_length : int + + (** The maximum size of an {!operation} in bytes. This value is bigger than the size + of the bytes required for {!operation_data}, because this value accounts + for the shell header. *) + val max_operation_data_length : int + + (** Operations quota for each validation pass. The length of the + list denotes the number of validation passes. *) + val validation_passes : quota list + + (** The economic protocol-specific type of blocks. *) + type block_header_data + + (** Encoding for economic protocol-specific part of block headers. *) + val block_header_data_encoding : block_header_data Data_encoding.t + + (** A fully parsed block header. *) + type block_header = { + shell : Block_header.shell_header; + protocol_data : block_header_data; + } + + (** Economic protocol-specific side information computed by the + protocol during the validation of a block. Should not include + information about the evaluation of operations which is handled + separately by {!operation_metadata}. To be used as an execution + trace by tools (client, indexer). Not necessary for + validation. *) + type block_header_metadata + + (** Encoding for economic protocol-specific block metadata. *) + val block_header_metadata_encoding : block_header_metadata Data_encoding.t + + (** The economic protocol-specific type of operations. *) + type operation_data + + (** Economic protocol-specific side information computed by the + protocol during the validation of each operation, to be used + conjointly with {!block_header_metadata}. *) + type operation_receipt + + (** A fully parsed operation. *) + type operation = { + shell : Operation.shell_header; + protocol_data : operation_data; + } + + (** Encoding for economoic protocol-specific operation data. *) + val operation_data_encoding : operation_data Data_encoding.t + + (** Encoding for eonomic protocol-specific operation receipts. *) + val operation_receipt_encoding : operation_receipt Data_encoding.t + + (** Encoding that mixes an operation data and its receipt. *) + val operation_data_and_receipt_encoding : + (operation_data * operation_receipt) Data_encoding.t + + (** [acceptable_passes op] lists the validation passes in which the + input operation [op] can appear. For instance, it results in + [[0]] if [op] only belongs to the first pass. An answer of [[]] + means that the [op] is ill-formed and cannot be included at + all in a block. *) + val acceptable_passes : operation -> int list + + (** [relative_position_within_block op1 op2] provides a partial and + strict order of operations within a block. It is intended to be + used as an argument to {!List.sort} (and other sorting/ordering + functions) to arrange a set of operations into a sequence, the + order of which is valid for the protocol. + + A negative (respectively, positive) results means that [op1] + should appear before (and, respectively, after) [op2] in a + block. This function does not provide a total ordering on the + operations: a result of [0] entails that the protocol does not + impose any preferences to the order in which [op1] and [op2] + should be included in a block. + + {b Caveat Emptor!} [relative_position_within_block o1 o2 = 0] + does NOT imply that [o1] is equal to [o2] in any way. + Consequently, it {e MUST NOT} be used as a [compare] component of + an {!Stdlib.Map.OrderedType}, or any such collection which relies + on a total comparison function. *) + val relative_position_within_block : operation -> operation -> int + + (** A functional state that is transmitted through the steps of a + block validation sequence: it can be created by any of the + [begin_x] functions below, and its final value is produced by + {!finalize_block}. It must retain the current state of the store, + and it can also contain additional information that must be + remembered during the validation process. Said extra content must + however be immutable: validator or baker implementations are + allowed to pause, replay or backtrack throughout validation + steps. *) + type validation_state + + (** [begin_partial_application cid ctxt] checks that a block is + well-formed in a given context. This function should run quickly, + as its main use is to reject bad blocks from the chain as early + as possible. The input [ancestor_context] is expected to result + from the application of an ancestor block of the current head + with the same economic protocol. Said ancestor block is also + required to be more recent (i.e., it has a greater level), than + the current head's "last_allowed_fork_level". + + The resulting `validation_state` will be used for multi-pass + validation. *) + val begin_partial_application : + chain_id:Chain_id.t -> + ancestor_context:Context.t -> + predecessor_timestamp:Time.t -> + predecessor_fitness:Fitness.t -> + block_header -> + validation_state tzresult Lwt.t + + (** [begin_application chain_id ... bh] defines the first step in a + block validation sequence. It initializes a validation context + for validating a block, whose header is [bh]. *) + val begin_application : + chain_id:Chain_id.t -> + predecessor_context:Context.t -> + predecessor_timestamp:Time.t -> + predecessor_fitness:Fitness.t -> + block_header -> + validation_state tzresult Lwt.t + + (** [begin_construction] initializes a validation context for + constructing a new block, as opposed to validating an existing + block. + + This function can be used in two modes: with and without the + optional [protocol_data] argument. With the latter, it is used by + bakers to start the process for baking a new block. Without it, + is used by the Shell's prevalidator to construct a virtual block, + which carries the contents of the pre-applied operations of the + mempool. + + When [protocol_data] is provided, it is not expected to be the + final value of the field of the same name in the {!block_header} + of the block eventually being baked. Instead, it is expected to + construct a protocol-specific, good enough, "prototype" of its + final value. For instance, if the economic protocol specifies + that its block headers include a signature, [protocol_data] must + include a (faked) signature. + + Moreover, these prototypes should not be distinguishable after + the application of [begin_construction]: the function must + produce the exact same context regardless of being passed a + prototype, or an "equivalent-but-complete" header. *) + val begin_construction : + chain_id:Chain_id.t -> + predecessor_context:Context.t -> + predecessor_timestamp:Time.t -> + predecessor_level:Int32.t -> + predecessor_fitness:Fitness.t -> + predecessor:Block_hash.t -> + timestamp:Time.t -> + ?protocol_data:block_header_data -> + unit -> + validation_state tzresult Lwt.t + + (** [apply_operation vs op] applies the input operation [op] on top + of the given {!validation_state} [vs]. It must be called after + {!begin_application} or {!begin_construction}, and before + {!finalize_block}, for each operation in a block. On a successful + application, it returns a pair consisting of the resulting + [validation_state], and the corresponding [operation_receipt]. *) + val apply_operation : + validation_state -> + operation -> + (validation_state * operation_receipt) tzresult Lwt.t + + (** [finalize_block vs] finalizes the context resulting from the + application of the contents of the block being validated. + + If there is no protocol migration, i.e., if the block being + applied is not the last block of the current economic protocol, the + resulting context can be used in the future as input for the + validation of its successor blocks. *) + val finalize_block : + validation_state -> + Block_header.shell_header option -> + (validation_result * block_header_metadata) tzresult Lwt.t + + (** [rpc_services] provides the list of remote procedures exported + by this protocol implementation. *) + val rpc_services : rpc_context RPC_directory.t + + (** [init ctxt hd] initializes the context, or upgrades the context + after a protocol amendment. This function receives as arguments + the context [ctxt] resulting from the application of the block + that triggered the amendment, as well as its header [hd]. This + function should fail if the "protocol stitching", i.e., the + transition from a valid previous protocol to the one being + activated, has not been implemented. *) + val init : + Context.t -> Block_header.shell_header -> validation_result tzresult Lwt.t + + (** [value_of_key chain_id predecessor_context + predecessor_timestamp predecessor_level predecessor_fitness + predecessor timestamp] returns a function to build one value of + the cache from its key. + + This function is used to restore all or part of the cache, for + instance when booting a validator to preheat the cache, or when a + reorganization happens. This function should never fail, returned + errors are fatal. + + The generated function is passed to [Context.Cache.load_caches] + which will use it either immediately a cache-loading time or + on-demand, when a given cached value is accessed. *) + val value_of_key : + chain_id:Chain_id.t -> + predecessor_context:Context.t -> + predecessor_timestamp:Time.t -> + predecessor_level:Int32.t -> + predecessor_fitness:Fitness.t -> + predecessor:Block_hash.t -> + timestamp:Time.t -> + (Context.Cache.key -> Context.Cache.value tzresult Lwt.t) tzresult Lwt.t +end + +(** [activate ctxt ph] activates an economic protocol (given by its + hash [ph]) from the context [ctxt]. The resulting context is still + a context for the current economic protocol, and the migration is + not complete until [init] in invoked. *) +val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/z.mli b/src/lib_protocol_environment/sigs/v5/z.mli new file mode 100644 index 000000000000..e04b459a7f0e --- /dev/null +++ b/src/lib_protocol_environment/sigs/v5/z.mli @@ -0,0 +1,468 @@ +(** + Integers. + + This modules provides arbitrary-precision integers. + Small integers internally use a regular OCaml [int]. + When numbers grow too large, we switch transparently to GMP numbers + ([mpn] numbers fully allocated on the OCaml heap). + + This interface is rather similar to that of [Int32] and [Int64], + with some additional functions provided natively by GMP + (GCD, square root, pop-count, etc.). + + + This file is part of the Zarith library + http://forge.ocamlcore.org/projects/zarith . + It is distributed under LGPL 2 licensing, with static linking exception. + See the LICENSE file included in the distribution. + + Copyright (c) 2010-2011 Antoine Miné, Abstraction project. + Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS), + a joint laboratory by: + CNRS (Centre national de la recherche scientifique, France), + ENS (École normale supérieure, Paris, France), + INRIA Rocquencourt (Institut national de recherche en informatique, France). + + *) + + +(** {1 Toplevel} *) + +(** For an optimal experience with the [ocaml] interactive toplevel, + the magic commands are: + + {[ + #load "zarith.cma";; + #install_printer Z.pp_print;; + ]} + + Alternatively, using the new [Zarith_top] toplevel module, simply: + {[ + #require "zarith.top";; + ]} +*) + + + +(** {1 Types} *) + +type t +(** Type of integers of arbitrary length. *) + +exception Overflow +(** Raised by conversion functions when the value cannot be represented in + the destination type. + *) + +(** {1 Construction} *) + +val zero: t +(** The number 0. *) + +val one: t +(** The number 1. *) + +val minus_one: t +(** The number -1. *) + +external of_int: int -> t = "%identity" +(** Converts from a base integer. *) + +external of_int32: int32 -> t = "ml_z_of_int32" +(** Converts from a 32-bit integer. *) + +external of_int64: int64 -> t = "ml_z_of_int64" +(** Converts from a 64-bit integer. *) + +val of_string: string -> t +(** Converts a string to an integer. + An optional [-] prefix indicates a negative number, while a [+] + prefix is ignored. + An optional prefix [0x], [0o], or [0b] (following the optional [-] + or [+] prefix) indicates that the number is, + represented, in hexadecimal, octal, or binary, respectively. + Otherwise, base 10 is assumed. + (Unlike C, a lone [0] prefix does not denote octal.) + Raises an [Invalid_argument] exception if the string is not a + syntactically correct representation of an integer. + *) + +val of_substring : string -> pos:int -> len:int -> t +(** [of_substring s ~pos ~len] is the same as [of_string (String.sub s + pos len)] + *) + +val of_string_base: int -> string -> t +(** Parses a number represented as a string in the specified base, + with optional [-] or [+] prefix. + The base must be between 2 and 16. + *) + +external of_substring_base + : int -> string -> pos:int -> len:int -> t + = "ml_z_of_substring_base" +(** [of_substring_base base s ~pos ~len] is the same as [of_string_base + base (String.sub s pos len)] +*) + + +(** {1 Basic arithmetic operations} *) + +val succ: t -> t +(** Returns its argument plus one. *) + +val pred: t -> t +(** Returns its argument minus one. *) + +val abs: t -> t +(** Absolute value. *) + +val neg: t -> t +(** Unary negation. *) + +val add: t -> t -> t +(** Addition. *) + +val sub: t -> t -> t +(** Subtraction. *) + +val mul: t -> t -> t +(** Multiplication. *) + +val div: t -> t -> t +(** Integer division. The result is truncated towards zero + and obeys the rule of signs. + Raises [Division_by_zero] if the divisor (second argument) is 0. + *) + +val rem: t -> t -> t +(** Integer remainder. Can raise a [Division_by_zero]. + The result of [rem a b] has the sign of [a], and its absolute value is + strictly smaller than the absolute value of [b]. + The result satisfies the equality [a = b * div a b + rem a b]. + *) + +external div_rem: t -> t -> (t * t) = "ml_z_div_rem" +(** Computes both the integer quotient and the remainder. + [div_rem a b] is equal to [(div a b, rem a b)]. + Raises [Division_by_zero] if [b = 0]. + *) + +external cdiv: t -> t -> t = "ml_z_cdiv" +(** Integer division with rounding towards +oo (ceiling). + Can raise a [Division_by_zero]. + *) + +external fdiv: t -> t -> t = "ml_z_fdiv" +(** Integer division with rounding towards -oo (floor). + Can raise a [Division_by_zero]. + *) + +val ediv_rem: t -> t -> (t * t) +(** Euclidean division and remainder. [ediv_rem a b] returns a pair [(q, r)] + such that [a = b * q + r] and [0 <= r < |b|]. + Raises [Division_by_zero] if [b = 0]. + *) + +val ediv: t -> t -> t +(** Euclidean division. [ediv a b] is equal to [fst (ediv_rem a b)]. + The result satisfies [0 <= a - b * ediv a b < |b|]. + Raises [Division_by_zero] if [b = 0]. + *) + +val erem: t -> t -> t +(** Euclidean remainder. [erem a b] is equal to [snd (ediv_rem a b)]. + The result satisfies [0 <= erem a b < |b|] and + [a = b * ediv a b + erem a b]. Raises [Division_by_zero] if [b = 0]. + *) + +val divexact: t -> t -> t +(** [divexact a b] divides [a] by [b], only producing correct result when the + division is exact, i.e., when [b] evenly divides [a]. + It should be faster than general division. + Can raise a [Division_by_zero]. +*) + +external divisible: t -> t -> bool = "ml_z_divisible" +(** [divisible a b] returns [true] if [a] is exactly divisible by [b]. + Unlike the other division functions, [b = 0] is accepted + (only 0 is considered divisible by 0). +*) + +external congruent: t -> t -> t -> bool = "ml_z_congruent" +(** [congruent a b c] returns [true] if [a] is congruent to [b] modulo [c]. + Unlike the other division functions, [c = 0] is accepted + (only equal numbers are considered equal congruent 0). +*) + + + + +(** {1 Bit-level operations} *) + +(** For all bit-level operations, negative numbers are considered in 2's + complement representation, starting with a virtual infinite number of + 1s. + *) + +val logand: t -> t -> t +(** Bitwise logical and. *) + +val logor: t -> t -> t +(** Bitwise logical or. *) + +val logxor: t -> t -> t +(** Bitwise logical exclusive or. *) + +val lognot: t -> t +(** Bitwise logical negation. + The identity [lognot a]=[-a-1] always hold. + *) + +val shift_left: t -> int -> t +(** Shifts to the left. + Equivalent to a multiplication by a power of 2. + The second argument must be nonnegative. + *) + +val shift_right: t -> int -> t +(** Shifts to the right. + This is an arithmetic shift, + equivalent to a division by a power of 2 with rounding towards -oo. + The second argument must be nonnegative. + *) + +val shift_right_trunc: t -> int -> t +(** Shifts to the right, rounding towards 0. + This is equivalent to a division by a power of 2, with truncation. + The second argument must be nonnegative. + *) + +external numbits: t -> int = "ml_z_numbits" [@@noalloc] +(** Returns the number of significant bits in the given number. + If [x] is zero, [numbits x] returns 0. Otherwise, + [numbits x] returns a positive integer [n] such that + [2^{n-1} <= |x| < 2^n]. Note that [numbits] is defined + for negative arguments, and that [numbits (-x) = numbits x]. *) + +external trailing_zeros: t -> int = "ml_z_trailing_zeros" [@@noalloc] +(** Returns the number of trailing 0 bits in the given number. + If [x] is zero, [trailing_zeros x] returns [max_int]. + Otherwise, [trailing_zeros x] returns a nonnegative integer [n] + which is the largest [n] such that [2^n] divides [x] evenly. + Note that [trailing_zeros] is defined for negative arguments, + and that [trailing_zeros (-x) = trailing_zeros x]. *) + +val testbit: t -> int -> bool +(** [testbit x n] return the value of bit number [n] in [x]: + [true] if the bit is 1, [false] if the bit is 0. + Bits are numbered from 0. Raise [Invalid_argument] if [n] + is negative. *) + +external popcount: t -> int = "ml_z_popcount" +(** Counts the number of bits set. + Raises [Overflow] for negative arguments, as those have an infinite + number of bits set. + *) + +external hamdist: t -> t -> int = "ml_z_hamdist" +(** Counts the number of different bits. + Raises [Overflow] if the arguments have different signs + (in which case the distance is infinite). + *) + +(** {1 Conversions} *) + +(** Note that, when converting to an integer type that cannot represent the + converted value, an [Overflow] exception is raised. + *) + +val to_int: t -> int +(** Converts to a base integer. May raise an [Overflow]. *) + +external to_int32: t -> int32 = "ml_z_to_int32" +(** Converts to a 32-bit integer. May raise [Overflow]. *) + +external to_int64: t -> int64 = "ml_z_to_int64" +(** Converts to a 64-bit integer. May raise [Overflow]. *) + +val to_string: t -> string +(** Gives a human-readable, decimal string representation of the argument. *) + +external format: string -> t -> string = "ml_z_format" +(** Gives a string representation of the argument in the specified + printf-like format. + The general specification has the following form: + + [% \[flags\] \[width\] type] + + Where the type actually indicates the base: + + - [i], [d], [u]: decimal + - [b]: binary + - [o]: octal + - [x]: lowercase hexadecimal + - [X]: uppercase hexadecimal + + Supported flags are: + + - [+]: prefix positive numbers with a [+] sign + - space: prefix positive numbers with a space + - [-]: left-justify (default is right justification) + - [0]: pad with zeroes (instead of spaces) + - [#]: alternate formatting (actually, simply output a literal-like prefix: [0x], [0b], [0o]) + + Unlike the classic [printf], all numbers are signed (even hexadecimal ones), + there is no precision field, and characters that are not part of the format + are simply ignored (and not copied in the output). + *) + +external fits_int: t -> bool = "ml_z_fits_int" [@@noalloc] +(** Whether the argument fits in a regular [int]. *) + +external fits_int32: t -> bool = "ml_z_fits_int32" [@@noalloc] +(** Whether the argument fits in an [int32]. *) + +external fits_int64: t -> bool = "ml_z_fits_int64" [@@noalloc] +(** Whether the argument fits in an [int64]. *) + + +(** {1 Printing} *) + +val pp_print: Format.formatter -> t -> unit +(** Prints the argument on the specified formatter. + Can be used as [%a] format printer in [Format.printf] and as + argument to [#install_printer] in the top-level. + *) + + +(** {1 Ordering} *) + +external compare: t -> t -> int = "ml_z_compare" [@@noalloc] +(** Comparison. [compare x y] returns 0 if [x] equals [y], + -1 if [x] is smaller than [y], and 1 if [x] is greater than [y]. + + Note that Pervasive.compare can be used to compare reliably two integers + only on OCaml 3.12.1 and later versions. + *) + +external equal: t -> t -> bool = "ml_z_equal" [@@noalloc] +(** Equality test. *) + +val leq: t -> t -> bool +(** Less than or equal. *) + +val geq: t -> t -> bool +(** Greater than or equal. *) + +val lt: t -> t -> bool +(** Less than (and not equal). *) + +val gt: t -> t -> bool +(** Greater than (and not equal). *) + +external sign: t -> int = "ml_z_sign" [@@noalloc] +(** Returns -1, 0, or 1 when the argument is respectively negative, null, or + positive. + *) + +val min: t -> t -> t +(** Returns the minimum of its arguments. *) + +val max: t -> t -> t +(** Returns the maximum of its arguments. *) + +val is_even: t -> bool +(** Returns true if the argument is even (divisible by 2), false if odd. *) + +val is_odd: t -> bool +(** Returns true if the argument is odd, false if even. *) + +(** {1 Powers} *) + +external pow: t -> int -> t = "ml_z_pow" +(** [pow base exp] raises [base] to the [exp] power. + [exp] must be nonnegative. + Note that only exponents fitting in a machine integer are supported, as + larger exponents would surely make the result's size overflow the + address space. + *) + +external sqrt: t -> t = "ml_z_sqrt" +(** Returns the square root. The result is truncated (rounded down + to an integer). + Raises an [Invalid_argument] on negative arguments. + *) + +external sqrt_rem: t -> (t * t) = "ml_z_sqrt_rem" +(** Returns the square root truncated, and the remainder. + Raises an [Invalid_argument] on negative arguments. + *) + +external root: t -> int -> t = "ml_z_root" +(** [root x n] computes the [n]-th root of [x]. + [n] must be positive and, if [n] is even, then [x] must be nonnegative. + Otherwise, an [Invalid_argument] is raised. + *) + +external rootrem: t -> int -> t * t = "ml_z_rootrem" +(** [rootrem x n] computes the [n]-th root of [x] and the remainder + [x-root**n]. + [n] must be positive and, if [n] is even, then [x] must be nonnegative. + Otherwise, an [Invalid_argument] is raised. + *) + +external perfect_power: t -> bool = "ml_z_perfect_power" +(** True if the argument has the form [a^b], with [b>1] *) + +external perfect_square: t -> bool = "ml_z_perfect_square" +(** True if the argument has the form [a^2]. *) + +val log2: t -> int +(** Returns the base-2 logarithm of its argument, rounded down to + an integer. If [x] is positive, [log2 x] returns the largest [n] + such that [2^n <= x]. If [x] is negative or zero, [log2 x] raise + the [Invalid_argument] exception. *) + +val log2up: t -> int +(** Returns the base-2 logarithm of its argument, rounded up to + an integer. If [x] is positive, [log2up x] returns the smallest [n] + such that [x <= 2^n]. If [x] is negative or zero, [log2up x] raise + the [Invalid_argument] exception. *) + +(** {1 Representation} *) + +external size: t -> int = "ml_z_size" [@@noalloc] +(** Returns the number of machine words used to represent the number. *) + +external extract: t -> int -> int -> t = "ml_z_extract" +(** [extract a off len] returns a nonnegative number corresponding to bits + [off] to [off]+[len]-1 of [b]. + Negative [a] are considered in infinite-length 2's complement + representation. + *) + +val signed_extract: t -> int -> int -> t +(** [signed_extract a off len] extracts bits [off] to [off]+[len]-1 of [b], + as [extract] does, then sign-extends bit [len-1] of the result + (that is, bit [off + len - 1] of [a]). The result is between + [- 2{^[len]-1}] (included) and [2{^[len]-1}] (excluded), + and equal to [extract a off len] modulo [2{^len}]. + *) + +external to_bits: t -> string = "ml_z_to_bits" +(** Returns a binary representation of the argument. + The string result should be interpreted as a sequence of bytes, + corresponding to the binary representation of the absolute value of + the argument in little endian ordering. + The sign is not stored in the string. + *) + +external of_bits: string -> t = "ml_z_of_bits" +(** Constructs a number from a binary string representation. + The string is interpreted as a sequence of bytes in little endian order, + and the result is always positive. + We have the identity: [of_bits (to_bits x) = abs x]. + However, we can have [to_bits (of_bits s) <> s] due to the presence of + trailing zeros in s. + *) diff --git a/src/lib_protocol_environment/structs/dune b/src/lib_protocol_environment/structs/dune index 8ed3961cc077..ec0383e4c673 100644 --- a/src/lib_protocol_environment/structs/dune +++ b/src/lib_protocol_environment/structs/dune @@ -7,7 +7,7 @@ tezos-crypto data-encoding bls12-381-legacy) - (modules V0 V1 V2 V3 V4)) + (modules V0 V1 V2 V3 V4 V5)) (include v0.dune.inc) @@ -18,3 +18,5 @@ (include v3.dune.inc) (include v4.dune.inc) + +(include v5.dune.inc) diff --git a/src/lib_protocol_environment/structs/v5.dune.inc b/src/lib_protocol_environment/structs/v5.dune.inc new file mode 100644 index 000000000000..d25c18e15941 --- /dev/null +++ b/src/lib_protocol_environment/structs/v5.dune.inc @@ -0,0 +1,8 @@ +(rule + (targets v5.ml) + (deps + v4/hex.ml + ) + +(action (with-stdout-to %{targets} (chdir %{workspace_root}} + (run %{libexec:tezos-protocol-environment-packer:s_packer} "structs" %{deps}))))) diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index b18a04d7466e..1abacd349c83 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -551,7 +551,7 @@ module Make (Proto : Registered_protocol.T) = struct let*! (ops_metadata_hashes, block_metadata_hash) = match new_protocol_env_version with | Protocol.V0 -> Lwt.return (None, None) - | Protocol.V1 | Protocol.V2 | Protocol.V3 | Protocol.V4 -> + | Protocol.(V1 | V2 | V3 | V4 | V5) -> Lwt.return ( Some (List.map @@ -663,9 +663,10 @@ module Make (Proto : Registered_protocol.T) = struct testchain genesis block and activation block, even when they are using environment V1, they contain no operations. *) let is_from_genesis = predecessor_shell_header.validation_passes = 0 in - (match Proto.environment_version with - | Protocol.V0 -> false - | Protocol.V1 | Protocol.V2 | Protocol.V3 | Protocol.V4 -> true) + Protocol.( + match Proto.environment_version with + | V0 -> false + | V1 | V2 | V3 | V4 | V5 -> true) && not is_from_genesis in let* context = @@ -891,7 +892,7 @@ module Make (Proto : Registered_protocol.T) = struct let*! (ops_metadata_hashes, block_metadata_hash) = match new_protocol_env_version with | Protocol.V0 -> Lwt.return (None, None) - | Protocol.V1 | Protocol.V2 | Protocol.V3 | Protocol.V4 -> + | Protocol.(V1 | V2 | V3 | V4 | V5) -> Lwt.return ( Some (List.map -- GitLab From 11542528e1b7a46bf18adc4a87de9001ea2e30ff Mon Sep 17 00:00:00 2001 From: Sylvain Ribstein Date: Thu, 16 Dec 2021 16:20:04 +0100 Subject: [PATCH 02/11] env: activate v5 --- src/lib_protocol_compiler/compiler.ml | 2 + src/lib_protocol_compiler/dune | 3 +- src/lib_protocol_compiler/embedded_cmis.mli | 2 + src/lib_protocol_compiler/registerer.ml | 5 ++ src/lib_protocol_compiler/registerer.mli | 5 ++ src/lib_protocol_environment/dune | 1 + .../tezos_protocol_environment.ml | 1 + .../tezos_protocol_environment.mli | 1 + .../registered_protocol.ml | 49 +++++++++++++++++++ .../registered_protocol.mli | 13 +++++ 10 files changed, 81 insertions(+), 1 deletion(-) diff --git a/src/lib_protocol_compiler/compiler.ml b/src/lib_protocol_compiler/compiler.ml index 9f4ace49eecb..c0ada4b1bca5 100644 --- a/src/lib_protocol_compiler/compiler.ml +++ b/src/lib_protocol_compiler/compiler.ml @@ -104,6 +104,8 @@ let tezos_protocol_env = tezos_protocol_environment_sigs__V3_cmi ); ( "Tezos_protocol_environment_sigs__V4", tezos_protocol_environment_sigs__V4_cmi ); + ( "Tezos_protocol_environment_sigs__V5", + tezos_protocol_environment_sigs__V5_cmi ); ] let register_env = diff --git a/src/lib_protocol_compiler/dune b/src/lib_protocol_compiler/dune index 881e2df6d87a..5e2b9ea993c7 100644 --- a/src/lib_protocol_compiler/dune +++ b/src/lib_protocol_compiler/dune @@ -21,7 +21,8 @@ %{lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V1.cmi} %{lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V2.cmi} %{lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V3.cmi} - %{lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V4.cmi}))) + %{lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V4.cmi} + %{lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V5.cmi}))) (library (name tezos_protocol_compiler) diff --git a/src/lib_protocol_compiler/embedded_cmis.mli b/src/lib_protocol_compiler/embedded_cmis.mli index 28a1e3fa043e..89babd16e94c 100644 --- a/src/lib_protocol_compiler/embedded_cmis.mli +++ b/src/lib_protocol_compiler/embedded_cmis.mli @@ -37,4 +37,6 @@ val tezos_protocol_environment_sigs__V3_cmi : string val tezos_protocol_environment_sigs__V4_cmi : string +val tezos_protocol_environment_sigs__V5_cmi : string + val tezos_protocol_registerer__Registerer_cmi : string diff --git a/src/lib_protocol_compiler/registerer.ml b/src/lib_protocol_compiler/registerer.ml index d6ae2a52529d..7b041224de7f 100644 --- a/src/lib_protocol_compiler/registerer.ml +++ b/src/lib_protocol_compiler/registerer.ml @@ -43,6 +43,10 @@ module type PROTOCOL_V4 = functor (Env : Tezos_protocol_environment_sigs.V4.T) -> Env.Updater.PROTOCOL +module type PROTOCOL_V5 = functor + (Env : Tezos_protocol_environment_sigs.V5.T) + -> Env.Updater.PROTOCOL + module VersionTable = Protocol_hash.Table type proto_env = @@ -51,6 +55,7 @@ type proto_env = | V2 of (module PROTOCOL_V2) | V3 of (module PROTOCOL_V3) | V4 of (module PROTOCOL_V4) + | V5 of (module PROTOCOL_V5) let versions : proto_env VersionTable.t = VersionTable.create 20 diff --git a/src/lib_protocol_compiler/registerer.mli b/src/lib_protocol_compiler/registerer.mli index 8bd86bf7d837..0dfe56ba49a1 100644 --- a/src/lib_protocol_compiler/registerer.mli +++ b/src/lib_protocol_compiler/registerer.mli @@ -43,12 +43,17 @@ module type PROTOCOL_V4 = functor (Env : Tezos_protocol_environment_sigs.V4.T) -> Env.Updater.PROTOCOL +module type PROTOCOL_V5 = functor + (Env : Tezos_protocol_environment_sigs.V5.T) + -> Env.Updater.PROTOCOL + type proto_env = | V0 of (module PROTOCOL_V0) | V1 of (module PROTOCOL_V1) | V2 of (module PROTOCOL_V2) | V3 of (module PROTOCOL_V3) | V4 of (module PROTOCOL_V4) + | V5 of (module PROTOCOL_V5) val register : string -> proto_env -> unit diff --git a/src/lib_protocol_environment/dune b/src/lib_protocol_environment/dune index b982b805a894..cc3986aac4a1 100644 --- a/src/lib_protocol_environment/dune +++ b/src/lib_protocol_environment/dune @@ -22,6 +22,7 @@ Environment_V2 Environment_V3 Environment_V4 + Environment_V5 Environment_cache Environment_context Environment_context_intf diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 5423ca6a7d95..9e0343cada0c 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -31,3 +31,4 @@ include Environment_V1 include Environment_V2 include Environment_V3 include Environment_V4 +include Environment_V5 diff --git a/src/lib_protocol_environment/tezos_protocol_environment.mli b/src/lib_protocol_environment/tezos_protocol_environment.mli index a8b45ea7afd8..561062d95ac7 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.mli +++ b/src/lib_protocol_environment/tezos_protocol_environment.mli @@ -32,4 +32,5 @@ include module type of struct include Environment_V2 include Environment_V3 include Environment_V4 + include Environment_V5 end diff --git a/src/lib_protocol_updater/registered_protocol.ml b/src/lib_protocol_updater/registered_protocol.ml index e9b6a868bd25..7ab308959ffe 100644 --- a/src/lib_protocol_updater/registered_protocol.ml +++ b/src/lib_protocol_updater/registered_protocol.ml @@ -141,6 +141,26 @@ let build hash = include P + let complete_b58prefix = Env.Context.complete + end : T) + | Some (V5 protocol) -> + let (module F) = protocol in + let module Name = struct + let name = Protocol_hash.to_b58check hash + end in + let module Env = Tezos_protocol_environment.MakeV5 (Name) () in + Some + (module struct + module Raw = F (Env) + + module P = struct + let hash = hash + + include Env.Lift (Raw) + end + + include P + let complete_b58prefix = Env.Context.complete end : T) @@ -343,3 +363,32 @@ struct include Self end + +module Register_embedded_V5 + (Env : Tezos_protocol_environment.V5) + (Proto : Env.Updater.PROTOCOL) + (Source : Source_sig) = +struct + let hash = + match Source.hash with + | None -> Protocol.hash Source.sources + | Some hash -> hash + + module Self = struct + module P = struct + let hash = hash + + include Env.Lift (Proto) + end + + include P + + let complete_b58prefix = Env.Context.complete + end + + let () = + VersionTable.add sources hash Source.sources ; + VersionTable.add versions hash (module Self : T) + + include Self +end diff --git a/src/lib_protocol_updater/registered_protocol.mli b/src/lib_protocol_updater/registered_protocol.mli index 75ea486d7297..a133a49cec51 100644 --- a/src/lib_protocol_updater/registered_protocol.mli +++ b/src/lib_protocol_updater/registered_protocol.mli @@ -116,3 +116,16 @@ module Register_embedded_V4 and type P.operation_data = Proto.operation_data and type P.operation_receipt = Proto.operation_receipt and type P.validation_state = Proto.validation_state + +module Register_embedded_V5 + (Env : Tezos_protocol_environment.V5) + (Proto : Env.Updater.PROTOCOL) (Source : sig + val hash : Protocol_hash.t option + + val sources : Protocol.t + end) : + T + with type P.block_header_data = Proto.block_header_data + and type P.operation_data = Proto.operation_data + and type P.operation_receipt = Proto.operation_receipt + and type P.validation_state = Proto.validation_state -- GitLab From 8b8519a356093ab6a2c115731d235f54e1ec6cca Mon Sep 17 00:00:00 2001 From: Sylvain Ribstein Date: Thu, 16 Dec 2021 16:20:57 +0100 Subject: [PATCH 03/11] proto: set alpha and demo_noops to use env V5 --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 2 +- src/proto_alpha/lib_protocol/dune.inc | 2 +- src/proto_demo_noops/lib_protocol/TEZOS_PROTOCOL | 2 +- src/proto_demo_noops/lib_protocol/dune.inc | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 21cdd831ad85..f714c8bb3c6c 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -1,5 +1,5 @@ { - "expected_env_version": 4, + "expected_env_version": 5, "hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK", "modules": [ "Misc", diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index 122e58169a5e..9969ca362fd3 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -21,7 +21,7 @@ (action (write-file %{targets} "module Name = struct let name = \"alpha\" end -include Tezos_protocol_environment.MakeV4(Name)() +include Tezos_protocol_environment.MakeV5(Name)() module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end "))) diff --git a/src/proto_demo_noops/lib_protocol/TEZOS_PROTOCOL b/src/proto_demo_noops/lib_protocol/TEZOS_PROTOCOL index 743e0cb60f7c..82548978a0b5 100644 --- a/src/proto_demo_noops/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_demo_noops/lib_protocol/TEZOS_PROTOCOL @@ -1,5 +1,5 @@ { - "expected_env_version": 4, + "expected_env_version": 5, "hash": "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp", "modules": ["Main"] } diff --git a/src/proto_demo_noops/lib_protocol/dune.inc b/src/proto_demo_noops/lib_protocol/dune.inc index 88f9e0a0df0f..42503252f2f6 100644 --- a/src/proto_demo_noops/lib_protocol/dune.inc +++ b/src/proto_demo_noops/lib_protocol/dune.inc @@ -21,7 +21,7 @@ (action (write-file %{targets} "module Name = struct let name = \"demo-noops\" end -include Tezos_protocol_environment.MakeV4(Name)() +include Tezos_protocol_environment.MakeV5(Name)() module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end "))) -- GitLab From 3935ad62c9bc01746efd91875cbba9b0491ccb6b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 18 Dec 2021 00:42:54 +0100 Subject: [PATCH 04/11] lib_context: upgrade to irmin 2.10 --- src/lib_context/context.ml | 12 ++++++------ src/lib_context/encoding/context.ml | 2 ++ src/lib_context/helpers/context.ml | 6 +++--- src/lib_context/memory/context.ml | 2 +- 4 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/lib_context/context.ml b/src/lib_context/context.ml index 28c109b891a1..80b935150c39 100644 --- a/src/lib_context/context.ml +++ b/src/lib_context/context.ml @@ -505,7 +505,7 @@ let close index = Store.Repo.close index.repo let get_branch chain_id = Format.asprintf "%a" Chain_id.pp chain_id let commit_genesis index ~chain_id ~time ~protocol = - let tree = Store.Tree.empty in + let tree = Store.Tree.empty () in let ctxt = {index; tree; parents = []; ops = 0} in (match index.patch_context with | None -> return ctxt @@ -717,7 +717,7 @@ module Dumpable_context = struct aux tree Fun.id >>= fun () -> Lwt.return !total_visited let make_context index = - {index; tree = Store.Tree.empty; parents = []; ops = 0} + {index; tree = Store.Tree.empty (); parents = []; ops = 0} let update_context context tree = {context with tree} @@ -736,10 +736,10 @@ module Dumpable_context = struct let add_dir batch l = let add sub_tree (step, hash) = match sub_tree with - | None -> Lwt.return_some Store.Tree.empty + | None -> Lwt.return_some (Store.Tree.empty ()) | Some sub_tree -> add_hash batch sub_tree [step] hash in - Seq_es.fold_left_s add (Some Store.Tree.empty) l >>=? function + Seq_es.fold_left_s add (Some (Store.Tree.empty ())) l >>=? function | None -> Lwt.return_ok None | Some tree -> let (Batch (repo, x, y)) = batch in @@ -789,7 +789,7 @@ let check_protocol_commit_consistency index ~expected_context_hash let data_merkle_root = Hash.of_context_hash data_merkle_root in let parents = List.map Hash.of_context_hash parents_contexts in let protocol_hash_bytes = Protocol_hash.to_bytes given_protocol_hash in - let tree = Store.Tree.empty in + let tree = Store.Tree.empty () in Store.Tree.add tree current_protocol_key protocol_hash_bytes >>= fun tree -> let test_chain_status_bytes = Data_encoding.Binary.to_bytes_exn @@ -831,7 +831,7 @@ let check_protocol_commit_consistency index ~expected_context_hash if Context_hash.equal expected_context_hash computed_context_hash then let ctxt = let parent = Store.of_private_commit index.repo commit in - {index; tree = Store.Tree.empty; parents = [parent]; ops = 0} + {index; tree = Store.Tree.empty (); parents = [parent]; ops = 0} in add_test_chain ctxt test_chain_status >>= fun ctxt -> add_protocol ctxt given_protocol_hash >>= fun ctxt -> diff --git a/src/lib_context/encoding/context.ml b/src/lib_context/encoding/context.ml index 6703947cbd52..55940161c1f0 100644 --- a/src/lib_context/encoding/context.ml +++ b/src/lib_context/encoding/context.ml @@ -37,6 +37,8 @@ module Conf = struct let entries = 32 let stable_hash = 256 + + let inode_child_order = `Seeded_hash end module Hash : sig diff --git a/src/lib_context/helpers/context.ml b/src/lib_context/helpers/context.ml index b1e4d0c0d15c..afd3905e4630 100644 --- a/src/lib_context/helpers/context.ml +++ b/src/lib_context/helpers/context.ml @@ -41,11 +41,11 @@ module Make_tree (Store : DB) = struct let pp = Irmin.Type.pp Store.tree_t - let empty _ = Store.Tree.empty + let empty _ = Store.Tree.empty () let equal = Irmin.Type.(unstage (equal Store.tree_t)) - let is_empty t = equal Store.Tree.empty t + let is_empty t = equal (Store.Tree.empty ()) t let hash t = Hash.to_context_hash (Store.Tree.hash t) @@ -59,7 +59,7 @@ module Make_tree (Store : DB) = struct | `Contents (c, _) -> Store.Tree.Contents.force_exn c >|= Option.some | `Node _ -> Lwt.return_none - let of_value _ v = Store.Tree.add Store.Tree.empty [] v + let of_value _ v = Store.Tree.add (Store.Tree.empty ()) [] v let fold ?depth t k ~(order : [`Sorted | `Undefined]) ~init ~f = find_tree t k >>= function diff --git a/src/lib_context/memory/context.ml b/src/lib_context/memory/context.ml index d08da2bc92f7..c5bb53e4a696 100644 --- a/src/lib_context/memory/context.ml +++ b/src/lib_context/memory/context.ml @@ -175,7 +175,7 @@ let create () = let cfg = Irmin_pack.config "/tmp" in let promise = Store.Repo.v cfg >>= fun repo -> - Lwt.return {repo; parents = []; tree = Store.Tree.empty} + Lwt.return {repo; parents = []; tree = Store.Tree.empty ()} in match Lwt.state promise with | Lwt.Return result -> result -- GitLab From d9618707cccb46c859d0b913a7b8f646de442a39 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 17 Dec 2021 21:51:20 +0100 Subject: [PATCH 05/11] lib_context: add proofs --- src/lib_context/context.ml | 3 + src/lib_context/helpers/context.ml | 70 ++++++++++++++++++ src/lib_context/helpers/context.mli | 11 +++ src/lib_context/memory/context.ml | 2 + src/lib_context/sigs/context.ml | 107 ++++++++++++++++++++++++++++ 5 files changed, 193 insertions(+) diff --git a/src/lib_context/context.ml b/src/lib_context/context.ml index 80b935150c39..55458036ea18 100644 --- a/src/lib_context/context.ml +++ b/src/lib_context/context.ml @@ -280,6 +280,7 @@ type value = bytes type tree = Store.tree module Tree = Tezos_context_helpers.Context.Make_tree (Store) +module Proof = Tree.Proof let mem ctxt key = Tree.mem ctxt.tree (data_key key) @@ -290,6 +291,8 @@ let raw_find ctxt key = Tree.find ctxt.tree key let list ctxt ?offset ?length key = Tree.list ctxt.tree ?offset ?length (data_key key) +let length ctxt key = Tree.length ctxt.tree key + let find ctxt key = raw_find ctxt (data_key key) let incr_ops ctxt = {ctxt with ops = ctxt.ops + 1} diff --git a/src/lib_context/helpers/context.ml b/src/lib_context/helpers/context.ml index afd3905e4630..abf0aff1f1a6 100644 --- a/src/lib_context/helpers/context.ml +++ b/src/lib_context/helpers/context.ml @@ -39,6 +39,74 @@ module type DB = module Make_tree (Store : DB) = struct include Store.Tree + module Kinded_hash = struct + let of_context_hash = function + | `Contents h -> `Contents (Hash.of_context_hash h, ()) + | `Node h -> `Node (Hash.of_context_hash h) + + let to_context_hash = function + | `Contents (h, ()) -> `Contents (Hash.to_context_hash h) + | `Node h -> `Node (Hash.to_context_hash h) + end + + module Proof = struct + include Tezos_context_sigs.Context.Proof_types + + type t = {before : kinded_hash; after : kinded_hash; state : tree} + + let v ~before ~after state = {before; after; state} + + let before t = t.before + + let after t = t.after + + let state t = t.state + + module State = struct + let rec of_inode : _ Store.Tree.Proof.inode -> _ inode = + fun {length; proofs} -> + {length; proofs = List.map (fun (k, v) -> (k, of_tree_state v)) proofs} + + and of_tree_state : Store.Tree.Proof.tree -> tree = function + | Blinded_node h -> Blinded_node (Hash.to_context_hash h) + | Node l -> Node (List.map (fun (k, v) -> (k, of_tree_state v)) l) + | Inode i -> Inode (of_inode i) + | Blinded_contents (h, ()) -> Blinded_contents (Hash.to_context_hash h) + | Contents (c, ()) -> Contents c + + let rec to_inode : _ inode -> _ Store.Tree.Proof.inode = + fun {length; proofs} -> + {length; proofs = List.map (fun (k, v) -> (k, to_tree_state v)) proofs} + + and to_tree_state : tree -> Store.Tree.Proof.tree = function + | Blinded_node h -> Blinded_node (Hash.of_context_hash h) + | Node l -> Node (List.map (fun (k, v) -> (k, to_tree_state v)) l) + | Inode i -> Inode (to_inode i) + | Blinded_contents h -> Blinded_contents (Hash.of_context_hash h, ()) + | Contents c -> Contents (c, ()) + end + + let of_tree_proof p = + let before = Kinded_hash.to_context_hash (Store.Tree.Proof.before p) in + let after = Kinded_hash.to_context_hash (Store.Tree.Proof.after p) in + let state = State.of_tree_state (Store.Tree.Proof.state p) in + v ~before ~after state + + let to_tree_proof p = + let before = Kinded_hash.of_context_hash p.before in + let after = Kinded_hash.of_context_hash p.after in + let state = State.to_tree_state p.state in + Store.Tree.Proof.v ~before ~after state + end + + let produce_proof repo hash f = + let hash = Kinded_hash.of_context_hash hash in + produce_proof repo hash f >|= Proof.of_tree_proof + + let verify_proof proof f = + let proof = Proof.to_tree_proof proof in + verify_proof proof f + let pp = Irmin.Type.pp Store.tree_t let empty _ = Store.Tree.empty () @@ -166,6 +234,8 @@ module Make_tree (Store : DB) = struct let list tree ?offset ?length key = Store.Tree.list ~cache:true tree ?offset ?length key + let length tree key = Store.Tree.length ~cache:true tree key + exception Context_dangling_hash of string let find_tree tree key = diff --git a/src/lib_context/helpers/context.mli b/src/lib_context/helpers/context.mli index 6cb92ca60e4d..4e4c0e31c3ca 100644 --- a/src/lib_context/helpers/context.mli +++ b/src/lib_context/helpers/context.mli @@ -44,6 +44,12 @@ module Make_tree (DB : DB) : sig and type value := DB.contents and type tree := DB.tree + module Proof : sig + include Tezos_context_sigs.Context.PROOF + + val v : before:kinded_hash -> after:kinded_hash -> tree -> t + end + val pp : Format.formatter -> DB.tree -> unit val empty : _ -> DB.tree @@ -66,6 +72,11 @@ module Make_tree (DB : DB) : sig val shallow : DB.repo -> kinded_hash -> DB.tree + val produce_proof : + repo -> kinded_hash -> (DB.tree -> DB.tree Lwt.t) -> Proof.t Lwt.t + + val verify_proof : Proof.t -> (DB.tree -> DB.tree Lwt.t) -> DB.tree Lwt.t + (** Exception raised by [find_tree] and [add_tree] when applied to shallow trees. It is exposed for so that the memory context can in turn raise it. *) exception Context_dangling_hash of string diff --git a/src/lib_context/memory/context.ml b/src/lib_context/memory/context.ml index c5bb53e4a696..ced87f72a551 100644 --- a/src/lib_context/memory/context.ml +++ b/src/lib_context/memory/context.ml @@ -115,6 +115,8 @@ let mem_tree ctxt key = Tree.mem_tree ctxt.tree (data_key key) let list ctxt ?offset ?length key = Tree.list ctxt.tree ?offset ?length (data_key key) +let length ctxt key = Tree.length ctxt.tree key + let find ctxt key = Tree.find ctxt.tree (data_key key) let raw_add ctxt key data = diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index b189055846ed..29f6dd91ae5b 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -63,6 +63,13 @@ module type VIEW = sig val list : t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t + (** [length t key] is an Lwt promise that resolve to the number of + files and sub-nodes stored under [k] in [t]. + + It is equivalent to [list t k >|= List.length] but has a + constant-time complexity. *) + val length : t -> key -> int Lwt.t + (** {2 Setters} *) (** [add t k v] is an Lwt promise that resolves to [c] such that: @@ -179,9 +186,104 @@ module type HASH_VERSION = sig val set_hash_version : t -> Context_hash.Version.t -> t Lwt.t end +module Proof_types = struct + (** The type for (internal) inode proofs. + + These proofs encode large directories into a more efficient tree-like + structure. + + Invariant are dependent on the backend. + + [length] is the total number of entries in the chidren of the inode. + E.g. the size of the "flattened" version of that inode. This is used + to efficiently implements paginated lists. + + Paths of singleton inodes are compacted into a single inode addressed by + that path (hence the [int list] indexing). + + [proofs] have a length of at most [Conf.entries] entries. This list can + be sparse so every proof is indexed by their position between + [0 ... (Conf.entries-1)]. For binary trees, this boolean + index is a segment of the left-right decision proof corresponding + to the path in that binary tree. *) + type 'a inode = {length : int; proofs : (int list * 'a) list} + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proofs. + + [Blinded_node h] is a shallow pointer to a node having hash [h]. + + [Node ls] is a "flat" node containing the list of files [ls]. The length + of [ls] is at most [Conf.stable_hash]. + + [Inode i] is an optimized representation of a node as a tree. Pointers in + that trees would refer to blinded nodes, nodes or to other inodes. E.g. + Blinded content is not expected to appear directly in an inodes. + + [Blinded_contents h] is a shallow pointer to contents having hash [h]. + + [Contents c] is the contents [c]. *) + type tree = + | Blinded_node of Context_hash.t + | Node of (string * tree) list + | Inode of tree inode + | Blinded_contents of Context_hash.t + | Contents of bytes + + (** The type for kinded hashes. *) + type kinded_hash = [`Contents of Context_hash.t | `Node of Context_hash.t] +end + +module type PROOF = sig + include + module type of Proof_types + with type 'a inode = 'a Proof_types.inode + and type tree = Proof_types.tree + + (** Proofs are compact representations of trees which can be shared + between a node and a client. + + The protocol is the following: + + - The node runs a function [f] over a tree [t]. While performing + this computation, the node records: the hash of [t] (called [before] + below), the hash of [f t] (called [after] below) and a subset of [t] + which is needed to replay [f] without any access to the node's storage. + Once done, the node packs this into a proof [p] and sends this to the + client. + + - The client generates an initial tree [t'] from [p] and computes [f t']. + Once done, it compares [t']'s hash and [f t']'s hash to [before] and + [after]. If they match, they know that the result state [f t'] is a + valid context state, without having to have access to the full node's + storage. *) + + (** The type for proofs. *) + type t + + (** [t] proves that the state advanced from [before t] to [after t]. + [state t]'s hash is [before], and [state t] contains the minimal + information for the computation to reach [after t]. *) + + (** [before t] it the state's hash at the beginning of the computation. *) + val before : t -> kinded_hash + + (** [after t] is the state's hash at the end of the computation. *) + val after : t -> kinded_hash + + (** [proof t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) + val state : t -> tree +end + module type S = sig include VIEW with type key = string list and type value = bytes + module Proof : PROOF + module Tree : sig include TREE @@ -216,5 +318,10 @@ module type S = sig val make_repo : unit -> repo Lwt.t val shallow : repo -> kinded_hash -> tree + + val produce_proof : + repo -> kinded_hash -> (tree -> tree Lwt.t) -> Proof.t Lwt.t + + val verify_proof : Proof.t -> (tree -> tree Lwt.t) -> tree Lwt.t end end -- GitLab From f973e53c7ae59b477cf0b0556fcb04609afb1d0a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 18 Dec 2021 00:04:54 +0100 Subject: [PATCH 06/11] lib_protocol_environment: add context proofs --- src/lib_protocol_environment/dummy_context.ml | 5 + .../environment_V2.ml | 25 ++++- .../environment_V3.ml | 25 ++++- .../environment_V4.ml | 2 + .../environment_context.ml | 59 +++++++++++- .../environment_context.mli | 25 ++++- .../environment_context_intf.ml | 9 ++ .../memory_context.ml | 2 + src/lib_protocol_environment/proxy_context.ml | 12 +++ src/lib_protocol_environment/shell_context.ml | 2 + .../sigs/v4/context.mli | 94 +++++++++++++++++++ 11 files changed, 248 insertions(+), 12 deletions(-) diff --git a/src/lib_protocol_environment/dummy_context.ml b/src/lib_protocol_environment/dummy_context.ml index 351abe5ab6f5..4be1e1ab91ec 100644 --- a/src/lib_protocol_environment/dummy_context.ml +++ b/src/lib_protocol_environment/dummy_context.ml @@ -67,10 +67,13 @@ module M = struct let list _ ?offset:_ ?length:_ _ = assert false + let length _ _ = assert false + let fold ?depth:_ _ _ ~order:_ ~init:_ ~f:_ = assert false end include Tree + module Proof = Memory_context.M.Proof let set_protocol _ _ = assert false @@ -81,6 +84,8 @@ module M = struct let set_hash_version _ _ = assert false let get_hash_version _ = assert false + + let verify_proof _ _ = assert false end open Tezos_protocol_environment diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index e7df84b4ef73..b2fd413936a3 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -917,7 +917,30 @@ struct type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] module type VIEW = sig - include Environment_context.VIEW + type t + + type key + + type value + + type tree + + val mem : t -> key -> bool Lwt.t + + val mem_tree : t -> key -> bool Lwt.t + + val find : t -> key -> value option Lwt.t + + val find_tree : t -> key -> tree option Lwt.t + + val list : + t -> ?offset:int -> ?length:int -> key -> (string * tree) trace Lwt.t + + val add : t -> key -> value -> t Lwt.t + + val add_tree : t -> key -> tree -> t Lwt.t + + val remove : t -> key -> t Lwt.t val fold : ?depth:depth -> diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 1a5c95f71c81..00f82a346934 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -1037,7 +1037,30 @@ struct type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] module type VIEW = sig - include Environment_context.VIEW + type t + + type key + + type value + + type tree + + val mem : t -> key -> bool Lwt.t + + val mem_tree : t -> key -> bool Lwt.t + + val find : t -> key -> value option Lwt.t + + val find_tree : t -> key -> tree option Lwt.t + + val list : + t -> ?offset:int -> ?length:int -> key -> (string * tree) trace Lwt.t + + val add : t -> key -> value -> t Lwt.t + + val add_tree : t -> key -> tree -> t Lwt.t + + val remove : t -> key -> t Lwt.t val fold : ?depth:depth -> diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index 87506ccced7b..558d380afd0e 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -1070,6 +1070,8 @@ struct module type VIEW = Environment_context.VIEW + module type PROOF = Environment_context.PROOF + module Kind = struct type t = [`Value | `Tree] end diff --git a/src/lib_protocol_environment/environment_context.ml b/src/lib_protocol_environment/environment_context.ml index 069383c9860a..838fe2ee37c8 100644 --- a/src/lib_protocol_environment/environment_context.ml +++ b/src/lib_protocol_environment/environment_context.ml @@ -38,6 +38,8 @@ module type VIEW = Environment_context_intf.VIEW module type TREE = Environment_context_intf.TREE +module type PROOF = Environment_context_intf.PROOF + module type CACHE = Environment_context_intf.CACHE module Equality_witness : sig @@ -85,8 +87,11 @@ module Context = struct type value = Bytes.t - type ('ctxt, 'tree) ops = - (module CONTEXT with type t = 'ctxt and type tree = 'tree) + type ('ctxt, 'tree, 'proof) ops = + (module CONTEXT + with type t = 'ctxt + and type tree = 'tree + and type Proof.t = 'proof) type _ kind = .. @@ -109,7 +114,7 @@ module Context = struct kind : 'a kind; impl_name : string; ctxt : 'a; - ops : ('a, 'b) ops; + ops : ('a, 'b, 'c) ops; equality_witness : ('a, 'b) equality_witness; cache : cache; } @@ -139,7 +144,7 @@ module Context = struct (* trees *) type tree = | Tree : { - ops : ('a, 'b) ops; + ops : ('a, 'b, 'c) ops; impl_name : string; tree : 'b; equality_witness : ('a, 'b) equality_witness; @@ -173,6 +178,8 @@ module Context = struct [] (List.rev ls) + let length (Context {ops = (module Ops); ctxt; _}) key = Ops.length ctxt key + let fold ?depth (Context {ops = (module Ops) as ops; ctxt; equality_witness; impl_name; _}) key @@ -244,6 +251,9 @@ module Context = struct [] (List.rev ls) + let length (Tree {ops = (module Ops); tree; _}) key = + Ops.Tree.length tree key + let fold ?depth (Tree {ops = (module Ops) as ops; tree = t; equality_witness; impl_name}) @@ -256,6 +266,41 @@ module Context = struct Ops.Tree.clear ?depth tree end + (* Proof *) + module Proof = struct + include Tezos_context_sigs.Context.Proof_types + + type t = + | Proof : { + ops : ('a, 'b, 'c) ops; + proof : 'c; + equality_witness : ('a, 'b) equality_witness; + impl_name : string; + } + -> t + + let before (Proof {ops = (module Ops); proof; _}) = Ops.Proof.before proof + + let after (Proof {ops = (module Ops); proof; _}) = Ops.Proof.after proof + + let state (Proof {ops = (module Ops); proof; _}) = Ops.Proof.state proof + end + + let proof ~impl_name ~proof ~ops ~equality_witness = + Proof.Proof {ops; proof; equality_witness; impl_name} + + let verify_proof + (Proof.Proof + {ops = (module Ops) as ops; proof; equality_witness; impl_name}) + (f : tree -> tree Lwt.t) : tree Lwt.t = + Ops.verify_proof proof (fun tree -> + let v = Tree {ops; tree; equality_witness; impl_name} in + f v >|= fun (Tree t) -> + match equiv equality_witness t.equality_witness with + | (Some Refl, Some Refl) -> (t.tree : Ops.tree) + | _ -> err_implementation_mismatch ~expected:impl_name ~got:t.impl_name) + >|= fun tree -> Tree {ops; tree; equality_witness; impl_name} + type cache_key = Environment_cache.key type block_cache = {context_hash : Context_hash.t; cache : cache} @@ -586,7 +631,11 @@ module Register (C : CONTEXT) = struct let equality_witness : (C.t, C.tree) Context.equality_witness = Context.equality_witness () - let ops = (module C : CONTEXT with type t = 'ctxt and type tree = 'tree) + let ops = + (module C : CONTEXT + with type t = 'ctxt + and type tree = 'tree + and type Proof.t = 'proof) end type validation_result = { diff --git a/src/lib_protocol_environment/environment_context.mli b/src/lib_protocol_environment/environment_context.mli index e5cfe0a6d2ef..134d724d09d3 100644 --- a/src/lib_protocol_environment/environment_context.mli +++ b/src/lib_protocol_environment/environment_context.mli @@ -38,6 +38,11 @@ module type TREE = sig include Environment_context_intf.TREE end +module type PROOF = sig + (** @inline *) + include Environment_context_intf.PROOF +end + module type CACHE = sig (** @inline *) include Environment_context_intf.CACHE @@ -56,8 +61,11 @@ module Equality_witness : sig end module Context : sig - type ('ctxt, 'tree) ops = - (module CONTEXT with type t = 'ctxt and type tree = 'tree) + type ('ctxt, 'tree, 'proof) ops = + (module CONTEXT + with type t = 'ctxt + and type tree = 'tree + and type Proof.t = 'proof) type _ kind = private .. @@ -81,7 +89,7 @@ module Context : sig kind : 'a kind; impl_name : string; ctxt : 'a; - ops : ('a, 'b) ops; + ops : ('a, 'b, _) ops; equality_witness : ('a, 'b) equality_witness; cache : cache; } @@ -98,10 +106,17 @@ module Context : sig kind:'a kind -> impl_name:string -> ctxt:'a -> - ops:('a, 'b) ops -> + ops:('a, 'b, _) ops -> equality_witness:('a, 'b) equality_witness -> t + val proof : + impl_name:string -> + proof:'c -> + ops:('a, 'b, 'c) ops -> + equality_witness:('a, 'b) equality_witness -> + Proof.t + (** A key uniquely identifies a cached [value] in the some subcache. *) type cache_key @@ -198,7 +213,7 @@ module Register (C : CONTEXT) : sig val equality_witness : (C.t, C.tree) Context.equality_witness - val ops : (C.t, C.tree) Context.ops + val ops : (C.t, C.tree, C.Proof.t) Context.ops end type validation_result = { diff --git a/src/lib_protocol_environment/environment_context_intf.ml b/src/lib_protocol_environment/environment_context_intf.ml index b9278ef3014a..dc5b83f56494 100644 --- a/src/lib_protocol_environment/environment_context_intf.ml +++ b/src/lib_protocol_environment/environment_context_intf.ml @@ -35,6 +35,11 @@ module type TREE = sig include Tezos_context_sigs.Context.TREE end +module type PROOF = sig + (** @inline *) + include Tezos_context_sigs.Context.PROOF +end + module type HASH_VERSION = sig (** @inline *) include Tezos_context_sigs.Context.HASH_VERSION @@ -43,6 +48,8 @@ end module type S = sig include VIEW with type key = string list and type value = bytes + module Proof : PROOF + module Tree : sig include TREE @@ -64,6 +71,8 @@ module type S = sig val set_hash_version : t -> Context_hash.Version.t -> t tzresult Lwt.t val get_hash_version : t -> Context_hash.Version.t + + val verify_proof : Proof.t -> (tree -> tree Lwt.t) -> tree Lwt.t end (* Copy of sigs/v3/context.mli:CACHE *) diff --git a/src/lib_protocol_environment/memory_context.ml b/src/lib_protocol_environment/memory_context.ml index 498f54f5ea9e..15a7aea85f8a 100644 --- a/src/lib_protocol_environment/memory_context.ml +++ b/src/lib_protocol_environment/memory_context.ml @@ -30,6 +30,8 @@ module M = struct let set_protocol = add_protocol let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c + + let verify_proof = Tree.verify_proof end open Tezos_protocol_environment diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index 5aa3c1bce800..bccf206b1680 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -182,6 +182,8 @@ module C = struct let list t ?offset ?length k = data_tree t >>= fun tree -> raw_list tree ?offset ?length k + let length t k = data_tree t >>= fun t -> Local.Tree.length t.tree k + let fold ?depth (t : t) root ~order ~init ~f = find_tree t root >>= function | None -> Lwt.return init @@ -256,8 +258,18 @@ module C = struct let list = raw_list + let length t k = Local.Tree.length t.tree k + let clear ?depth t = Local.Tree.clear ?depth t.tree end + + module Proof = Local.Proof + + let verify_proof proof f = + let of_local tree = {proxy = None; path = []; tree} in + Local.Tree.verify_proof proof (fun tree -> + f (of_local tree) >|= fun t -> t.tree) + >|= of_local end open Tezos_protocol_environment diff --git a/src/lib_protocol_environment/shell_context.ml b/src/lib_protocol_environment/shell_context.ml index 47b668f6aa4d..7c9f247d7084 100644 --- a/src/lib_protocol_environment/shell_context.ml +++ b/src/lib_protocol_environment/shell_context.ml @@ -31,6 +31,8 @@ module C = struct include Tezos_context.Context let set_protocol = add_protocol + + let verify_proof = Tree.verify_proof end include Environment_context.Register (C) diff --git a/src/lib_protocol_environment/sigs/v4/context.mli b/src/lib_protocol_environment/sigs/v4/context.mli index 6114a50ed394..f6fa95056e57 100644 --- a/src/lib_protocol_environment/sigs/v4/context.mli +++ b/src/lib_protocol_environment/sigs/v4/context.mli @@ -67,6 +67,13 @@ module type VIEW = sig val list : t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t + (** [length t key] is an Lwt promise that resolve to the number of + files and sub-nodes stored under [k] in [t]. + + It is equivalent to [list t k >|= List.length] but has a + constant-time complexity. *) + val length : t -> key -> int Lwt.t + (** {2 Setters} *) (** [add t k v] is an Lwt promise that resolves to [c] such that: @@ -119,6 +126,91 @@ module type VIEW = sig 'a Lwt.t end +module Proof : sig + (** Proofs are compact representations of trees which can be shared + between a node and a client. + + The protocol is the following: + + - The node runs a function [f] over a tree [t]. While performing + this computation, the node records: the hash of [t] (called [before] + below), the hash of [f t] (called [after] below) and a subset of [t] + which is needed to replay [f] without any access to the node's storage. + Once done, the node packs this into a proof [p] and sends this to the + client. + + - The client generates an initial tree [t'] from [p] and computes [f t']. + Once done, it compares [t']'s hash and [f t']'s hash to [before] and + [after]. If they match, they know that the result state [f t'] is a + valid context state, without having to have access to the full node's + storage. *) + + (** The type for (internal) inode proofs. + + These proofs encode large directories into a more efficient tree-like + structure. + + Invariant are dependent on the backend. + + [length] is the total number of entries in the chidren of the inode. + E.g. the size of the "flattened" version of that inode. This is used + to efficiently implements paginated lists. + + Paths of singleton inodes are compacted into a single inode addressed by + that path (hence the [int list] indexing). + + [proofs] have a length of at most [Conf.entries] entries. This list can + be sparse so every proof is indexed by their position between + [0 ... (Conf.entries-1)]. For binary trees, this boolean + index is a segment of the left-right decision proof corresponding + to the path in that binary tree. *) + type 'a inode = {length : int; proofs : (int list * 'a) list} + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proofs. + + [Blinded_node h] is a shallow pointer to a node having hash [h]. + + [Node ls] is a "flat" node containing the list of files [ls]. The length + of [ls] is at most [Conf.stable_hash]. + + [Inode i] is an optimized representation of a node as a tree. Pointers in + that trees would refer to blinded nodes, nodes or to other inodes. E.g. + Blinded content is not expected to appear directly in an inodes. + + [Blinded_contents h] is a shallow pointer to contents having hash [h]. + + [Contents c] is the contents [c]. *) + type tree = + | Blinded_node of Context_hash.t + | Node of (string * tree) list + | Inode of tree inode + | Blinded_contents of Context_hash.t + | Contents of bytes + + type t + + (** The type for kinded hashes. *) + type kinded_hash = [`Contents of Context_hash.t | `Node of Context_hash.t] + + (** A proof [p] proves that the state advanced from [before p] to + [after p]. [state p]'s hash is [before p], and [state p] contains + the minimal information for the computation to reach [after p]. *) + + (** [before t] it the state's hash at the beginning of the computation. *) + val before : t -> kinded_hash + + (** [after t] is the state's hash at the end of the computation. *) + val after : t -> kinded_hash + + (** [proof t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) + val state : t -> tree +end + module Kind : sig type t = [`Value | `Tree] end @@ -183,6 +275,8 @@ module Tree : and type value := value and type tree := tree +val verify_proof : Proof.t -> (tree -> tree Lwt.t) -> tree Lwt.t + val register_resolver : 'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit -- GitLab From e218bb5b6a8d5538def186c82ac1812376e21eac Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 18 Dec 2021 00:15:49 +0100 Subject: [PATCH 07/11] proto_alpha: add context proofs to the protocol --- src/proto_alpha/lib_protocol/raw_context.ml | 6 ++ .../lib_protocol/raw_context_intf.ml | 92 +++++++++++++++++++ .../lib_protocol/storage_functors.ml | 13 +++ 3 files changed, 111 insertions(+) diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index f4199953be4a..b36a4dfd0bda 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1017,9 +1017,13 @@ let add_or_remove_tree ctxt k = function let list ctxt ?offset ?length k = Context.list (context ctxt) ?offset ?length k +let length ctxt k = Context.length (context ctxt) k + let fold ?depth ctxt k ~order ~init ~f = Context.fold ?depth (context ctxt) k ~order ~init ~f +module Proof = Context.Proof + module Tree : Raw_context_intf.TREE with type t := t @@ -1079,6 +1083,8 @@ module Tree : | Some v -> add_tree t k v end +let verify_proof proof f = Context.verify_proof proof f + let project x = x let absolute_key _ k = k diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index dc1817f0a2d6..ab31edd229c8 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -75,6 +75,8 @@ module type VIEW = sig val list : t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t + val length : t -> key -> int Lwt.t + (** {2 Setters} *) (** [init t k v] is an Lwt promise that resolves to [Ok c] if: @@ -220,6 +222,92 @@ module type TREE = sig val clear : ?depth:int -> tree -> unit end +module type PROOF = sig + (** The type for (internal) inode proofs. + + These proofs encode large directories into a more efficient tree-like + structure. + + Invariant are dependent on the backend. + + [length] is the total number of entries in the chidren of the inode. + E.g. the size of the "flattened" version of that inode. This is used + to efficiently implements paginated lists. + + Paths of singleton inodes are compacted into a single inode addressed by + that path (hence the [int list] indexing). + + [proofs] have a length of at most [Conf.entries] entries. This list can + be sparse so every proof is indexed by their position between + [0 ... (Conf.entries-1)]. For binary trees, this boolean + index is a segment of the left-right decision proof corresponding + to the path in that binary tree. *) + type 'a inode = {length : int; proofs : (int list * 'a) list} + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proofs. + + [Blinded_node h] is a shallow pointer to a node having hash [h]. + + [Node ls] is a "flat" node containing the list of files [ls]. The length + of [ls] is at most [Conf.stable_hash]. + + [Inode i] is an optimized representation of a node as a tree. Pointers in + that trees would refer to blinded nodes, nodes or to other inodes. E.g. + Blinded content is not expected to appear directly in an inodes. + + [Blinded_contents h] is a shallow pointer to contents having hash [h]. + + [Contents c] is the contents [c]. *) + type tree = + | Blinded_node of Context_hash.t + | Node of (string * tree) list + | Inode of tree inode + | Blinded_contents of Context_hash.t + | Contents of bytes + + (** The type for kinded hashes. *) + type kinded_hash = [`Contents of Context_hash.t | `Node of Context_hash.t] + + (** Proofs are compact representations of trees which can be shared + between a node and a client. + + The protocol is the following: + + - The node runs a function [f] over a tree [t]. While performing + this computation, the node records: the hash of [t] (called [before] + below), the hash of [f t] (called [after] below) and a subset of [t] + which is needed to replay [f] without any access to the node's storage. + Once done, the node packs this into a proof [p] and sends this to the + client. + + - The client generates an initial tree [t'] from [p] and computes [f t']. + Once done, it compares [t']'s hash and [f t']'s hash to [before] and + [after]. If they match, they know that the result state [f t'] is a + valid context state, without having to have access to the full node's + storage. *) + + (** The type for proofs. *) + type t + + (** [t] proves that the state advanced from [before t] to [after t]. + [state t]'s hash is [before], and [state t] contains the minimal + information for the computation to reach [after t]. *) + + (** [before t] it the state's hash at the beginning of the computation. *) + val before : t -> kinded_hash + + (** [after t] is the state's hash at the end of the computation. *) + val after : t -> kinded_hash + + (** [proof t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) + val state : t -> tree +end + module type T = sig (** The type for root contexts. *) type root @@ -233,6 +321,10 @@ module type T = sig and type value := value and type tree := tree + module Proof : PROOF + + val verify_proof : Proof.t -> (tree -> tree Lwt.t) -> tree Lwt.t + (** Internally used in {!Storage_functors} to escape from a view. *) val project : t -> root diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 48a611f95b88..1419b8e9d540 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -109,10 +109,15 @@ module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : let list t ?offset ?length k = C.list t ?offset ?length (to_key k) + let length t k = C.length t k + let fold ?depth t k ~order ~init ~f = C.fold ?depth t (to_key k) ~order ~init ~f module Tree = C.Tree + module Proof = C.Proof + + let verify_proof = C.verify_proof let project = C.project @@ -720,6 +725,10 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let (t, i) = unpack c in C.list t ?offset ?length (to_key i k) + let length c k = + let (t, i) = unpack c in + C.length t (to_key i k) + let init c k v = let (t, i) = unpack c in C.init t (to_key i k) v >|=? fun t -> pack t i @@ -776,6 +785,10 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : C.Tree.empty t end + module Proof = C.Proof + + let verify_proof = C.verify_proof + let project c = let (t, _) = unpack c in C.project t -- GitLab From bfcd6d2750eed6d415f97fd7c569fceffd22d63c Mon Sep 17 00:00:00 2001 From: Sylvain Ribstein Date: Fri, 17 Dec 2021 08:15:43 +0100 Subject: [PATCH 08/11] doc: update protocol environment upgrade with --- docs/developer/protocol_environment_upgrade.rst | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/docs/developer/protocol_environment_upgrade.rst b/docs/developer/protocol_environment_upgrade.rst index 02bf8312c1da..7dcd26239063 100644 --- a/docs/developer/protocol_environment_upgrade.rst +++ b/docs/developer/protocol_environment_upgrade.rst @@ -13,7 +13,7 @@ This page details the process of creating a new environment by copying the lates Bootstrap --------- -The following steps are roughly the steps taken in the `V4 bootstrap MR `__ +The following steps are roughly the steps taken in the `V5 bootstrap MR `__ 1. Copy the existing environment files: @@ -35,11 +35,18 @@ The following steps are roughly the steps taken in the `V4 bootstrap MR .ml[i]`` to ``src/lib_protocol_environment/environment_V.ml[i]`` - * Copy ``environment_protocol_T_V.ml`` to ``environment_protocol_T_V.ml`` + * Change any reference from ``V`` to ``V`` in all those copied files the - * Change any reference from ``V`` to ``V`` in all those copied files +5. If the protocol signature is expected to change then copy and adapt it otherwise leave it as is: -5. Add references to the new environment version number in the rest of the code: + ``Environment_protocol_T_V`` is the current protocol signature and ```` is equal to the environment version that introduce it. + + * Copy ``src/lib_protocol_environment/environment_protocol_T_V.ml`` to ``src/lib_protocol_environment/environment_protocol_T_V.ml`` + + * Change ``Environment_protocol_T_V`` to ``Environment_protocol_T_V`` in ``src/lib_protocol_environment/environment_V.ml`` + + +6. Add references to the new environment version number in the rest of the code: * Add references to ``src/lib_base/protocol.ml[i]`` @@ -84,9 +91,11 @@ How to activate To activate the environment you will need to change the following files, adding references to ``V`` to match the references to ``V``: * ``src/lib_protocol_environment/tezos_protocol_environment.ml[i]`` +* ``src/lib_protocol_environment/dune`` * ``src/lib_protocol_updater/registered_protocol.ml[i]`` * ``src/lib_protocol_compiler/registerer.ml[i]`` * ``src/lib_protocol_compiler/embedded_cmis.mli`` +* ``src/lib_protocol_compiler/compiler.ml`` * ``src/lib_protocol_compiler/dune`` And finally, bump environment version in ``src/proto_alpha/lib_protocol/dune.inc`` and ``src/proto_alpha/lib_protocol/TEZOS_PROTOCOL``. -- GitLab From ede72af327e044f3ce3b5d1bcfb94a4e73de7d55 Mon Sep 17 00:00:00 2001 From: Sylvain Ribstein Date: Fri, 17 Dec 2021 08:24:29 +0100 Subject: [PATCH 09/11] shell: add description to the protocol metadata --- src/lib_base/protocol.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/lib_base/protocol.ml b/src/lib_base/protocol.ml index 9e734572ed80..f1acc97ab5aa 100644 --- a/src/lib_base/protocol.ml +++ b/src/lib_base/protocol.ml @@ -140,8 +140,11 @@ module Meta = struct let encoding = let open Data_encoding in - def "protocol.meta" - (* FIXME: add ~description argument *) + def + "protocol.meta" + ~description: + "Protocol metadata: the hash of the protocol, the expected environment \ + version and the list of modules comprising the protocol." @@ conv (fun {hash; expected_env_version; modules} -> (hash, expected_env_version, modules)) -- GitLab From bc1271b6a288048964939e4aa1c844b3d84db2a3 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 18 Dec 2021 00:16:33 +0100 Subject: [PATCH 10/11] WIP: vendor irmin 2.10 --- irmin-layers.opam | 25 + irmin-pack.opam | 35 + irmin.opam | 48 + vendor-irmin.sh | 15 + vendors/irmin/irmin-layers/dune | 6 + vendors/irmin/irmin-layers/import.ml | 17 + vendors/irmin/irmin-layers/irmin_layers.ml | 96 + vendors/irmin/irmin-layers/irmin_layers.mli | 18 + .../irmin/irmin-layers/irmin_layers_intf.ml | 166 ++ vendors/irmin/irmin-layers/stats.ml | 326 +++ vendors/irmin/irmin-layers/stats.mli | 75 + vendors/irmin/irmin-pack/IO.ml | 349 +++ vendors/irmin/irmin-pack/IO.mli | 18 + vendors/irmin/irmin-pack/IO_intf.ml | 74 + vendors/irmin/irmin-pack/atomic_write.ml | 313 +++ vendors/irmin/irmin-pack/atomic_write.mli | 17 + vendors/irmin/irmin-pack/atomic_write_intf.ml | 46 + vendors/irmin/irmin-pack/checks.ml | 398 ++++ vendors/irmin/irmin-pack/checks.mli | 20 + vendors/irmin/irmin-pack/checks_intf.ml | 144 ++ vendors/irmin/irmin-pack/conf.ml | 131 ++ vendors/irmin/irmin-pack/conf.mli | 58 + .../irmin/irmin-pack/content_addressable.ml | 83 + .../irmin/irmin-pack/content_addressable.mli | 17 + .../irmin-pack/content_addressable_intf.ml | 60 + vendors/irmin/irmin-pack/dict.ml | 124 + vendors/irmin/irmin-pack/dict.mli | 18 + vendors/irmin/irmin-pack/dict_intf.ml | 37 + vendors/irmin/irmin-pack/dune | 7 + vendors/irmin/irmin-pack/ext.ml | 249 ++ vendors/irmin/irmin-pack/ext.mli | 21 + vendors/irmin/irmin-pack/import.ml | 32 + vendors/irmin/irmin-pack/inode.ml | 1670 ++++++++++++++ vendors/irmin/irmin-pack/inode.mli | 18 + vendors/irmin/irmin-pack/inode_intf.ml | 189 ++ vendors/irmin/irmin-pack/irmin_pack.ml | 56 + vendors/irmin/irmin-pack/irmin_pack.mli | 18 + vendors/irmin/irmin-pack/irmin_pack_intf.ml | 84 + vendors/irmin/irmin-pack/layered/IO_layers.ml | 94 + .../irmin/irmin-pack/layered/IO_layers.mli | 37 + vendors/irmin/irmin-pack/layered/checks.ml | 212 ++ vendors/irmin/irmin-pack/layered/conf.ml | 70 + vendors/irmin/irmin-pack/layered/conf.mli | 35 + vendors/irmin/irmin-pack/layered/dune | 6 + .../irmin/irmin-pack/layered/ext_layered.ml | 865 +++++++ .../irmin/irmin-pack/layered/ext_layered.mli | 20 + vendors/irmin/irmin-pack/layered/import.ml | 26 + .../irmin/irmin-pack/layered/inode_layers.ml | 111 + .../irmin/irmin-pack/layered/inode_layers.mli | 18 + .../irmin-pack/layered/inode_layers_intf.ml | 92 + .../irmin-pack/layered/irmin_pack_layered.ml | 28 + .../irmin-pack/layered/irmin_pack_layered.mli | 53 + .../irmin/irmin-pack/layered/layered_store.ml | 538 +++++ .../irmin-pack/layered/layered_store.mli | 49 + vendors/irmin/irmin-pack/layered/layout.ml | 19 + vendors/irmin/irmin-pack/layered/s.ml | 173 ++ vendors/irmin/irmin-pack/layout.ml | 21 + vendors/irmin/irmin-pack/layout.mli | 28 + .../irmin-pack/mem/content_addressable.ml | 148 ++ .../irmin-pack/mem/content_addressable.mli | 29 + vendors/irmin/irmin-pack/mem/dune | 6 + vendors/irmin/irmin-pack/mem/import.ml | 24 + .../irmin/irmin-pack/mem/irmin_pack_mem.ml | 159 ++ .../irmin/irmin-pack/mem/irmin_pack_mem.mli | 22 + vendors/irmin/irmin-pack/migrate.ml | 65 + vendors/irmin/irmin-pack/migrate.mli | 17 + vendors/irmin/irmin-pack/pack_dict.ml | 35 + vendors/irmin/irmin-pack/pack_dict.mli | 23 + vendors/irmin/irmin-pack/pack_index.ml | 69 + vendors/irmin/irmin-pack/pack_index.mli | 18 + vendors/irmin/irmin-pack/pack_index_intf.ml | 45 + vendors/irmin/irmin-pack/pack_store.ml | 328 +++ vendors/irmin/irmin-pack/pack_store.mli | 2 + vendors/irmin/irmin-pack/pack_store_intf.ml | 59 + vendors/irmin/irmin-pack/pack_value.ml | 67 + vendors/irmin/irmin-pack/pack_value.mli | 2 + vendors/irmin/irmin-pack/pack_value_intf.ml | 52 + vendors/irmin/irmin-pack/s.ml | 106 + vendors/irmin/irmin-pack/stats.ml | 60 + vendors/irmin/irmin-pack/stats.mli | 46 + .../irmin/irmin-pack/traverse_pack_file.ml | 334 +++ vendors/irmin/irmin-pack/utils.ml | 140 ++ vendors/irmin/irmin-pack/version.ml | 56 + vendors/irmin/irmin-pack/version.mli | 41 + vendors/irmin/irmin/branch.ml | 36 + vendors/irmin/irmin/branch.mli | 20 + vendors/irmin/irmin/branch_intf.ml | 62 + vendors/irmin/irmin/commit.ml | 528 +++++ vendors/irmin/irmin/commit.mli | 27 + vendors/irmin/irmin/commit_intf.ml | 210 ++ vendors/irmin/irmin/conf.ml | 128 + vendors/irmin/irmin/conf.mli | 138 ++ vendors/irmin/irmin/contents.ml | 238 ++ vendors/irmin/irmin/contents.mli | 20 + vendors/irmin/irmin/contents_intf.ml | 92 + vendors/irmin/irmin/diff.ml | 18 + vendors/irmin/irmin/diff.mli | 19 + vendors/irmin/irmin/dot.ml | 212 ++ vendors/irmin/irmin/dot.mli | 45 + vendors/irmin/irmin/dune | 7 + vendors/irmin/irmin/export_for_backends.ml | 18 + vendors/irmin/irmin/hash.ml | 99 + vendors/irmin/irmin/hash.mli | 17 + vendors/irmin/irmin/hash_intf.ml | 93 + vendors/irmin/irmin/import.ml | 123 + vendors/irmin/irmin/info.ml | 30 + vendors/irmin/irmin/info.mli | 59 + vendors/irmin/irmin/irmin.ml | 424 ++++ vendors/irmin/irmin/irmin.mli | 593 +++++ vendors/irmin/irmin/lock.ml | 66 + vendors/irmin/irmin/lock.mli | 37 + vendors/irmin/irmin/lru.ml | 124 + vendors/irmin/irmin/lru.mli | 24 + vendors/irmin/irmin/mem/dune | 4 + vendors/irmin/irmin/mem/import.ml | 1 + vendors/irmin/irmin/mem/irmin_mem.ml | 146 ++ vendors/irmin/irmin/mem/irmin_mem.mli | 40 + vendors/irmin/irmin/merge.ml | 421 ++++ vendors/irmin/irmin/merge.mli | 235 ++ vendors/irmin/irmin/node.ml | 496 ++++ vendors/irmin/irmin/node.mli | 27 + vendors/irmin/irmin/node_intf.ml | 327 +++ vendors/irmin/irmin/object_graph.ml | 253 ++ vendors/irmin/irmin/object_graph.mli | 19 + vendors/irmin/irmin/object_graph_intf.ml | 124 + vendors/irmin/irmin/path.ml | 48 + vendors/irmin/irmin/path.mli | 20 + vendors/irmin/irmin/path_intf.ml | 67 + vendors/irmin/irmin/perms.ml | 65 + vendors/irmin/irmin/private.ml | 73 + vendors/irmin/irmin/proof.ml | 209 ++ vendors/irmin/irmin/proof.mli | 17 + vendors/irmin/irmin/proof_intf.ml | 220 ++ vendors/irmin/irmin/s.ml | 226 ++ vendors/irmin/irmin/slice.ml | 58 + vendors/irmin/irmin/slice.mli | 18 + vendors/irmin/irmin/slice_intf.ml | 72 + vendors/irmin/irmin/store.ml | 1202 ++++++++++ vendors/irmin/irmin/store.mli | 21 + vendors/irmin/irmin/store_intf.ml | 1035 +++++++++ vendors/irmin/irmin/sync.ml | 33 + vendors/irmin/irmin/sync.mli | 19 + vendors/irmin/irmin/sync_ext.ml | 218 ++ vendors/irmin/irmin/sync_ext.mli | 19 + vendors/irmin/irmin/sync_ext_intf.ml | 96 + vendors/irmin/irmin/sync_intf.ml | 65 + vendors/irmin/irmin/tree.ml | 2053 +++++++++++++++++ vendors/irmin/irmin/tree.mli | 19 + vendors/irmin/irmin/tree_intf.ml | 435 ++++ vendors/irmin/irmin/type.ml | 17 + vendors/irmin/irmin/type.mli | 18 + vendors/irmin/irmin/version.ml | 1 + vendors/irmin/irmin/watch.ml | 328 +++ vendors/irmin/irmin/watch.mli | 20 + vendors/irmin/irmin/watch_intf.ml | 96 + 155 files changed, 21914 insertions(+) create mode 100644 irmin-layers.opam create mode 100644 irmin-pack.opam create mode 100644 irmin.opam create mode 100755 vendor-irmin.sh create mode 100644 vendors/irmin/irmin-layers/dune create mode 100644 vendors/irmin/irmin-layers/import.ml create mode 100644 vendors/irmin/irmin-layers/irmin_layers.ml create mode 100644 vendors/irmin/irmin-layers/irmin_layers.mli create mode 100644 vendors/irmin/irmin-layers/irmin_layers_intf.ml create mode 100644 vendors/irmin/irmin-layers/stats.ml create mode 100644 vendors/irmin/irmin-layers/stats.mli create mode 100644 vendors/irmin/irmin-pack/IO.ml create mode 100644 vendors/irmin/irmin-pack/IO.mli create mode 100644 vendors/irmin/irmin-pack/IO_intf.ml create mode 100644 vendors/irmin/irmin-pack/atomic_write.ml create mode 100644 vendors/irmin/irmin-pack/atomic_write.mli create mode 100644 vendors/irmin/irmin-pack/atomic_write_intf.ml create mode 100644 vendors/irmin/irmin-pack/checks.ml create mode 100644 vendors/irmin/irmin-pack/checks.mli create mode 100644 vendors/irmin/irmin-pack/checks_intf.ml create mode 100644 vendors/irmin/irmin-pack/conf.ml create mode 100644 vendors/irmin/irmin-pack/conf.mli create mode 100644 vendors/irmin/irmin-pack/content_addressable.ml create mode 100644 vendors/irmin/irmin-pack/content_addressable.mli create mode 100644 vendors/irmin/irmin-pack/content_addressable_intf.ml create mode 100644 vendors/irmin/irmin-pack/dict.ml create mode 100644 vendors/irmin/irmin-pack/dict.mli create mode 100644 vendors/irmin/irmin-pack/dict_intf.ml create mode 100644 vendors/irmin/irmin-pack/dune create mode 100644 vendors/irmin/irmin-pack/ext.ml create mode 100644 vendors/irmin/irmin-pack/ext.mli create mode 100644 vendors/irmin/irmin-pack/import.ml create mode 100644 vendors/irmin/irmin-pack/inode.ml create mode 100644 vendors/irmin/irmin-pack/inode.mli create mode 100644 vendors/irmin/irmin-pack/inode_intf.ml create mode 100644 vendors/irmin/irmin-pack/irmin_pack.ml create mode 100644 vendors/irmin/irmin-pack/irmin_pack.mli create mode 100644 vendors/irmin/irmin-pack/irmin_pack_intf.ml create mode 100644 vendors/irmin/irmin-pack/layered/IO_layers.ml create mode 100644 vendors/irmin/irmin-pack/layered/IO_layers.mli create mode 100644 vendors/irmin/irmin-pack/layered/checks.ml create mode 100644 vendors/irmin/irmin-pack/layered/conf.ml create mode 100644 vendors/irmin/irmin-pack/layered/conf.mli create mode 100644 vendors/irmin/irmin-pack/layered/dune create mode 100644 vendors/irmin/irmin-pack/layered/ext_layered.ml create mode 100644 vendors/irmin/irmin-pack/layered/ext_layered.mli create mode 100644 vendors/irmin/irmin-pack/layered/import.ml create mode 100644 vendors/irmin/irmin-pack/layered/inode_layers.ml create mode 100644 vendors/irmin/irmin-pack/layered/inode_layers.mli create mode 100644 vendors/irmin/irmin-pack/layered/inode_layers_intf.ml create mode 100644 vendors/irmin/irmin-pack/layered/irmin_pack_layered.ml create mode 100644 vendors/irmin/irmin-pack/layered/irmin_pack_layered.mli create mode 100644 vendors/irmin/irmin-pack/layered/layered_store.ml create mode 100644 vendors/irmin/irmin-pack/layered/layered_store.mli create mode 100644 vendors/irmin/irmin-pack/layered/layout.ml create mode 100644 vendors/irmin/irmin-pack/layered/s.ml create mode 100644 vendors/irmin/irmin-pack/layout.ml create mode 100644 vendors/irmin/irmin-pack/layout.mli create mode 100644 vendors/irmin/irmin-pack/mem/content_addressable.ml create mode 100644 vendors/irmin/irmin-pack/mem/content_addressable.mli create mode 100644 vendors/irmin/irmin-pack/mem/dune create mode 100644 vendors/irmin/irmin-pack/mem/import.ml create mode 100644 vendors/irmin/irmin-pack/mem/irmin_pack_mem.ml create mode 100644 vendors/irmin/irmin-pack/mem/irmin_pack_mem.mli create mode 100644 vendors/irmin/irmin-pack/migrate.ml create mode 100644 vendors/irmin/irmin-pack/migrate.mli create mode 100644 vendors/irmin/irmin-pack/pack_dict.ml create mode 100644 vendors/irmin/irmin-pack/pack_dict.mli create mode 100644 vendors/irmin/irmin-pack/pack_index.ml create mode 100644 vendors/irmin/irmin-pack/pack_index.mli create mode 100644 vendors/irmin/irmin-pack/pack_index_intf.ml create mode 100644 vendors/irmin/irmin-pack/pack_store.ml create mode 100644 vendors/irmin/irmin-pack/pack_store.mli create mode 100644 vendors/irmin/irmin-pack/pack_store_intf.ml create mode 100644 vendors/irmin/irmin-pack/pack_value.ml create mode 100644 vendors/irmin/irmin-pack/pack_value.mli create mode 100644 vendors/irmin/irmin-pack/pack_value_intf.ml create mode 100644 vendors/irmin/irmin-pack/s.ml create mode 100644 vendors/irmin/irmin-pack/stats.ml create mode 100644 vendors/irmin/irmin-pack/stats.mli create mode 100644 vendors/irmin/irmin-pack/traverse_pack_file.ml create mode 100644 vendors/irmin/irmin-pack/utils.ml create mode 100644 vendors/irmin/irmin-pack/version.ml create mode 100644 vendors/irmin/irmin-pack/version.mli create mode 100644 vendors/irmin/irmin/branch.ml create mode 100644 vendors/irmin/irmin/branch.mli create mode 100644 vendors/irmin/irmin/branch_intf.ml create mode 100644 vendors/irmin/irmin/commit.ml create mode 100644 vendors/irmin/irmin/commit.mli create mode 100644 vendors/irmin/irmin/commit_intf.ml create mode 100644 vendors/irmin/irmin/conf.ml create mode 100644 vendors/irmin/irmin/conf.mli create mode 100644 vendors/irmin/irmin/contents.ml create mode 100644 vendors/irmin/irmin/contents.mli create mode 100644 vendors/irmin/irmin/contents_intf.ml create mode 100644 vendors/irmin/irmin/diff.ml create mode 100644 vendors/irmin/irmin/diff.mli create mode 100644 vendors/irmin/irmin/dot.ml create mode 100644 vendors/irmin/irmin/dot.mli create mode 100644 vendors/irmin/irmin/dune create mode 100644 vendors/irmin/irmin/export_for_backends.ml create mode 100644 vendors/irmin/irmin/hash.ml create mode 100644 vendors/irmin/irmin/hash.mli create mode 100644 vendors/irmin/irmin/hash_intf.ml create mode 100644 vendors/irmin/irmin/import.ml create mode 100644 vendors/irmin/irmin/info.ml create mode 100644 vendors/irmin/irmin/info.mli create mode 100644 vendors/irmin/irmin/irmin.ml create mode 100644 vendors/irmin/irmin/irmin.mli create mode 100644 vendors/irmin/irmin/lock.ml create mode 100644 vendors/irmin/irmin/lock.mli create mode 100644 vendors/irmin/irmin/lru.ml create mode 100644 vendors/irmin/irmin/lru.mli create mode 100644 vendors/irmin/irmin/mem/dune create mode 100644 vendors/irmin/irmin/mem/import.ml create mode 100644 vendors/irmin/irmin/mem/irmin_mem.ml create mode 100644 vendors/irmin/irmin/mem/irmin_mem.mli create mode 100644 vendors/irmin/irmin/merge.ml create mode 100644 vendors/irmin/irmin/merge.mli create mode 100644 vendors/irmin/irmin/node.ml create mode 100644 vendors/irmin/irmin/node.mli create mode 100644 vendors/irmin/irmin/node_intf.ml create mode 100644 vendors/irmin/irmin/object_graph.ml create mode 100644 vendors/irmin/irmin/object_graph.mli create mode 100644 vendors/irmin/irmin/object_graph_intf.ml create mode 100644 vendors/irmin/irmin/path.ml create mode 100644 vendors/irmin/irmin/path.mli create mode 100644 vendors/irmin/irmin/path_intf.ml create mode 100644 vendors/irmin/irmin/perms.ml create mode 100644 vendors/irmin/irmin/private.ml create mode 100644 vendors/irmin/irmin/proof.ml create mode 100644 vendors/irmin/irmin/proof.mli create mode 100644 vendors/irmin/irmin/proof_intf.ml create mode 100644 vendors/irmin/irmin/s.ml create mode 100644 vendors/irmin/irmin/slice.ml create mode 100644 vendors/irmin/irmin/slice.mli create mode 100644 vendors/irmin/irmin/slice_intf.ml create mode 100644 vendors/irmin/irmin/store.ml create mode 100644 vendors/irmin/irmin/store.mli create mode 100644 vendors/irmin/irmin/store_intf.ml create mode 100644 vendors/irmin/irmin/sync.ml create mode 100644 vendors/irmin/irmin/sync.mli create mode 100644 vendors/irmin/irmin/sync_ext.ml create mode 100644 vendors/irmin/irmin/sync_ext.mli create mode 100644 vendors/irmin/irmin/sync_ext_intf.ml create mode 100644 vendors/irmin/irmin/sync_intf.ml create mode 100644 vendors/irmin/irmin/tree.ml create mode 100644 vendors/irmin/irmin/tree.mli create mode 100644 vendors/irmin/irmin/tree_intf.ml create mode 100644 vendors/irmin/irmin/type.ml create mode 100644 vendors/irmin/irmin/type.mli create mode 100644 vendors/irmin/irmin/version.ml create mode 100644 vendors/irmin/irmin/watch.ml create mode 100644 vendors/irmin/irmin/watch.mli create mode 100644 vendors/irmin/irmin/watch_intf.ml diff --git a/irmin-layers.opam b/irmin-layers.opam new file mode 100644 index 000000000000..a14b538c6a2f --- /dev/null +++ b/irmin-layers.opam @@ -0,0 +1,25 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" {>= "2.7.0"} + "mtime" {>= "1.0.0"} + "irmin" {= version} + "logs" + "lwt" {>= "5.3.0"} +] + +synopsis: "Combine different Irmin stores into a single, layered store" diff --git a/irmin-pack.opam b/irmin-pack.opam new file mode 100644 index 000000000000..3da54922c02c --- /dev/null +++ b/irmin-pack.opam @@ -0,0 +1,35 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "2.7.0"} + "irmin" {= version} + "irmin-layers" {= version} + "ppx_irmin" {= version} + "index" {>= "1.5.0"} + "fmt" + "logs" + "lwt" {>= "5.3.0"} + "mtime" + "cmdliner" + "optint" {>= "0.1.0"} + "irmin-test" {with-test & = version} + "alcotest-lwt" {with-test} + "astring" {with-test} + "fpath" {with-test} + "alcotest" {with-test} +] + +synopsis: "Irmin backend which stores values in a pack file" diff --git a/irmin.opam b/irmin.opam new file mode 100644 index 000000000000..dec9bbf1b1b9 --- /dev/null +++ b/irmin.opam @@ -0,0 +1,48 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "2.7.0"} + "repr" {>= "0.5.0"} + "fmt" {>= "0.8.0"} + "uri" {>= "1.3.12"} + "uutf" + "jsonm" {>= "1.0.0"} + "lwt" {>= "5.3.0"} + "digestif" {>= "0.9.0"} + "ocamlgraph" + "logs" {>= "0.5.0"} + "bheap" {>= "2.0.0"} + "astring" + "ppx_irmin" {= version} + "hex" {with-test} + "alcotest" {>= "1.1.0" & with-test} + "alcotest-lwt" {with-test} +] +conflicts: [ + "result" {< "1.5"} # Requires `Result = Stdlib.Result` + ] +available: [ arch != "s390x" ] +synopsis: """ +Irmin, a distributed database that follows the same design principles as Git +""" +description: """ +Irmin is a library for persistent stores with built-in snapshot, +branching and reverting mechanisms. It is designed to use a large +variety of backends. Irmin is written in pure OCaml and does not +depend on external C stubs; it aims to run everywhere, from Linux, +to browsers and Xen unikernels. +""" diff --git a/vendor-irmin.sh b/vendor-irmin.sh new file mode 100755 index 000000000000..eabf6974c50c --- /dev/null +++ b/vendor-irmin.sh @@ -0,0 +1,15 @@ +rm -rf vendors/irmin +rm -f irmin.opam +rm -f irmin-pack.opam +rm -f irmin-layers.opam + +mkdir -p vendors/irmin + +cp -R ~/git/irmin/src/irmin vendors/irmin/ +cp -f ~/git/irmin/irmin.opam . + +cp -R ~/git/irmin/src/irmin-pack vendors/irmin/ +cp -f ~/git/irmin/irmin-pack.opam . + +cp -R ~/git/irmin/src/irmin-layers vendors/irmin/ +cp -f ~/git/irmin/irmin-layers.opam . diff --git a/vendors/irmin/irmin-layers/dune b/vendors/irmin/irmin-layers/dune new file mode 100644 index 000000000000..cdb3b0c29fc0 --- /dev/null +++ b/vendors/irmin/irmin-layers/dune @@ -0,0 +1,6 @@ +(library + (public_name irmin-layers) + (name irmin_layers) + (libraries irmin logs lwt mtime mtime.clock.os) + (preprocess + (pps ppx_irmin))) diff --git a/vendors/irmin/irmin-layers/import.ml b/vendors/irmin/irmin-layers/import.ml new file mode 100644 index 000000000000..7d38a6b5ba5d --- /dev/null +++ b/vendors/irmin/irmin-layers/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/irmin-layers/irmin_layers.ml b/vendors/irmin/irmin-layers/irmin_layers.ml new file mode 100644 index 000000000000..0eb208bb4277 --- /dev/null +++ b/vendors/irmin/irmin-layers/irmin_layers.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Irmin_layers_intf + +module Layer_id = struct + type t = layer_id [@@deriving irmin] + + let to_string = function + | `Upper0 -> "upper0" + | `Upper1 -> "upper1" + | `Lower -> "lower" + + let pp = Fmt.of_to_string to_string +end + +module Make_ext + (CA : Irmin.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : Irmin.ATOMIC_WRITE_STORE_MAKER) + (N : Irmin.Private.Node.Maker) + (CT : Irmin.Private.Commit.Maker) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) = +struct + module XNode = N (H) (P) (M) + module XCommit = CT (H) + include Irmin.Make_ext (CA) (AW) (M) (C) (P) (B) (H) (XNode) (XCommit) + + let freeze ?min_lower:_ ?max_lower:_ ?min_upper:_ ?max_upper:_ ?recovery:_ + _repo = + Lwt.fail_with "not implemented" + + type store_handle = + | Commit_t : hash -> store_handle + | Node_t : hash -> store_handle + | Content_t : hash -> store_handle + + let layer_id _repo _store_handle = Lwt.fail_with "not implemented" + let async_freeze _ = failwith "not implemented" + let upper_in_use _repo = failwith "not implemented" + let self_contained ?min:_ ~max:_ _repo = failwith "not implemented" + let check_self_contained ?heads:_ _ = failwith "not implemented" + let needs_recovery _ = failwith "not implemented" + + module Private_layer = struct + module Hook = struct + type 'a t = unit + + let v _ = failwith "not implemented" + end + + let wait_for_freeze _ = Lwt.fail_with "not implemented" + + let freeze' ?min_lower:_ ?max_lower:_ ?min_upper:_ ?max_upper:_ ?recovery:_ + ?hook:_ _repo = + Lwt.fail_with "not implemented" + + let upper_in_use = upper_in_use + end +end + +module Make + (CA : Irmin.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : Irmin.ATOMIC_WRITE_STORE_MAKER) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) = +struct + include + Make_ext (CA) (AW) (Irmin.Private.Node.Make) (Irmin.Private.Commit.Make) (M) + (C) + (P) + (B) + (H) +end + +module Stats = Stats diff --git a/vendors/irmin/irmin-layers/irmin_layers.mli b/vendors/irmin/irmin-layers/irmin_layers.mli new file mode 100644 index 000000000000..fd2996ed9be1 --- /dev/null +++ b/vendors/irmin/irmin-layers/irmin_layers.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_layers_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-layers/irmin_layers_intf.ml b/vendors/irmin/irmin-layers/irmin_layers_intf.ml new file mode 100644 index 000000000000..27ebeb812a92 --- /dev/null +++ b/vendors/irmin/irmin-layers/irmin_layers_intf.ml @@ -0,0 +1,166 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type layer_id = [ `Upper0 | `Upper1 | `Lower ] [@@deriving irmin] + +module type S = sig + include Irmin.S + + val freeze : + ?min_lower:commit list -> + ?max_lower:commit list -> + ?min_upper:commit list -> + ?max_upper:commit list -> + ?recovery:bool -> + repo -> + unit Lwt.t + (** [freeze ?min_lower ?max_lower ?min_upper ?max_upper ?recovery t] launches + an asynchronous freezing operation on the repo [t] to reduce the size of + the upper layer and discard unnecessary branches of objects (i.e. commits, + nodes and contents). + + Let [o] be the set of objects reachable from the [max_lower] commits and + bounded by the [min_lower] commits. During the freeze, all objects in [o] + are copied to the lower layer, if there is one. [max_lower] defaults to + the head commits of the repo and [min_lower] defaults to the empty list + (i.e. the copy is unbounded). When [max_lower] is the empty list, nothing + is copied. + + Let [o'] be the set of objects reachable from the [max_upper] commits and + bounded by the [min_upper] commits. When the freeze is over, the new upper + layer will only contain the objects of [o']. [max_upper] defaults to + [max_lower] and [min_upper] defaults to [max_upper] (i.e. only the max + commits are copied). When [max_upper] is the empty list, nothing is + copied. + + If [recovery] is true then the function will first try to recover from a + previously interrupted freeze. See {!needs_recovery}. + + If a freeze is already ongoing, the behavior depends on the + freeze_throttle configuration of the repo: + + - When [`Overcommit_memory], the function returns without launching a new + freeze. + - When [`Cancel_existing], the function blocks until the ongoing freeze + safely cancels and then a new one is started afterwards. The time spent + doing the canceled freeze is not completely wasted, objects copied to + the lower layer will not have to be copied again, but objects copied to + the next upper layer are discarded from that layer. + - When [`Block_writes], the function blocks until the ongoing freeze ends + and then a new one is started afterwards. *) + + type store_handle = + | Commit_t : hash -> store_handle + | Node_t : hash -> store_handle + | Content_t : hash -> store_handle + + val layer_id : repo -> store_handle -> layer_id Lwt.t + (** [layer_id t store_handle] returns the layer where an object, identified by + its hash, is stored. *) + + val async_freeze : repo -> bool + (** [async_freeze t] returns true if there is an ongoing freeze. To be used + with caution, as a freeze can start (or stop) just after the test. It is + helpful when a single freeze is called, to check whether it completed or + not. *) + + val self_contained : ?min:commit list -> max:commit list -> repo -> unit Lwt.t + (** [self_contained min max t] copies the commits in the range of [min, max] + from lower into upper, in order to make the upper self contained. If [min] + is missing then only the [max] commits are copied. *) + + val check_self_contained : + ?heads:commit list -> + repo -> + ([> `Msg of string ], [> `Msg of string ]) result Lwt.t + (** [check_self_contained ?heads] checks that the current upper layer of a + store is self contained. *) + + val needs_recovery : repo -> bool + (** [needs_recovery repo] detects if an ongoing freeze was interrupted during + the last node crash. If it returns [true] then the next call to freeze + needs to have its [recovery] flag set. *) + + (** These modules should not be used. They are exposed purely for testing + purposes. *) + module Private_layer : sig + module Hook : sig + type 'a t + + val v : ('a -> unit Lwt.t) -> 'a t + end + + val wait_for_freeze : repo -> unit Lwt.t + + val freeze' : + ?min_lower:commit list -> + ?max_lower:commit list -> + ?min_upper:commit list -> + ?max_upper:commit list -> + ?recovery:bool -> + ?hook: + [ `After_Clear + | `Before_Clear + | `Before_Copy + | `Before_Copy_Newies + | `Before_Copy_Last_Newies + | `Before_Flip ] + Hook.t -> + repo -> + unit Lwt.t + + val upper_in_use : repo -> [ `Upper0 | `Upper1 ] + end +end + +module type Maker = functor + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) + -> + S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + +module type Sigs = sig + module Layer_id : sig + type t = layer_id [@@deriving irmin] + + val pp : Format.formatter -> t -> unit + val to_string : t -> string + end + + module type S = S + module type Maker = Maker + + module Make_ext + (CA : Irmin.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : Irmin.ATOMIC_WRITE_STORE_MAKER) + (Node : Irmin.Private.Node.Maker) + (Commit : Irmin.Private.Commit.Maker) : Maker + + module Make + (CA : Irmin.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : Irmin.ATOMIC_WRITE_STORE_MAKER) : Maker + + module Stats = Stats +end diff --git a/vendors/irmin/irmin-layers/stats.ml b/vendors/irmin/irmin-layers/stats.ml new file mode 100644 index 000000000000..94b4cd96733d --- /dev/null +++ b/vendors/irmin/irmin-layers/stats.ml @@ -0,0 +1,326 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open! Import + +(* This file avoids the [option] type and other clean functionnal paradigms in + order to lower the cpu footprint. The integer incrementation functions are + called millions of times per freeze. *) + +(** Ensure lists are not growing indefinitely by dropping elements. *) +let limit_length_list = 10 + +let minimum_seconds_to_be_considered_long = 1.0 + +type counters = { + mutable contents : int; + mutable nodes : int; + mutable commits : int; + mutable branches : int; + mutable adds : int; + mutable skip_tests : int; + mutable skips : int; + mutable yields : int; +} + +type freeze_profile = { + idx : int; + past_adds : int; + t0 : Mtime.t; + mutable t1 : Mtime.t; + mutable current_section : string; + mutable current_counters : counters; + mutable rev_timeline : (string * Mtime.t * float * counters) list; + mutable copy_newies_loops : int; + mutable outside_totlen : float; + mutable inside_totlen : float; + mutable outside_maxlen : string * float; + mutable inside_maxlen : string * float; + mutable rev_longest_yields : (string, int * float) Hashtbl.t; + mutable rev_longest_blocks : (string, int * float) Hashtbl.t; +} + +let fresh_counters () = + { + contents = 0; + nodes = 0; + commits = 0; + branches = 0; + adds = 0; + skips = 0; + skip_tests = 0; + yields = 0; + } + +let fresh_freeze_profile idx t0 initial_section past_adds = + { + idx; + past_adds; + t0; + t1 = t0; + current_section = initial_section; + current_counters = fresh_counters (); + rev_timeline = []; + copy_newies_loops = 0; + outside_totlen = 0.; + inside_totlen = 0.; + outside_maxlen = ("never", 0.); + inside_maxlen = ("never", 0.); + rev_longest_yields = Hashtbl.create 2; + rev_longest_blocks = Hashtbl.create 2; + } + +let get_elapsed = + let c = ref (Mtime_clock.counter ()) in + fun ~reset -> + let elapsed = Mtime.Span.to_s (Mtime_clock.count !c) in + if reset then c := Mtime_clock.counter (); + elapsed + +let freeze_start_counter = + let c = ref (-1) in + fun () -> + incr c; + !c + +let freeze_profiles = ref [] +let latest = ref (fresh_freeze_profile (-1) (Mtime_clock.now ()) "" 0) +let are_all_counters_zero c = c = fresh_counters () + +let reset_stats () = + freeze_profiles := []; + latest := fresh_freeze_profile (-1) (Mtime_clock.now ()) "" 0 + +let freeze_start t0 initial_section = + let past_adds = !latest.current_counters.adds in + let (_ : float) = get_elapsed ~reset:true in + latest := + fresh_freeze_profile (freeze_start_counter ()) t0 initial_section past_adds + +let freeze_section ev_name' = + let ev_name = !latest.current_section in + let now = Mtime_clock.now () in + let now_inside = get_elapsed ~reset:false +. !latest.inside_totlen in + let c = !latest.current_counters in + !latest.current_counters <- fresh_counters (); + !latest.current_section <- ev_name'; + !latest.rev_timeline <- (ev_name, now, now_inside, c) :: !latest.rev_timeline + +let copy_contents () = + !latest.current_counters.contents <- succ !latest.current_counters.contents + +let copy_nodes () = + !latest.current_counters.nodes <- succ !latest.current_counters.nodes + +let copy_commits () = + !latest.current_counters.commits <- succ !latest.current_counters.commits + +let copy_branches () = + !latest.current_counters.branches <- succ !latest.current_counters.branches + +let add () = + (* The only incrementator not called from freeze. *) + !latest.current_counters.adds <- succ !latest.current_counters.adds + +let skip_test should_skip = + !latest.current_counters.skip_tests <- + succ !latest.current_counters.skip_tests; + if should_skip then + !latest.current_counters.skips <- succ !latest.current_counters.skips + +let copy_newies_loop () = + !latest.copy_newies_loops <- succ !latest.copy_newies_loops + +let fold_counters v f = + List.fold_left + (fun acc (_, _, _, c) -> acc + f c) + (f v.current_counters) v.rev_timeline + +let get_add_count () = fold_counters !latest (fun c -> c.adds) +let get_copied_commits_count () = fold_counters !latest (fun c -> c.commits) +let get_copied_branches_count () = fold_counters !latest (fun c -> c.branches) +let get_copied_contents_count () = fold_counters !latest (fun c -> c.contents) +let get_copied_nodes_count () = fold_counters !latest (fun c -> c.nodes) +let get_freeze_count () = List.length !freeze_profiles + +let freeze_yield () = + !latest.current_counters.yields <- succ !latest.current_counters.yields; + let d1 = get_elapsed ~reset:true in + let d0 = !latest.inside_totlen in + !latest.inside_totlen <- d0 +. d1; + let _, d0 = !latest.inside_maxlen in + if d1 > d0 then !latest.inside_maxlen <- (!latest.current_section, d1); + if d1 >= minimum_seconds_to_be_considered_long then + let tbl = !latest.rev_longest_blocks in + let s = !latest.current_section in + let new_entry = + match Hashtbl.find_opt tbl s with + | None -> (1, d1) + | Some (i, d) -> (i + 1, d +. d1) + in + Hashtbl.replace tbl s new_entry + +let freeze_yield_end () = + let d1 = get_elapsed ~reset:true in + let d0 = !latest.outside_totlen in + !latest.outside_totlen <- d0 +. d1; + let _, d0 = !latest.outside_maxlen in + if d1 > d0 then !latest.outside_maxlen <- (!latest.current_section, d1); + if d1 >= minimum_seconds_to_be_considered_long then + let tbl = !latest.rev_longest_yields in + let s = !latest.current_section in + let new_entry = + match Hashtbl.find_opt tbl s with + | None -> (1, d1) + | Some (i, d) -> (i + 1, d +. d1) + in + Hashtbl.replace tbl s new_entry + +let freeze_stop () = + let v = !latest in + freeze_yield (); + v.current_counters.yields <- pred v.current_counters.yields; + v.t1 <- Mtime_clock.now (); + v.rev_timeline <- + (v.current_section, Mtime_clock.now (), v.inside_totlen, v.current_counters) + :: v.rev_timeline; + v.current_counters <- fresh_counters (); + let shorter ls = + List.fold_left + (fun (acc, i) x -> + if i < limit_length_list then (x :: acc, i + 1) else (acc, i + 1)) + ([], 0) ls + |> fst + |> List.rev + in + freeze_profiles := shorter (v :: !freeze_profiles) + +let pp_latest_when_any ppf v = + let ongoing = Mtime.equal v.t0 v.t1 in + let timeline = + let l, t0, t0_block = + List.fold_right + (fun (s, t1, t1_block, counters) (acc, t0, t0_block) -> + let span = Mtime.span t0 t1 in + let span_block = t1_block -. t0_block in + let data = (s, span, span_block, counters, false) in + (data :: acc, t1, t1_block)) + v.rev_timeline ([], v.t0, 0.) + in + let l = + if not ongoing then l + else + let t1 = Mtime_clock.now () in + let t1_block = get_elapsed ~reset:false +. v.inside_totlen in + let span = Mtime.span t0 t1 in + let span_block = t1_block -. t0_block in + (v.current_section, span, span_block, v.current_counters, true) :: l + in + List.rev l + in + let totlen = + if ongoing then Mtime.span v.t0 (Mtime_clock.now ()) + else Mtime.span v.t0 v.t1 + in + let frac_out, frac_in = + let totlen = Mtime.Span.to_s totlen in + (v.outside_totlen /. totlen, v.inside_totlen /. totlen) + in + let pp_timeline_timings_section ppf (name, span, span_block, _, is_ongoing) = + let totlen = Mtime.Span.to_s totlen in + let span = Mtime.Span.to_s span in + let pp = Mtime.Span.pp_float_s in + let pp' ppf v = Format.fprintf ppf "%.0f%%" (v *. 100.) in + Format.fprintf ppf + "@\n %20s took %a (%a of total) and blocked %a (%a of total)%s." name + pp span pp' (span /. totlen) pp span_block pp' + (span_block /. v.inside_totlen) + (if is_ongoing then " (ongoing)" else "") + in + let pp_timeline_timings ppf = + Format.fprintf ppf "%a" + Fmt.(list ~sep:(any "") pp_timeline_timings_section) + timeline + in + let pp_timeline_counters_section ppf (name, _, _, c, is_ongoing) = + Format.fprintf ppf "@\n %20s %a%s." name + Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") string int)) + [ + ("copy_contents", c.contents); + ("copy_nodes", c.nodes); + ("copy_commits", c.commits); + ("copy_branches", c.branches); + ("adds", c.adds); + ("skips", c.skips); + ("skip_tests", c.skip_tests); + ("yields", c.yields); + ] + (if is_ongoing then " (ongoing)" else "") + in + let pp_timeline_counters ppf = + let timeline = + List.filter + (fun (_, _, _, c, _) -> not @@ are_all_counters_zero c) + timeline + in + Format.fprintf ppf "%a" + Fmt.(list ~sep:(any "") pp_timeline_counters_section) + timeline + in + let pp_long_segment ppf (action_name, (max_section, max_len), tbl) = + if max_len = 0. then Format.fprintf ppf "No %ss" action_name + else if Hashtbl.length tbl = 0 then + Format.fprintf ppf "Longest %s: %a (during \"%s\")" action_name + Mtime.Span.pp_float_s max_len max_section + else + let pp_per_section ppf (section, (count, totlen)) = + let pp_if_max ppf = + if section = max_section then + Format.fprintf ppf " (max:%a)" Mtime.Span.pp_float_s max_len + in + if count = 1 then + Format.fprintf ppf "1 long %s in \"%s\" of %a" action_name section + Mtime.Span.pp_float_s totlen + else + Format.fprintf ppf "%d long %ss in \"%s\" of ~%a%t" count action_name + section Mtime.Span.pp_float_s + (totlen /. float_of_int count) + pp_if_max + in + Format.fprintf ppf "Longests %ss: [%a]" action_name + Fmt.(list ~sep:(any "; ") pp_per_section) + (Hashtbl.to_seq tbl |> List.of_seq) + in + Format.fprintf ppf + "freeze %d (%s) blocked %a (%.0f%%), and yielded %a (%.0f%%). Total %a. %d \ + adds before freeze. Copy newies loops: %d.@\n\ + \ %a.@\n\ + \ %a.@\n\ + \ Timeline timings: %t@\n\ + \ Timeline counters: %t@\n" + v.idx + (if ongoing then "ongoing" else "finished") + Mtime.Span.pp_float_s v.inside_totlen (frac_in *. 100.) + Mtime.Span.pp_float_s v.outside_totlen (frac_out *. 100.) Mtime.Span.pp + totlen v.past_adds v.copy_newies_loops pp_long_segment + ("block", v.inside_maxlen, v.rev_longest_blocks) + pp_long_segment + ("yield", v.outside_maxlen, v.rev_longest_yields) + pp_timeline_timings pp_timeline_counters + +let pp_latest ppf = + let v = !latest in + if v.idx = -1 then Format.fprintf ppf "No freeze started yet." + else pp_latest_when_any ppf v diff --git a/vendors/irmin/irmin-layers/stats.mli b/vendors/irmin/irmin-layers/stats.mli new file mode 100644 index 000000000000..12ca9dc98481 --- /dev/null +++ b/vendors/irmin/irmin-layers/stats.mli @@ -0,0 +1,75 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {2 Profiling of Freeze} + + {3 Control Flow of the Freeze Thread} + + Most of the functions here should be called from under a single mutex lock. *) + +val freeze_start : Mtime.t -> string -> unit +(** Signals the start of a new freeze given the time at which the freeze process + started and the name given to the initial code section. *) + +val freeze_section : string -> unit +(** Signals that the freeze is entering a specific section of the code. *) + +val freeze_stop : unit -> unit +(** Signals the end of an ongoing freeze freeze. *) + +val freeze_yield : unit -> unit +(** Signals that the freeze is cooperatively yielding to other threads. *) + +val freeze_yield_end : unit -> unit +(** Signals that the freeze is given back the control. *) + +(** {3 Incrementations of Counters} *) + +val copy_contents : unit -> unit +(** Increments the number of copied contents for the current freeze. *) + +val copy_nodes : unit -> unit +(** Increments the number of copied nodes for the current freeze. *) + +val copy_commits : unit -> unit +(** Increments the number of copied commits for the current freeze. *) + +val copy_branches : unit -> unit +(** Increments the number of copied branches for the current freeze. *) + +val add : unit -> unit +(** Increment the number of objects added by main thread. *) + +val skip_test : bool -> unit +(** Increment the number time we wondered if an entry was present at the + destination during a graph traversal for the current freeze. *) + +val copy_newies_loop : unit -> unit +(** Increment the number of iterations of newies copy. *) + +(** {3 Observation} *) + +val get_add_count : unit -> int +val get_copied_commits_count : unit -> int +val get_copied_branches_count : unit -> int +val get_copied_contents_count : unit -> int +val get_copied_nodes_count : unit -> int +val get_freeze_count : unit -> int +val pp_latest : Format.formatter -> unit + +(** {3 Misc.} *) + +val reset_stats : unit -> unit diff --git a/vendors/irmin/irmin-pack/IO.ml b/vendors/irmin/irmin-pack/IO.ml new file mode 100644 index 000000000000..568dbaa8a691 --- /dev/null +++ b/vendors/irmin/irmin-pack/IO.ml @@ -0,0 +1,349 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include IO_intf +open! Import + +let src = Logs.Src.create "irmin.pack.io" ~doc:"IO for irmin-pack" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Unix : S = struct + module Raw = Index_unix.Private.Raw + + type t = { + file : string; + mutable raw : Raw.t; + mutable generation : int63; + mutable offset : int63; + mutable flushed : int63; + readonly : bool; + version : Version.t; + buf : Buffer.t; + } + + let name t = t.file + + let header = function + | `V1 -> (* offset + version *) Int63.of_int 16 + | `V2 -> (* offset + version + generation *) Int63.of_int 24 + + let unsafe_flush t = + Log.debug (fun l -> l "IO flush %s" t.file); + let buf = Buffer.contents t.buf in + if buf = "" then () + else + let offset = t.offset in + Buffer.clear t.buf; + Raw.unsafe_write t.raw ~off:t.flushed buf 0 (String.length buf); + Raw.Offset.set t.raw offset; + (* concurrent append might happen so here t.offset might differ + from offset *) + let h = header t.version in + if not (t.flushed ++ Int63.of_int (String.length buf) = h ++ offset) then + Fmt.failwith "sync error: %s flushed=%a offset+header=%a\n%!" t.file + Int63.pp t.flushed Int63.pp (offset ++ h); + t.flushed <- offset ++ h + + let flush t = + if t.readonly then raise S.RO_not_allowed; + unsafe_flush t + + let auto_flush_limit = Int63.of_int 1_000_000 + + let append t buf = + Buffer.add_string t.buf buf; + let len = Int63.of_int (String.length buf) in + t.offset <- t.offset ++ len; + if t.offset -- t.flushed > auto_flush_limit then flush t + + let set t ~off buf = + if t.readonly then raise S.RO_not_allowed; + unsafe_flush t; + let buf_len = String.length buf in + Raw.unsafe_write t.raw ~off:(header t.version ++ off) buf 0 buf_len; + assert ( + let len = Int63.of_int buf_len in + let off = header t.version ++ off ++ len in + off <= t.flushed) + + let read_buffer t ~off ~buf ~len = + let off = header t.version ++ off in + assert (if not t.readonly then off <= t.flushed else true); + Raw.unsafe_read t.raw ~off ~len buf + + let read t ~off buf = read_buffer t ~off ~buf ~len:(Bytes.length buf) + let offset t = t.offset + + let force_offset t = + t.offset <- Raw.Offset.get t.raw; + t.offset + + let generation t = t.generation + + let force_headers t = + match t.version with + | `V1 -> + (* There is no generation number in V1 *) + { offset = force_offset t; generation = Int63.zero } + | `V2 -> + let h = Raw.Header.get t.raw in + t.generation <- h.generation; + t.offset <- h.offset; + { offset = t.offset; generation = t.generation } + + let version t = + Log.debug (fun l -> + l "[%s] version: %a" (Filename.basename t.file) Version.pp t.version); + t.version + + let readonly t = t.readonly + + let protect_unix_exn = function + | Unix.Unix_error _ as e -> failwith (Printexc.to_string e) + | e -> raise e + + let ignore_enoent = function + | Unix.Unix_error (Unix.ENOENT, _, _) -> () + | e -> raise e + + let protect f x = try f x with e -> protect_unix_exn e + let safe f x = try f x with e -> ignore_enoent e + + let mkdir dirname = + let rec aux dir k = + if Sys.file_exists dir && Sys.is_directory dir then k () + else ( + if Sys.file_exists dir then safe Unix.unlink dir; + (aux [@tailcall]) (Filename.dirname dir) (fun () -> + protect (Unix.mkdir dir) 0o755; + k ())) + in + aux dirname (fun () -> ()) + + let raw ~flags ~version ~offset ~generation file = + let x = Unix.openfile file flags 0o644 in + let raw = Raw.v x in + let header = + { Raw.Header.version = Version.to_bin version; offset; generation } + in + Raw.Header.set raw header; + raw + + let unsafe_clear ?keep_generation t = + if t.readonly then invalid_arg "Read-only IO cannot be cleared"; + Log.debug (fun l -> l "clear %s" t.file); + Buffer.clear t.buf; + (* no-op if the file is already empty; this is to avoid bumping + the version number when this is not necessary. *) + if t.offset = Int63.zero then () + else ( + t.offset <- Int63.zero; + if keep_generation = None then t.generation <- Int63.succ t.generation; + t.flushed <- header t.version; + (* update the generation for concurrent readonly instance to + notice that the file has been clear when they next sync. *) + Raw.Generation.set t.raw t.generation; + (* delete the file. *) + Raw.close t.raw; + Unix.unlink t.file; + (* and re-open a fresh instance. *) + t.raw <- + raw ~version:t.version ~generation:t.generation ~offset:Int63.zero + ~flags:Unix.[ O_CREAT; O_RDWR; O_CLOEXEC ] + t.file) + + let clear ?keep_generation t = + match t.version with + | `V1 -> invalid_arg "V1 stores cannot be cleared; use [truncate] instead" + | `V2 -> unsafe_clear ?keep_generation t + + let truncate t = + match t.version with + | `V2 -> invalid_arg "V2 stores cannot be truncated; use [clear] instead" + | `V1 -> + t.offset <- Int63.zero; + t.flushed <- header `V1; + Buffer.clear t.buf + + let v ~version ~fresh ~readonly file = + let get_version () = + match version with + | Some v -> v + | None -> + Fmt.invalid_arg + "Must supply an explicit version when creating a new store ({ file \ + = %s })" + file + in + let v ~offset ~version ~generation raw = + { + version; + file; + offset; + raw; + readonly; + buf = Buffer.create (4 * 1024); + flushed = header version ++ offset; + generation; + } + in + let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in + mkdir (Filename.dirname file); + match Sys.file_exists file with + | false -> + let version = get_version () in + let raw = + raw + ~flags:[ O_CREAT; mode; O_CLOEXEC ] + ~version ~offset:Int63.zero ~generation:Int63.zero file + in + v ~offset:Int63.zero ~version ~generation:Int63.zero raw + | true -> ( + let x = Unix.openfile file Unix.[ O_EXCL; mode; O_CLOEXEC ] 0o644 in + let raw = Raw.v x in + if fresh then ( + let version = get_version () in + let header = + { + Raw.Header.version = Version.to_bin version; + offset = Int63.zero; + generation = Int63.zero; + } + in + Raw.Header.set raw header; + v ~offset:Int63.zero ~version ~generation:Int63.zero raw) + else + let actual_version = + let v_string = Raw.Version.get raw in + match Version.of_bin v_string with + | Some v -> v + | None -> Version.invalid_arg v_string + in + (match version with + | Some v when v <> actual_version -> + raise (Version.Invalid { expected = v; found = actual_version }) + | _ -> ()); + match actual_version with + | `V1 -> + Log.debug (fun l -> l "[%s] file exists in V1" file); + let offset = Raw.Offset.get raw in + v ~offset ~version:`V1 ~generation:Int63.zero raw + | `V2 -> + let { Raw.Header.offset; generation; _ } = Raw.Header.get raw in + v ~offset ~version:`V2 ~generation raw) + + let close t = Raw.close t.raw + let exists file = Sys.file_exists file + let size { raw; _ } = (Raw.fstat raw).st_size + + (* From a given offset in [src], transfer all data to [dst] (starting at + [dst_off]). *) + let transfer_all ~progress ~src ~src_off ~dst ~dst_off = + let ( + ) a b = Int63.(add a (of_int b)) in + let buf_len = 4096 in + let buf = Bytes.create buf_len in + let rec inner ~src_off ~dst_off = + match Raw.unsafe_read src ~off:src_off ~len:buf_len buf with + | 0 -> () + | read -> + assert (read <= buf_len); + let to_write = if read < buf_len then Bytes.sub buf 0 read else buf in + let () = + Raw.unsafe_write dst ~off:dst_off + (Bytes.unsafe_to_string to_write) + 0 read + in + progress (Int63.of_int read); + (inner [@tailcall]) ~src_off:(src_off + read) ~dst_off:(dst_off + read) + in + inner ~src_off ~dst_off + + let migrate ~progress src dst_v = + let src_v = + let v_bin = Raw.Version.get src.raw in + match Version.of_bin v_bin with + | None -> Fmt.failwith "Could not parse version string `%s'" v_bin + | Some v -> v + in + let src_offset = Raw.Offset.get src.raw in + match (src_v, dst_v) with + | `V1, `V2 -> + let dst_path = + let rand = Random.State.(bits (make_self_init ())) land 0xFFFFFF in + Fmt.str "%s-tmp-migrate-%06x" src.file rand + in + Log.debug (fun m -> + m "[%s] Performing migration [%a → %a] using tmp file %s" + (Filename.basename src.file) + Version.pp `V1 Version.pp `V2 + (Filename.basename dst_path)); + let dst = + (* Note: all V1 files implicitly have [generation = 0], since it + is not possible to [clear] them. *) + raw dst_path ~flags:[ Unix.O_CREAT; O_WRONLY ] ~version:`V2 + ~offset:src_offset ~generation:Int63.zero + in + transfer_all ~src:src.raw ~progress + ~src_off:(header `V1) + ~dst + ~dst_off:(header `V2); + Raw.close dst; + Unix.rename dst_path src.file; + Ok () + | _, _ -> + Fmt.invalid_arg "[%s] Unsupported migration path: %a → %a" + (Filename.basename src.file) + Version.pp src_v Version.pp dst_v +end + +module Cache = struct + type ('a, 'v) t = { v : 'a -> ?fresh:bool -> ?readonly:bool -> string -> 'v } + + let memoize ~v ~clear ~valid file = + let files = Hashtbl.create 13 in + let cached_constructor extra_args ?(fresh = false) ?(readonly = false) root + = + let file = file ~root in + if fresh && readonly then invalid_arg "Read-only IO cannot be fresh"; + try + if not (Sys.file_exists file) then ( + Log.debug (fun l -> + l "[%s] does not exist anymore, cleaning up the fd cache" + (Filename.basename file)); + Hashtbl.remove files (file, true); + Hashtbl.remove files (file, false); + raise Not_found); + let t = Hashtbl.find files (file, readonly) in + if valid t then ( + Log.debug (fun l -> + l "found in cache: %s (readonly=%b)" file readonly); + if fresh then clear t; + t) + else ( + Hashtbl.remove files (file, readonly); + raise Not_found) + with Not_found -> + Log.debug (fun l -> + l "[%s] v fresh=%b readonly=%b" (Filename.basename file) fresh + readonly); + let t = v extra_args ~fresh ~readonly file in + if fresh then clear t; + Hashtbl.add files (file, readonly) t; + t + in + { v = cached_constructor } +end diff --git a/vendors/irmin/irmin-pack/IO.mli b/vendors/irmin/irmin-pack/IO.mli new file mode 100644 index 000000000000..34d39db55e67 --- /dev/null +++ b/vendors/irmin/irmin-pack/IO.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include IO_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/IO_intf.ml b/vendors/irmin/irmin-pack/IO_intf.ml new file mode 100644 index 000000000000..8f77a26436a1 --- /dev/null +++ b/vendors/irmin/irmin-pack/IO_intf.ml @@ -0,0 +1,74 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +type headers = { offset : int63; generation : int63 } + +module type S = sig + type t + type path := string + + val v : version:Version.t option -> fresh:bool -> readonly:bool -> path -> t + val name : t -> string + val clear : ?keep_generation:unit -> t -> unit + val append : t -> string -> unit + val set : t -> off:int63 -> string -> unit + val read : t -> off:int63 -> bytes -> int + val read_buffer : t -> off:int63 -> buf:bytes -> len:int -> int + val offset : t -> int63 + val generation : t -> int63 + val force_headers : t -> headers + val readonly : t -> bool + val version : t -> Version.t + val flush : t -> unit + val close : t -> unit + val exists : string -> bool + val size : t -> int + + val truncate : t -> unit + (** Sets the length of the underlying IO to be 0, without actually purging the + associated data. Not supported for stores beyond [`V1], which should use + {!clear} instead. *) + + val migrate : + progress:(int63 -> unit) -> + t -> + Version.t -> + (unit, [> `Msg of string ]) result + (** @raise Invalid_arg if the migration path is not supported. *) +end + +module type Sigs = sig + type nonrec headers = headers + + module type S = S + + module Unix : S + + module Cache : sig + type ('a, 'v) t = { + v : 'a -> ?fresh:bool -> ?readonly:bool -> string -> 'v; + } + + val memoize : + v:('a -> fresh:bool -> readonly:bool -> string -> 'v) -> + clear:('v -> unit) -> + valid:('v -> bool) -> + (root:string -> string) -> + ('a, 'v) t + end +end diff --git a/vendors/irmin/irmin-pack/atomic_write.ml b/vendors/irmin/irmin-pack/atomic_write.ml new file mode 100644 index 000000000000..1ea8bd7dac78 --- /dev/null +++ b/vendors/irmin/irmin-pack/atomic_write.ml @@ -0,0 +1,313 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Atomic_write_intf +module Cache = IO.Cache + +module Table (K : Irmin.Type.S) = Hashtbl.Make (struct + type t = K.t + + let hash = Irmin.Type.(unstage (short_hash K.t)) ?seed:None + let equal = Irmin.Type.(unstage (equal K.t)) +end) + +module Make_persistent + (Current : Version.S) + (K : Irmin.Type.S) + (V : Irmin.Hash.S) = +struct + module Tbl = Table (K) + module W = Irmin.Private.Watch.Make (K) (V) + module IO = IO.Unix + + type key = K.t + type value = V.t + type watch = W.watch + + type t = { + index : int63 Tbl.t; + cache : V.t Tbl.t; + mutable block : IO.t; + w : W.t; + mutable open_instances : int; + } + + let decode_bin = Irmin.Type.(unstage (decode_bin int32)) + + let read_length32 ~off block = + let buf = Bytes.create 4 in + let n = IO.read block ~off buf in + assert (n = 4); + let n, v = decode_bin (Bytes.unsafe_to_string buf) 0 in + assert (n = 4); + Int32.to_int v + + let entry = Irmin.Type.(pair (string_of `Int32) V.t) + let key_to_bin_string = Irmin.Type.(unstage (to_bin_string K.t)) + let key_of_bin_string = Irmin.Type.(unstage (of_bin_string K.t)) + let entry_to_bin_string = Irmin.Type.(unstage (to_bin_string entry)) + let value_of_bin_string = Irmin.Type.(unstage (of_bin_string V.t)) + let value_decode_bin = Irmin.Type.(unstage (decode_bin V.t)) + + let set_entry t ?off k v = + let k = key_to_bin_string k in + let buf = entry_to_bin_string (k, v) in + match off with + | None -> IO.append t.block buf + | Some off -> IO.set t.block buf ~off + + let pp_branch = Irmin.Type.pp K.t + + let zero = + match value_of_bin_string (String.make V.hash_size '\000') with + | Ok x -> x + | Error _ -> assert false + + let equal_val = Irmin.Type.(unstage (equal V.t)) + + let refill t ~to_ ~from = + let rec aux offset = + if offset >= to_ then () + else + let len = read_length32 ~off:offset t.block in + let buf = Bytes.create (len + V.hash_size) in + let off = offset ++ Int63.of_int 4 in + let n = IO.read t.block ~off buf in + assert (n = Bytes.length buf); + let buf = Bytes.unsafe_to_string buf in + let h = + let h = String.sub buf 0 len in + match key_of_bin_string h with + | Ok k -> k + | Error (`Msg e) -> failwith e + in + let n, v = value_decode_bin buf len in + assert (n = String.length buf); + if not (equal_val v zero) then Tbl.add t.cache h v; + Tbl.add t.index h offset; + (aux [@tailcall]) (off ++ Int63.(of_int @@ (len + V.hash_size))) + in + aux from + + let sync_offset t = + let former_offset = IO.offset t.block in + let former_generation = IO.generation t.block in + let h = IO.force_headers t.block in + if former_generation <> h.generation then ( + Log.debug (fun l -> l "[branches] generation changed, refill buffers"); + IO.close t.block; + let io = + IO.v ~fresh:false ~readonly:true ~version:(Some Current.version) + (IO.name t.block) + in + t.block <- io; + Tbl.clear t.cache; + Tbl.clear t.index; + refill t ~to_:h.offset ~from:Int63.zero) + else if h.offset > former_offset then + refill t ~to_:h.offset ~from:former_offset + + let unsafe_find t k = + Log.debug (fun l -> l "[branches] find %a" pp_branch k); + if IO.readonly t.block then sync_offset t; + try Some (Tbl.find t.cache k) with Not_found -> None + + let find t k = Lwt.return (unsafe_find t k) + + let unsafe_mem t k = + Log.debug (fun l -> l "[branches] mem %a" pp_branch k); + try Tbl.mem t.cache k with Not_found -> false + + let mem t v = Lwt.return (unsafe_mem t v) + + let unsafe_remove t k = + Tbl.remove t.cache k; + try + let off = Tbl.find t.index k in + set_entry t ~off k zero + with Not_found -> () + + let remove t k = + Log.debug (fun l -> l "[branches] remove %a" pp_branch k); + unsafe_remove t k; + W.notify t.w k None + + let unsafe_clear ?keep_generation t = + Lwt.async (fun () -> W.clear t.w); + match Current.version with + | `V1 -> IO.truncate t.block + | `V2 -> + IO.clear ?keep_generation t.block; + Tbl.clear t.cache; + Tbl.clear t.index + + let clear t = + Log.debug (fun l -> l "[branches] clear"); + unsafe_clear t; + Lwt.return_unit + + let clear_keep_generation t = + Log.debug (fun l -> l "[branches] clear"); + unsafe_clear ~keep_generation:() t; + Lwt.return_unit + + let watches = W.v () + + let valid t = + if t.open_instances <> 0 then ( + t.open_instances <- t.open_instances + 1; + true) + else false + + let unsafe_v ~fresh ~readonly file = + let block = IO.v ~fresh ~version:(Some Current.version) ~readonly file in + let cache = Tbl.create 997 in + let index = Tbl.create 997 in + let t = { cache; index; block; w = watches; open_instances = 1 } in + let h = IO.force_headers block in + refill t ~to_:h.offset ~from:Int63.zero; + t + + let Cache.{ v = unsafe_v } = + Cache.memoize ~clear:unsafe_clear ~valid + ~v:(fun () -> unsafe_v) + Layout.branch + + let v ?fresh ?readonly file = Lwt.return (unsafe_v () ?fresh ?readonly file) + + let unsafe_set t k v = + try + let off = Tbl.find t.index k in + Tbl.replace t.cache k v; + set_entry t ~off k v + with Not_found -> + let offset = IO.offset t.block in + set_entry t k v; + Tbl.add t.cache k v; + Tbl.add t.index k offset + + let set t k v = + Log.debug (fun l -> l "[branches %s] set %a" (IO.name t.block) pp_branch k); + unsafe_set t k v; + W.notify t.w k (Some v) + + let equal_v_opt = Irmin.Type.(unstage (equal (option V.t))) + + let unsafe_test_and_set t k ~test ~set = + let v = try Some (Tbl.find t.cache k) with Not_found -> None in + if not (equal_v_opt v test) then Lwt.return_false + else + let return () = Lwt.return_true in + match set with + | None -> unsafe_remove t k |> return + | Some v -> unsafe_set t k v |> return + + let test_and_set t k ~test ~set = + Log.debug (fun l -> l "[branches] test-and-set %a" pp_branch k); + unsafe_test_and_set t k ~test ~set >>= function + | true -> W.notify t.w k set >|= fun () -> true + | false -> Lwt.return_false + + let list t = + Log.debug (fun l -> l "[branches] list"); + let keys = Tbl.fold (fun k _ acc -> k :: acc) t.cache [] in + Lwt.return keys + + let watch_key t = W.watch_key t.w + let watch t = W.watch t.w + let unwatch t = W.unwatch t.w + + let unsafe_close t = + t.open_instances <- t.open_instances - 1; + if t.open_instances = 0 then ( + Tbl.reset t.index; + Tbl.reset t.cache; + if not (IO.readonly t.block) then IO.flush t.block; + IO.close t.block; + W.clear t.w) + else Lwt.return_unit + + let close t = unsafe_close t + let flush t = IO.flush t.block +end + +(* FIXME: remove code duplication with irmin/atomic_write *) +module Closeable (AW : S) = struct + type t = { closed : bool ref; t : AW.t } + type key = AW.key + type value = AW.value + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + AW.mem t.t k + + let find t k = + check_not_closed t; + AW.find t.t k + + let set t k v = + check_not_closed t; + AW.set t.t k v + + let test_and_set t k ~test ~set = + check_not_closed t; + AW.test_and_set t.t k ~test ~set + + let remove t k = + check_not_closed t; + AW.remove t.t k + + let list t = + check_not_closed t; + AW.list t.t + + type watch = AW.watch + + let watch t ?init f = + check_not_closed t; + AW.watch t.t ?init f + + let watch_key t k ?init f = + check_not_closed t; + AW.watch_key t.t k ?init f + + let unwatch t w = + check_not_closed t; + AW.unwatch t.t w + + let make_closeable t = { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + AW.close t.t) + + let clear t = + check_not_closed t; + AW.clear t.t + + let flush t = + check_not_closed t; + AW.flush t.t + + let clear_keep_generation t = + check_not_closed t; + AW.clear_keep_generation t.t +end diff --git a/vendors/irmin/irmin-pack/atomic_write.mli b/vendors/irmin/irmin-pack/atomic_write.mli new file mode 100644 index 000000000000..296e19d82e48 --- /dev/null +++ b/vendors/irmin/irmin-pack/atomic_write.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Atomic_write_intf.Sigs diff --git a/vendors/irmin/irmin-pack/atomic_write_intf.ml b/vendors/irmin/irmin-pack/atomic_write_intf.ml new file mode 100644 index 000000000000..d32e1e9a53bf --- /dev/null +++ b/vendors/irmin/irmin-pack/atomic_write_intf.ml @@ -0,0 +1,46 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Irmin.ATOMIC_WRITE_STORE + + val flush : t -> unit + val clear_keep_generation : t -> unit Lwt.t +end + +module type Persistent = sig + include S + + val v : ?fresh:bool -> ?readonly:bool -> string -> t Lwt.t +end + +module type Sigs = sig + module type S = S + module type Persistent = Persistent + + module Make_persistent (_ : Version.S) (K : Irmin.Type.S) (V : Irmin.Hash.S) : + Persistent with type key = K.t and type value = V.t + + module Closeable (AW : S) : sig + include + S + with type key = AW.key + and type value = AW.value + and type watch = AW.watch + + val make_closeable : AW.t -> t + end +end diff --git a/vendors/irmin/irmin-pack/checks.ml b/vendors/irmin/irmin-pack/checks.ml new file mode 100644 index 000000000000..c322fdd3a71d --- /dev/null +++ b/vendors/irmin/irmin-pack/checks.ml @@ -0,0 +1,398 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Checks_intf +module IO = IO.Unix + +let setup_log = + let init style_renderer level = + let format_reporter = + let report _src level ~over k msgf = + let k _ = + over (); + k () + in + msgf @@ fun ?header:_ ?tags:_ fmt -> + match level with + | Logs.App -> + Fmt.kpf k Fmt.stderr + ("@[%a" ^^ fmt ^^ "@]@.") + Fmt.(styled `Bold (styled (`Fg `Cyan) string)) + ">> " + | _ -> Fmt.kpf k Fmt.stdout ("@[" ^^ fmt ^^ "@]@.") + in + { Logs.report } + in + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter format_reporter + in + Cmdliner.Term.(const init $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let path = + let open Cmdliner.Arg in + required + @@ pos 0 (some string) None + @@ info ~doc:"Path to the Irmin store on disk" ~docv:"PATH" [] + +module Make (M : Maker) = struct + module Store_V1 = M (Version.V1) + module Store_V2 = M (Version.V2) + module Hash = Store_V1.Hash + module Index = Pack_index.Make (Hash) + + let current_version = `V1 + + (** Read basic metrics from an existing store. *) + module Stat = struct + type size = Bytes of int [@@deriving irmin] + type version = [ `V1 | `V2 ] [@@deriving irmin] + + type io = { + size : size; + offset : int63; + generation : int63; + version : version; + } + [@@deriving irmin] + + type files = { pack : io option; branch : io option; dict : io option } + [@@deriving irmin] + + type objects = { nb_commits : int; nb_nodes : int; nb_contents : int } + [@@deriving irmin] + + type t = { + hash_size : size; + log_size : int; + files : files; + objects : objects; + } + [@@deriving irmin] + + let with_io : type a. Version.t -> string -> (IO.t -> a) -> a option = + fun version path f -> + match IO.exists path with + | false -> None + | true -> + let io = + IO.v ~fresh:false ~readonly:true ~version:(Some version) path + in + Fun.protect ~finally:(fun () -> IO.close io) (fun () -> Some (f io)) + + let detect_version ~root = + try + let path = Layout.pack ~root in + match with_io current_version path Fun.id with + | None -> Fmt.failwith "cannot read pack file" + | Some _ -> current_version + with Version.Invalid { expected = _; found } -> found + + let io ~version path = + with_io version path @@ fun io -> + let offset = IO.offset io in + let generation = IO.generation io in + let size = Bytes (IO.size io) in + let version = IO.version io in + { size; offset; generation; version } + + let v ~root ~version = + let pack = Layout.pack ~root |> io ~version in + let branch = Layout.branch ~root |> io ~version in + let dict = Layout.dict ~root |> io ~version in + { pack; branch; dict } + + let traverse_index ~root log_size = + let index = Index.v ~readonly:true ~fresh:false ~log_size root in + let bar, (progress_contents, progress_nodes, progress_commits) = + Utils.Progress.increment ~ppf:Format.err_formatter () + in + let f _ (_, _, (kind : Pack_value.Kind.t)) = + match kind with + | Contents -> progress_contents () + | Node | Inode -> progress_nodes () + | Commit -> progress_commits () + in + Index.iter f index; + let nb_commits, nb_nodes, nb_contents = + Utils.Progress.finalise_with_stats bar + in + { nb_commits; nb_nodes; nb_contents } + + let conf root = Conf.v ~readonly:true ~fresh:false root + + let run_versioned_store ~root version = + Logs.app (fun f -> f "Getting statistics for store: `%s'@," root); + let log_size = conf root |> Conf.index_log_size in + let objects = traverse_index ~root log_size in + let files = v ~root ~version in + { hash_size = Bytes Hash.hash_size; log_size; files; objects } + |> Irmin.Type.pp_json ~minify:false t Fmt.stdout; + Lwt.return_unit + + let run ~root = detect_version ~root |> run_versioned_store ~root + + let term_internal = + Cmdliner.Term.(const (fun root () -> Lwt_main.run (run ~root)) $ path) + + let term = + let doc = "Print high-level statistics about the store." in + Cmdliner.Term.(term_internal $ setup_log, info ~doc "stat") + end + + module Reconstruct_index = struct + let conf ~index_log_size root = + Conf.v ~readonly:false ~fresh:false ?index_log_size root + + let dest = + let open Cmdliner.Arg in + value + & pos 1 (some string) None + @@ info ~doc:"Path to the new index file" ~docv:"DEST" [] + + let index_log_size = + let open Cmdliner.Arg in + value + & opt (some int) None + @@ info ~doc:"Size of the index log file" [ "index-log-size" ] + + let run ~root ~output ?index_log_size () = + let (module Store : Versioned_store) = + match Stat.detect_version ~root with + | `V1 -> (module Store_V1) + | `V2 -> (module Store_V2) + in + let conf = conf ~index_log_size root in + match output with + | None -> Store.traverse_pack_file (`Reconstruct_index `In_place) conf + | Some p -> Store.traverse_pack_file (`Reconstruct_index (`Output p)) conf + + let term_internal = + Cmdliner.Term.( + const (fun root output index_log_size () -> + run ~root ~output ?index_log_size ()) + $ path + $ dest + $ index_log_size) + + let term = + let doc = "Reconstruct index from an existing pack file." in + Cmdliner.Term.(term_internal $ setup_log, info ~doc "reconstruct-index") + end + + module Integrity_check_index = struct + let conf root = Conf.v ~readonly:true ~fresh:false root + + let run ~root ~auto_repair () = + let (module Store : Versioned_store) = + match Stat.detect_version ~root with + | `V1 -> (module Store_V1) + | `V2 -> (module Store_V2) + in + let conf = conf root in + if auto_repair then Store.traverse_pack_file `Check_and_fix_index conf + else Store.traverse_pack_file `Check_index conf + + let auto_repair = + let open Cmdliner.Arg in + value + & (flag @@ info ~doc:"Add missing entries in index" [ "auto-repair" ]) + + let term_internal = + Cmdliner.Term.( + const (fun root auto_repair () -> run ~root ~auto_repair ()) + $ path + $ auto_repair) + + let term = + let doc = "Check index integrity." in + Cmdliner.Term. + (term_internal $ setup_log, info ~doc "integrity-check-index") + end + + module Integrity_check = struct + let conf root = Conf.v ~readonly:false ~fresh:false root + + let handle_result ?name res = + let name = match name with Some x -> x ^ ": " | None -> "" in + match res with + | Ok (`Fixed n) -> Printf.printf "%sOk -- fixed %d\n%!" name n + | Ok `No_error -> Printf.printf "%sOk\n%!" name + | Error (`Cannot_fix x) -> + Printf.eprintf "%sError -- cannot fix: %s\n%!" name x + | Error (`Corrupted x) -> + Printf.eprintf "%sError -- corrupted: %d\n%!" name x + + let run_versioned_store ~root ~auto_repair (module Store : Versioned_store) + = + let conf = conf root in + let+ repo = Store.Repo.v conf in + Store.integrity_check ~ppf:Format.err_formatter ~auto_repair repo + |> handle_result ?name:None + + let run ~root ~auto_repair = + match Stat.detect_version ~root with + | `V1 -> run_versioned_store ~root ~auto_repair (module Store_V1) + | `V2 -> run_versioned_store ~root ~auto_repair (module Store_V2) + + let term_internal = + let auto_repair = + let open Cmdliner.Arg in + value + & (flag @@ info ~doc:"Automatically repair issues" [ "auto-repair" ]) + in + Cmdliner.Term.( + const (fun root auto_repair () -> Lwt_main.run (run ~root ~auto_repair)) + $ path + $ auto_repair) + + let term = + let doc = "Check integrity of an existing store." in + Cmdliner.Term.(term_internal $ setup_log, info ~doc "integrity-check") + end + + module Integrity_check_inodes = struct + let conf root = Conf.v ~readonly:true ~fresh:false root + + let heads = + let open Cmdliner.Arg in + value + & opt (some (list ~sep:',' string)) None + & info [ "heads" ] ~doc:"List of head commit hashes" ~docv:"HEADS" + + let run_versioned_store ~root ~heads (module Store : Versioned_store) = + let conf = conf root in + let* repo = Store.Repo.v conf in + let* heads = + match heads with + | None -> Store.Repo.heads repo + | Some heads -> + Lwt_list.filter_map_s + (fun x -> + match Repr.of_string Store.Hash.t x with + | Ok x -> Store.Commit.of_hash repo x + | _ -> Lwt.return None) + heads + in + let* () = + Store.integrity_check_inodes ~heads repo >|= function + | Ok (`Msg msg) -> Logs.app (fun l -> l "Ok -- %s" msg) + | Error (`Msg msg) -> Logs.err (fun l -> l "Error -- %s" msg) + in + Store.Repo.close repo + + let run ~root ~heads = + match Stat.detect_version ~root with + | `V1 -> run_versioned_store ~root ~heads (module Store_V1) + | `V2 -> run_versioned_store ~root ~heads (module Store_V2) + + let term_internal = + Cmdliner.Term.( + const (fun root heads () -> Lwt_main.run (run ~root ~heads)) + $ path + $ heads) + + let term = + let doc = "Check integrity of inodes in an existing store." in + Cmdliner.Term. + (term_internal $ setup_log, info ~doc "integrity-check-inodes") + end + + module Cli = struct + open Cmdliner + + let main + ?(terms = + [ + Stat.term; + Reconstruct_index.term; + Integrity_check.term; + Integrity_check_inodes.term; + Integrity_check_index.term; + ]) () : empty = + let default = + let default_info = + let doc = "Check Irmin data-stores." in + Term.info ~doc "irmin-fsck" + in + Term.(ret (const (`Help (`Auto, None))), default_info) + in + Term.(eval_choice default terms |> (exit : unit result -> _)); + assert false + end + + let cli = Cli.main +end + +module Index (Index : Pack_index.S) = struct + let null = + match Sys.os_type with + | "Unix" | "Cygwin" -> "/dev/null" + | "Win32" -> "NUL" + | _ -> invalid_arg "invalid os type" + + let integrity_check ?ppf ~auto_repair ~check index = + let ppf = + match ppf with + | Some p -> p + | None -> open_out null |> Format.formatter_of_out_channel + in + Fmt.pf ppf "Running the integrity_check.\n%!"; + let nb_absent = ref 0 in + let nb_corrupted = ref 0 in + let exception Cannot_fix in + let bar, (progress_contents, progress_nodes, progress_commits) = + Utils.Progress.increment () + in + let f (k, (offset, length, (kind : Pack_value.Kind.t))) = + match kind with + | Contents -> + progress_contents (); + check ~kind:`Contents ~offset ~length k + | Node | Inode -> + progress_nodes (); + check ~kind:`Node ~offset ~length k + | Commit -> + progress_commits (); + check ~kind:`Commit ~offset ~length k + in + let result = + if auto_repair then + try + Index.filter index (fun binding -> + match f binding with + | Ok () -> true + | Error `Wrong_hash -> raise Cannot_fix + | Error `Absent_value -> + incr nb_absent; + false); + if !nb_absent = 0 then Ok `No_error else Ok (`Fixed !nb_absent) + with Cannot_fix -> Error (`Cannot_fix "Not implemented") + else ( + Index.iter + (fun k v -> + match f (k, v) with + | Ok () -> () + | Error `Wrong_hash -> incr nb_corrupted + | Error `Absent_value -> incr nb_absent) + index; + if !nb_absent = 0 && !nb_corrupted = 0 then Ok `No_error + else Error (`Corrupted (!nb_corrupted + !nb_absent))) + in + Utils.Progress.finalise bar; + result +end diff --git a/vendors/irmin/irmin-pack/checks.mli b/vendors/irmin/irmin-pack/checks.mli new file mode 100644 index 000000000000..c50636b182b7 --- /dev/null +++ b/vendors/irmin/irmin-pack/checks.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Offline stats for Irmin stores. *) + +include Checks_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/checks_intf.ml b/vendors/irmin/irmin-pack/checks_intf.ml new file mode 100644 index 000000000000..2e76e75cc702 --- /dev/null +++ b/vendors/irmin/irmin-pack/checks_intf.ml @@ -0,0 +1,144 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +type empty = | + +module type Subcommand = sig + type run + + val run : run + + val term_internal : (unit -> unit) Cmdliner.Term.t + (** A pre-packaged [Cmdliner] term for executing {!run}. *) + + val term : unit Cmdliner.Term.t * Cmdliner.Term.info + (** [term] is {!term_internal} plus documentation and logs initialisation *) +end + +module type S = sig + (** Reads basic metrics from an existing store and prints them to stdout. *) + module Stat : sig + include Subcommand with type run := root:string -> unit Lwt.t + + (** Internal implementation utilities exposed for use in other integrity + checks. *) + + type size = Bytes of int [@@deriving irmin] + type version = [ `V1 | `V2 ] [@@deriving irmin] + + type io = { + size : size; + offset : int63; + generation : int63; + version : version; + } + [@@deriving irmin] + + type files = { pack : io option; branch : io option; dict : io option } + [@@deriving irmin] + + type objects = { nb_commits : int; nb_nodes : int; nb_contents : int } + [@@deriving irmin] + + val v : root:string -> version:Version.t -> files + val detect_version : root:string -> Version.t + val traverse_index : root:string -> int -> objects + end + + module Reconstruct_index : + Subcommand + with type run := + root:string -> + output:string option -> + ?index_log_size:int -> + unit -> + unit + (** Rebuilds an index for an existing pack file *) + + (** Checks the integrity of a store *) + module Integrity_check : sig + include + Subcommand with type run := root:string -> auto_repair:bool -> unit Lwt.t + + val handle_result : + ?name:string -> + ( [< `Fixed of int | `No_error ], + [< `Cannot_fix of string | `Corrupted of int ] ) + result -> + unit + end + + (** Checks the integrity of the index in a store *) + module Integrity_check_index : sig + include + Subcommand + with type run := root:string -> auto_repair:bool -> unit -> unit + end + + (** Checks the integrity of inodes in a store *) + module Integrity_check_inodes : sig + include + Subcommand + with type run := root:string -> heads:string list option -> unit Lwt.t + end + + val cli : + ?terms:(unit Cmdliner.Term.t * Cmdliner.Term.info) list -> unit -> empty + (** Run a [Cmdliner] binary containing tools for running offline checks. + [terms] defaults to the set of checks in this module. *) +end + +module type Versioned_store = sig + include Irmin.S + include S.S with type repo := repo and type commit := commit +end + +module type Maker = functor (_ : Version.S) -> Versioned_store + +type integrity_error = [ `Wrong_hash | `Absent_value ] + +module type Sigs = sig + type integrity_error = [ `Wrong_hash | `Absent_value ] + type nonrec empty = empty + + val setup_log : unit Cmdliner.Term.t + val path : string Cmdliner.Term.t + + module type Subcommand = Subcommand + module type S = S + module type Versioned_store = Versioned_store + module type Maker = Maker + + module Make (_ : Maker) : S + + module Index (Index : Pack_index.S) : sig + val integrity_check : + ?ppf:Format.formatter -> + auto_repair:bool -> + check: + (kind:[> `Commit | `Contents | `Node ] -> + offset:int63 -> + length:int -> + Index.key -> + (unit, [< `Absent_value | `Wrong_hash ]) result) -> + Index.t -> + ( [> `Fixed of int | `No_error ], + [> `Cannot_fix of string | `Corrupted of int ] ) + result + end +end diff --git a/vendors/irmin/irmin-pack/conf.ml b/vendors/irmin/irmin-pack/conf.ml new file mode 100644 index 000000000000..fc3384b3078b --- /dev/null +++ b/vendors/irmin/irmin-pack/conf.ml @@ -0,0 +1,131 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + val entries : int + val stable_hash : int + + type inode_child_order := + [ `Seeded_hash | `Hash_bits | `Custom of depth:int -> bytes -> int ] + + val inode_child_order : inode_child_order +end + +module Default = struct + let fresh = false + let lru_size = 100_000 + let index_log_size = 2_500_000 + let readonly = false + let merge_throttle = `Block_writes + let freeze_throttle = `Block_writes +end + +let fresh_key = + Irmin.Private.Conf.key ~doc:"Start with a fresh disk." "fresh" + Irmin.Private.Conf.bool Default.fresh + +let lru_size_key = + Irmin.Private.Conf.key ~doc:"Size of the LRU cache for pack entries." + "lru-size" Irmin.Private.Conf.int Default.lru_size + +let index_log_size_key = + Irmin.Private.Conf.key ~doc:"Size of index logs." "index-log-size" + Irmin.Private.Conf.int Default.index_log_size + +let readonly_key = + Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly" + Irmin.Private.Conf.bool Default.readonly + +type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin] + +let merge_throttle_converter : merge_throttle Irmin.Private.Conf.converter = + let parse = function + | "block-writes" -> Ok `Block_writes + | "overcommit-memory" -> Ok `Overcommit_memory + | s -> + Fmt.error_msg + "invalid %s, expected one of: `block-writes' or `overcommit-memory'" s + in + let print = + Fmt.of_to_string (function + | `Block_writes -> "block-writes" + | `Overcommit_memory -> "overcommit-memory") + in + (parse, print) + +type freeze_throttle = [ `Block_writes | `Overcommit_memory | `Cancel_existing ] +[@@deriving irmin] + +let freeze_throttle_converter : freeze_throttle Irmin.Private.Conf.converter = + let parse = function + | "block-writes" -> Ok `Block_writes + | "overcommit-memory" -> Ok `Overcommit_memory + | "cancel-existing" -> Ok `Cancel_existing + | s -> + Fmt.error_msg + "invalid %s, expected one of: `block-writes, `overcommit-memory' or \ + `cancel-existing'" + s + in + let print = + Fmt.of_to_string (function + | `Block_writes -> "block-writes" + | `Overcommit_memory -> "overcommit-memory" + | `Cancel_existing -> "cancel-existing") + in + (parse, print) + +let merge_throttle_key = + Irmin.Private.Conf.key + ~doc:"Strategy to use for large writes when index caches are full." + "merge-throttle" merge_throttle_converter Default.merge_throttle + +let freeze_throttle_key = + Irmin.Private.Conf.key ~doc:"Strategy to use for long-running freezes." + "freeze-throttle" freeze_throttle_converter Default.freeze_throttle + +let fresh config = Irmin.Private.Conf.get config fresh_key +let lru_size config = Irmin.Private.Conf.get config lru_size_key +let readonly config = Irmin.Private.Conf.get config readonly_key +let index_log_size config = Irmin.Private.Conf.get config index_log_size_key +let merge_throttle config = Irmin.Private.Conf.get config merge_throttle_key +let freeze_throttle config = Irmin.Private.Conf.get config freeze_throttle_key +let root_key = Irmin.Private.Conf.root + +let root config = + match Irmin.Private.Conf.get config root_key with + | None -> failwith "no root set" + | Some r -> r + +let v ?(fresh = Default.fresh) ?(readonly = Default.readonly) + ?(lru_size = Default.lru_size) ?(index_log_size = Default.index_log_size) + ?(merge_throttle = Default.merge_throttle) + ?(freeze_throttle = Default.freeze_throttle) root = + let config = Irmin.Private.Conf.empty in + let config = Irmin.Private.Conf.add config fresh_key fresh in + let config = Irmin.Private.Conf.add config root_key (Some root) in + let config = Irmin.Private.Conf.add config lru_size_key lru_size in + let config = + Irmin.Private.Conf.add config index_log_size_key index_log_size + in + let config = Irmin.Private.Conf.add config readonly_key readonly in + let config = + Irmin.Private.Conf.add config merge_throttle_key merge_throttle + in + let config = + Irmin.Private.Conf.add config freeze_throttle_key freeze_throttle + in + config diff --git a/vendors/irmin/irmin-pack/conf.mli b/vendors/irmin/irmin-pack/conf.mli new file mode 100644 index 000000000000..bb884bd67e86 --- /dev/null +++ b/vendors/irmin/irmin-pack/conf.mli @@ -0,0 +1,58 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + val entries : int + val stable_hash : int + + type inode_child_order := + [ `Seeded_hash (** use a non-crypto seeded-hash of the step *) + | `Hash_bits (** crypto hash the step and extract the relevant bits. *) + | `Custom of depth:int -> bytes -> int (** use a custom index *) ] + + val inode_child_order : inode_child_order +end + +val fresh_key : bool Irmin.Private.Conf.key +val lru_size_key : int Irmin.Private.Conf.key +val index_log_size_key : int Irmin.Private.Conf.key +val readonly_key : bool Irmin.Private.Conf.key +val root_key : string option Irmin.Private.Conf.key +val fresh : Irmin.Private.Conf.t -> bool +val lru_size : Irmin.Private.Conf.t -> int +val index_log_size : Irmin.Private.Conf.t -> int +val readonly : Irmin.Private.Conf.t -> bool + +type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin] + +val merge_throttle_key : merge_throttle Irmin.Private.Conf.key +val merge_throttle : Irmin.Private.Conf.t -> merge_throttle + +type freeze_throttle = [ merge_throttle | `Cancel_existing ] [@@deriving irmin] + +val freeze_throttle_key : freeze_throttle Irmin.Private.Conf.key +val freeze_throttle : Irmin.Private.Conf.t -> freeze_throttle +val root : Irmin.Private.Conf.t -> string + +val v : + ?fresh:bool -> + ?readonly:bool -> + ?lru_size:int -> + ?index_log_size:int -> + ?merge_throttle:merge_throttle -> + ?freeze_throttle:freeze_throttle -> + string -> + Irmin.config diff --git a/vendors/irmin/irmin-pack/content_addressable.ml b/vendors/irmin/irmin-pack/content_addressable.ml new file mode 100644 index 000000000000..b445c9499be1 --- /dev/null +++ b/vendors/irmin/irmin-pack/content_addressable.ml @@ -0,0 +1,83 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Content_addressable_intf +open! Import + +(* FIXME: remove code duplication with irmin/content_addressable *) +module Closeable (S : S) = struct + type 'a t = { closed : bool ref; t : 'a S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let unsafe_append ~ensure_unique ~overcommit t k v = + check_not_closed t; + S.unsafe_append ~ensure_unique ~overcommit t.t k v + + let unsafe_mem t k = + check_not_closed t; + S.unsafe_mem t.t k + + let unsafe_find ~check_integrity t k = + check_not_closed t; + S.unsafe_find ~check_integrity t.t k + + let clear t = + check_not_closed t; + S.clear t.t + + let generation t = + check_not_closed t; + S.generation t.t + + let clear_keep_generation t = + check_not_closed t; + S.clear_keep_generation t.t + + let make_closeable t = { closed = ref false; t } + + let get_open_exn t = + check_not_closed t; + t.t +end diff --git a/vendors/irmin/irmin-pack/content_addressable.mli b/vendors/irmin/irmin-pack/content_addressable.mli new file mode 100644 index 000000000000..c0ed69e66422 --- /dev/null +++ b/vendors/irmin/irmin-pack/content_addressable.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +include Content_addressable_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/content_addressable_intf.ml b/vendors/irmin/irmin-pack/content_addressable_intf.ml new file mode 100644 index 000000000000..97eef67006e7 --- /dev/null +++ b/vendors/irmin/irmin-pack/content_addressable_intf.ml @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + include Irmin.CONTENT_ADDRESSABLE_STORE + + val add : 'a t -> value -> key Lwt.t + (** Overwrite [add] to work with a read-only database handler. *) + + val unsafe_add : 'a t -> key -> value -> unit Lwt.t + (** Overwrite [unsafe_add] to work with a read-only database handler. *) + + val unsafe_append : + ensure_unique:bool -> overcommit:bool -> 'a t -> key -> value -> unit + + val unsafe_mem : 'a t -> key -> bool + val unsafe_find : check_integrity:bool -> 'a t -> key -> value option + + val generation : 'a t -> int63 + (** The number of times that {!clear} has been called on this store. *) + + val clear_keep_generation : 'a t -> unit Lwt.t + val close : _ t -> unit Lwt.t + val batch : read t -> ([ read | write ] t -> 'a Lwt.t) -> 'a Lwt.t +end + +module type Maker = sig + type key + + (** Save multiple kind of values in the same pack file. Values will be + distinguished using [V.kind], so they have to all be different. *) + module Make (V : Pack_value.S with type hash := key) : + S with type key = key and type value = V.t +end + +module type Sigs = sig + module type S = S + + module Closeable (CA : S) : sig + include S with type key = CA.key and type value = CA.value + + val make_closeable : 'a CA.t -> 'a t + val get_open_exn : 'a t -> 'a CA.t + end +end diff --git a/vendors/irmin/irmin-pack/dict.ml b/vendors/irmin/irmin-pack/dict.ml new file mode 100644 index 000000000000..657130ffa7e9 --- /dev/null +++ b/vendors/irmin/irmin-pack/dict.ml @@ -0,0 +1,124 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Dict_intf +open! Import + +module Make (V : Version.S) (IO : IO.S) : S = struct + type t = { + capacity : int; + cache : (string, int) Hashtbl.t; + index : (int, string) Hashtbl.t; + mutable io : IO.t; + mutable open_instances : int; + } + + let int32_to_bin = Irmin.Type.(unstage (to_bin_string int32)) + let decode_int32 = Irmin.Type.(unstage (decode_bin int32)) + + let append_string t v = + let len = Int32.of_int (String.length v) in + let buf = int32_to_bin len ^ v in + IO.append t.io buf + + let refill ~from t = + let len = Int63.to_int (IO.offset t.io -- from) in + let raw = Bytes.create len in + let n = IO.read t.io ~off:from raw in + assert (n = len); + let raw = Bytes.unsafe_to_string raw in + let rec aux n offset = + if offset >= len then () + else + let _, v = decode_int32 raw offset in + let len = Int32.to_int v in + let v = String.sub raw (offset + 4) len in + Hashtbl.add t.cache v n; + Hashtbl.add t.index n v; + (aux [@tailcall]) (n + 1) (offset + 4 + len) + in + (aux [@tailcall]) (Hashtbl.length t.cache) 0 + + let sync_offset t = + let former_offset = IO.offset t.io in + let former_generation = IO.generation t.io in + let h = IO.force_headers t.io in + if former_generation <> h.generation then ( + IO.close t.io; + let io = + IO.v ~fresh:false ~readonly:true ~version:(Some V.version) + (IO.name t.io) + in + t.io <- io; + Hashtbl.clear t.cache; + Hashtbl.clear t.index; + refill ~from:Int63.zero t) + else if h.offset > former_offset then refill ~from:former_offset t + + let sync t = + if IO.readonly t.io then sync_offset t + else invalid_arg "only a readonly instance should call this function" + + let flush t = IO.flush t.io + + let index t v = + Log.debug (fun l -> l "[dict] index %S" v); + try Some (Hashtbl.find t.cache v) + with Not_found -> + let id = Hashtbl.length t.cache in + if id > t.capacity then None + else ( + if IO.readonly t.io then raise S.RO_not_allowed; + append_string t v; + Hashtbl.add t.cache v id; + Hashtbl.add t.index id v; + Some id) + + let find t id = + Log.debug (fun l -> l "[dict] find %d" id); + let v = try Some (Hashtbl.find t.index id) with Not_found -> None in + v + + let clear t = + match V.version with + | `V1 -> IO.truncate t.io + | `V2 -> + IO.clear t.io; + Hashtbl.clear t.cache; + Hashtbl.clear t.index + + let v ?(fresh = true) ?(readonly = false) ?(capacity = 100_000) file = + let io = IO.v ~fresh ~version:(Some V.version) ~readonly file in + let cache = Hashtbl.create 997 in + let index = Hashtbl.create 997 in + let t = { capacity; index; cache; io; open_instances = 1 } in + refill ~from:Int63.zero t; + t + + let close t = + t.open_instances <- t.open_instances - 1; + if t.open_instances = 0 then ( + if not (IO.readonly t.io) then flush t; + IO.close t.io; + Hashtbl.reset t.cache; + Hashtbl.reset t.index) + + let valid t = + if t.open_instances <> 0 then ( + t.open_instances <- t.open_instances + 1; + true) + else false +end diff --git a/vendors/irmin/irmin-pack/dict.mli b/vendors/irmin/irmin-pack/dict.mli new file mode 100644 index 000000000000..4be3fb7c58f0 --- /dev/null +++ b/vendors/irmin/irmin-pack/dict.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Dict_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/dict_intf.ml b/vendors/irmin/irmin-pack/dict_intf.ml new file mode 100644 index 000000000000..32b8303fb92b --- /dev/null +++ b/vendors/irmin/irmin-pack/dict_intf.ml @@ -0,0 +1,37 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + type t + + val find : t -> int -> string option + val index : t -> string -> int option + val flush : t -> unit + + val sync : t -> unit + (** syncs a readonly dict with the file on disk. *) + + val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t + val clear : t -> unit + val close : t -> unit + val valid : t -> bool +end + +module type Sigs = sig + module type S = S + + module Make (_ : Version.S) (_ : IO.S) : S +end diff --git a/vendors/irmin/irmin-pack/dune b/vendors/irmin/irmin-pack/dune new file mode 100644 index 000000000000..94c64a78eb60 --- /dev/null +++ b/vendors/irmin/irmin-pack/dune @@ -0,0 +1,7 @@ +(library + (public_name irmin-pack) + (name irmin_pack) + (libraries fmt index index.unix irmin irmin-layers logs lwt lwt.unix mtime + ppx_irmin cmdliner optint) + (preprocess + (pps ppx_irmin))) diff --git a/vendors/irmin/irmin-pack/ext.ml b/vendors/irmin/irmin-pack/ext.ml new file mode 100644 index 000000000000..275299ebe0e1 --- /dev/null +++ b/vendors/irmin/irmin-pack/ext.ml @@ -0,0 +1,249 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module IO = IO.Unix + +module Maker + (V : Version.S) + (Config : Conf.S) + (Node : Irmin.Private.Node.Maker) + (Commit : Irmin.Private.Commit.Maker) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) = +struct + module Index = Pack_index.Make (H) + module Pack = Pack_store.Maker (V) (Index) (H) + module Dict = Pack_dict.Make (V) + + module X = struct + module Hash = H + + type 'a value = { hash : H.t; kind : Pack_value.Kind.t; v : 'a } + [@@deriving irmin] + + module Contents = struct + module Pack_value = Pack_value.Of_contents (H) (C) + + module CA = struct + module Key = H + module Val = C + include Pack.Make (Pack_value) + end + + include Irmin.Contents.Store (CA) + end + + module Node = struct + module Node = Node (H) (P) (M) + + module CA = struct + module Inter = Inode.Make_internal (Config) (H) (Node) + include Inode.Make_persistent (H) (Node) (Inter) (Pack) + end + + include Irmin.Private.Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module Commit = Commit (H) + module Pack_value = Pack_value.Of_commit (H) (Commit) + + module CA = struct + module Key = H + module Val = Commit + include Pack.Make (Pack_value) + end + + include Irmin.Private.Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + module AW = Atomic_write.Make_persistent (V) (Key) (Val) + include Atomic_write.Closeable (AW) + + let v ?fresh ?readonly path = + AW.v ?fresh ?readonly path >|= make_closeable + end + + module Slice = Irmin.Private.Slice.Make (Contents) (Node) (Commit) + module Sync = Irmin.Private.Sync.None (H) (B) + + module Repo = struct + type t = { + config : Irmin.Private.Conf.t; + contents : read Contents.CA.t; + node : read Node.CA.t; + commit : read Commit.CA.t; + branch : Branch.t; + index : Index.t; + } + + let contents_t t : 'a Contents.t = t.contents + let node_t t : 'a Node.t = (contents_t t, t.node) + let commit_t t : 'a Commit.t = (node_t t, t.commit) + let branch_t t = t.branch + + let batch t f = + Commit.CA.batch t.commit (fun commit -> + Node.CA.batch t.node (fun node -> + Contents.CA.batch t.contents (fun contents -> + let contents : 'a Contents.t = contents in + let node : 'a Node.t = (contents, node) in + let commit : 'a Commit.t = (node, commit) in + f contents node commit))) + + let unsafe_v config = + let root = Conf.root config in + let fresh = Conf.fresh config in + let lru_size = Conf.lru_size config in + let readonly = Conf.readonly config in + let log_size = Conf.index_log_size config in + let throttle = Conf.merge_throttle config in + let f = ref (fun () -> ()) in + let index = + Index.v + ~flush_callback:(fun () -> !f ()) + (* backpatching to add pack flush before an index flush *) + ~fresh ~readonly ~throttle ~log_size root + in + let* contents = Contents.CA.v ~fresh ~readonly ~lru_size ~index root in + let* node = Node.CA.v ~fresh ~readonly ~lru_size ~index root in + let* commit = Commit.CA.v ~fresh ~readonly ~lru_size ~index root in + let+ branch = Branch.v ~fresh ~readonly root in + (* Stores share instances in memory, one flush is enough. In case of a + system crash, the flush_callback might not make with the disk. In + this case, when the store is reopened, [integrity_check] needs to be + called to repair the store. *) + (f := fun () -> Contents.CA.flush ~index:false contents); + { contents; node; commit; branch; config; index } + + let close t = + Index.close t.index; + Contents.CA.close (contents_t t) >>= fun () -> + Node.CA.close (snd (node_t t)) >>= fun () -> + Commit.CA.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch + + let v config = + Lwt.catch + (fun () -> unsafe_v config) + (function + | Version.Invalid { expected; found } as e when expected = V.version + -> + Log.err (fun m -> + m "[%s] Attempted to open store of unsupported version %a" + (Conf.root config) Version.pp found); + Lwt.fail e + | e -> Lwt.fail e) + + (** Stores share instances in memory, one sync is enough. However each + store has its own lru and all have to be cleared. *) + let sync t = + let on_generation_change () = + Node.CA.clear_caches (snd (node_t t)); + Commit.CA.clear_caches (snd (commit_t t)) + in + Contents.CA.sync ~on_generation_change (contents_t t) + + (** Stores share instances so one clear is enough. *) + let clear t = Contents.CA.clear (contents_t t) + + let flush t = + Contents.CA.flush (contents_t t); + Branch.flush t.branch + end + end + + let integrity_check ?ppf ~auto_repair t = + let module Checks = Checks.Index (Index) in + let contents = X.Repo.contents_t t in + let nodes = X.Repo.node_t t |> snd in + let commits = X.Repo.commit_t t |> snd in + let check ~kind ~offset ~length k = + match kind with + | `Contents -> X.Contents.CA.integrity_check ~offset ~length k contents + | `Node -> X.Node.CA.integrity_check ~offset ~length k nodes + | `Commit -> X.Commit.CA.integrity_check ~offset ~length k commits + in + Checks.integrity_check ?ppf ~auto_repair ~check t.index + + include Irmin.Of_private (X) + + let ignore_invalid_depth f t k = + Lwt.catch + (fun () -> f t k) + (function + | X.Node.CA.Inter.Raw.Invalid_depth _ -> Lwt.return [] | e -> Lwt.fail e) + + let integrity_check_inodes ?heads t = + Log.debug (fun l -> l "Check integrity for inodes"); + let bar, (_, progress_nodes, progress_commits) = + Utils.Progress.increment () + in + let errors = ref [] in + let nodes = X.Repo.node_t t |> snd in + let pred_node = ignore_invalid_depth Repo.default_pred_node in + let node k = + progress_nodes (); + X.Node.CA.integrity_check_inodes nodes k >|= function + | Ok () -> () + | Error msg -> errors := msg :: !errors + in + let commit _ = + progress_commits (); + Lwt.return_unit + in + let* heads = + match heads with None -> Repo.heads t | Some m -> Lwt.return m + in + let hashes = List.map (fun x -> `Commit (Commit.hash x)) heads in + let+ () = + Repo.iter ~cache_size:1_000_000 ~min:[] ~max:hashes ~pred_node ~node + ~commit t + in + Utils.Progress.finalise bar; + let pp_commits = Fmt.list ~sep:Fmt.comma Commit.pp_hash in + if !errors = [] then + Fmt.kstr (fun x -> Ok (`Msg x)) "Ok for heads %a" pp_commits heads + else + Fmt.kstr + (fun x -> Error (`Msg x)) + "Inconsistent inodes found for heads %a: %a" pp_commits heads + Fmt.(list ~sep:comma string) + !errors + + let sync = X.Repo.sync + let clear = X.Repo.clear + let migrate = Migrate.run + let flush = X.Repo.flush + + module Traverse_pack_file = Traverse_pack_file.Make (struct + module Version = V + module Hash = H + module Index = Index + module Inode = X.Node.CA + module Dict = Dict + module Contents = X.Contents.Pack_value + module Commit = X.Commit.Pack_value + end) + + let traverse_pack_file = Traverse_pack_file.run +end diff --git a/vendors/irmin/irmin-pack/ext.mli b/vendors/irmin/irmin-pack/ext.mli new file mode 100644 index 000000000000..904ef641067f --- /dev/null +++ b/vendors/irmin/irmin-pack/ext.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Maker + (_ : Version.S) + (_ : Conf.S) + (N : Irmin.Private.Node.Maker) + (CT : Irmin.Private.Commit.Maker) : S.Maker diff --git a/vendors/irmin/irmin-pack/import.ml b/vendors/irmin/irmin-pack/import.ml new file mode 100644 index 000000000000..0b08b7e1cf1b --- /dev/null +++ b/vendors/irmin/irmin-pack/import.ml @@ -0,0 +1,32 @@ +(* + * Copyright (c)2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends + +let src = Logs.Src.create "irmin.pack" ~doc:"irmin-pack backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Int63 = struct + include Optint.Int63 + + let t = Irmin.Type.int63 +end + +type int63 = Int63.t [@@deriving irmin] + +let ( ++ ) = Int63.add +let ( -- ) = Int63.sub diff --git a/vendors/irmin/irmin-pack/inode.ml b/vendors/irmin/irmin-pack/inode.ml new file mode 100644 index 000000000000..90b9bb8de546 --- /dev/null +++ b/vendors/irmin/irmin-pack/inode.ml @@ -0,0 +1,1670 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Inode_intf + +module Make_internal + (Conf : Conf.S) + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S with type hash = H.t) = +struct + let () = + if Conf.entries > Conf.stable_hash then + invalid_arg "entries should be lower or equal to stable_hash" + + module Node = struct + include Node + module H = Irmin.Hash.Typed (H) (Node) + + let hash = H.hash + end + + (* Keep at most 50 bits of information. *) + let max_depth = int_of_float (log (2. ** 50.) /. log (float Conf.entries)) + + module T = struct + type hash = H.t [@@deriving irmin ~pp ~to_bin_string] + type step = Node.step [@@deriving irmin ~to_bin_string] + type metadata = Node.metadata [@@deriving irmin] + type value = Node.value [@@deriving irmin] + + let default = Node.default + + exception Dangling_hash = Node.Dangling_hash + end + + module Step = + Irmin.Hash.Typed + (H) + (struct + type t = T.step + + let t = T.step_t + end) + + exception Max_depth of int + + module Index : sig + type key + + val key : T.step -> key + val index : depth:int -> key -> int + end = struct + open T + + type key = bytes + + let log_entry = int_of_float (log (float Conf.entries) /. log 2.) + + let () = + assert (log_entry <> 0); + assert (Conf.entries = int_of_float (2. ** float log_entry)) + + let key = + match Conf.inode_child_order with + | `Hash_bits -> + fun s -> Bytes.unsafe_of_string (hash_to_bin_string (Step.hash s)) + | `Seeded_hash | `Custom _ -> + fun s -> Bytes.unsafe_of_string (step_to_bin_string s) + + (* Assume [k = cryto_hash(step)] (see {!key}) and [Conf.entry] can + can represented with [n] bits. Then, [hash_bits ~depth k] is + the [n]-bits integer [i] with the following binary representation: + + [k(n*depth) ... k(n*depth+n-1)] + + When [n] is not a power of 2, [hash_bits] needs to handle + unaligned reads properly. *) + let hash_bits ~depth k = + let byte = 8 in + let n = depth * log_entry / byte in + let r = depth * log_entry mod byte in + if n >= Bytes.length k then raise (Max_depth depth); + if r + log_entry <= byte then + let i = Bytes.get_uint8 k n in + let e0 = i lsr (byte - log_entry - r) in + let r0 = e0 land (Conf.entries - 1) in + r0 + else + let i0 = Bytes.get_uint8 k n in + let to_read = byte - r in + let rest = log_entry - to_read in + let mask = (1 lsl to_read) - 1 in + let r0 = (i0 land mask) lsl rest in + if n + 1 >= Bytes.length k then raise (Max_depth depth); + let i1 = Bytes.get_uint8 k (n + 1) in + let r1 = i1 lsr (byte - rest) in + r0 + r1 + + let short_hash = Irmin.Type.(unstage (short_hash bytes)) + let seeded_hash ~depth k = abs (short_hash ~seed:depth k) mod Conf.entries + + let index = + match Conf.inode_child_order with + | `Seeded_hash -> seeded_hash + | `Hash_bits -> hash_bits + | `Custom f -> f + end + + module StepMap = struct + include Map.Make (struct + type t = T.step + + let compare = Irmin.Type.(unstage (compare T.step_t)) + end) + + let of_list l = List.fold_left (fun acc (k, v) -> add k v acc) empty l + end + + (* Binary representation, useful to compute hashes *) + module Bin = struct + open T + + type ptr = { index : int; hash : H.t } [@@deriving irmin] + + type tree = { depth : int; length : int; entries : ptr list } + [@@deriving irmin] + + type v = Values of (step * value) list | Tree of tree [@@deriving irmin] + + module V = + Irmin.Hash.Typed + (H) + (struct + type t = v + + let t = v_t + end) + + type t = { hash : H.t Lazy.t; stable : bool; v : v } + + let pre_hash_v = Irmin.Type.(unstage (pre_hash v_t)) + + let t : t Irmin.Type.t = + let open Irmin.Type in + let pre_hash x = pre_hash_v x.v in + record "Bin.t" (fun hash stable v -> { hash = lazy hash; stable; v }) + |+ field "hash" H.t (fun t -> Lazy.force t.hash) + |+ field "stable" bool (fun t -> t.stable) + |+ field "v" v_t (fun t -> t.v) + |> sealr + |> like ~pre_hash + + let v ~stable ~hash v = { stable; hash; v } + let hash t = Lazy.force t.hash + + let depth t = + match t.v with + | Values _ -> if t.stable then Some 0 else None + | Tree t -> Some t.depth + end + + (* Compressed binary representation *) + module Compress = struct + open T + + type name = Indirect of int | Direct of step + type address = Indirect of int63 | Direct of H.t + + let address_t : address Irmin.Type.t = + let open Irmin.Type in + variant "Compress.address" (fun i d -> function + | Indirect x -> i x | Direct x -> d x) + |~ case1 "Indirect" int63_t (fun x -> Indirect x) + |~ case1 "Direct" H.t (fun x -> Direct x) + |> sealv + + type ptr = { index : int; hash : address } + + let ptr_t : ptr Irmin.Type.t = + let open Irmin.Type in + record "Compress.ptr" (fun index hash -> { index; hash }) + |+ field "index" int (fun t -> t.index) + |+ field "hash" address_t (fun t -> t.hash) + |> sealr + + type tree = { depth : int; length : int; entries : ptr list } + + let tree_t : tree Irmin.Type.t = + let open Irmin.Type in + record "Compress.tree" (fun depth length entries -> + { depth; length; entries }) + |+ field "depth" int (fun t -> t.depth) + |+ field "length" int (fun t -> t.length) + |+ field "entries" (list ptr_t) (fun t -> t.entries) + |> sealr + + type value = + | Contents of name * address * metadata + | Node of name * address + + let is_default = Irmin.Type.(unstage (equal T.metadata_t)) T.default + + let value_t : value Irmin.Type.t = + let open Irmin.Type in + variant "Compress.value" + (fun + contents_ii + contents_x_ii + node_ii + contents_id + contents_x_id + node_id + contents_di + contents_x_di + node_di + contents_dd + contents_x_dd + node_dd + -> function + | Contents (Indirect n, Indirect h, m) -> + if is_default m then contents_ii (n, h) else contents_x_ii (n, h, m) + | Node (Indirect n, Indirect h) -> node_ii (n, h) + | Contents (Indirect n, Direct h, m) -> + if is_default m then contents_id (n, h) else contents_x_id (n, h, m) + | Node (Indirect n, Direct h) -> node_id (n, h) + | Contents (Direct n, Indirect h, m) -> + if is_default m then contents_di (n, h) else contents_x_di (n, h, m) + | Node (Direct n, Indirect h) -> node_di (n, h) + | Contents (Direct n, Direct h, m) -> + if is_default m then contents_dd (n, h) else contents_x_dd (n, h, m) + | Node (Direct n, Direct h) -> node_dd (n, h)) + |~ case1 "contents-ii" (pair int Int63.t) (fun (n, i) -> + Contents (Indirect n, Indirect i, T.default)) + |~ case1 "contents-x-ii" (triple int int63_t metadata_t) (fun (n, i, m) -> + Contents (Indirect n, Indirect i, m)) + |~ case1 "node-ii" (pair int Int63.t) (fun (n, i) -> + Node (Indirect n, Indirect i)) + |~ case1 "contents-id" (pair int H.t) (fun (n, h) -> + Contents (Indirect n, Direct h, T.default)) + |~ case1 "contents-x-id" (triple int H.t metadata_t) (fun (n, h, m) -> + Contents (Indirect n, Direct h, m)) + |~ case1 "node-id" (pair int H.t) (fun (n, h) -> + Node (Indirect n, Direct h)) + |~ case1 "contents-di" (pair step_t Int63.t) (fun (n, i) -> + Contents (Direct n, Indirect i, T.default)) + |~ case1 "contents-x-di" (triple step_t int63_t metadata_t) + (fun (n, i, m) -> Contents (Direct n, Indirect i, m)) + |~ case1 "node-di" (pair step_t Int63.t) (fun (n, i) -> + Node (Direct n, Indirect i)) + |~ case1 "contents-dd" (pair step_t H.t) (fun (n, i) -> + Contents (Direct n, Direct i, T.default)) + |~ case1 "contents-x-dd" (triple step_t H.t metadata_t) (fun (n, i, m) -> + Contents (Direct n, Direct i, m)) + |~ case1 "node-dd" (pair step_t H.t) (fun (n, i) -> + Node (Direct n, Direct i)) + |> sealv + + type v = Values of value list | Tree of tree + + let v_t : v Irmin.Type.t = + let open Irmin.Type in + variant "Compress.v" (fun values tree -> function + | Values x -> values x | Tree x -> tree x) + |~ case1 "Values" (list value_t) (fun x -> Values x) + |~ case1 "Tree" tree_t (fun x -> Tree x) + |> sealv + + type t = { hash : H.t; stable : bool; v : v } + + let v ~stable ~hash v = { hash; stable; v } + let kind_node = Pack_value.Kind.Node + let kind_inode = Pack_value.Kind.Inode + let magic_node = Pack_value.Kind.to_magic kind_node + let magic_inode = Pack_value.Kind.to_magic kind_inode + + let stable_t : bool Irmin.Type.t = + Irmin.Type.(map char) + (fun n -> n = magic_node) + (function true -> magic_node | false -> magic_inode) + + let t = + let open Irmin.Type in + record "Compress.t" (fun hash stable v -> { hash; stable; v }) + |+ field "hash" H.t (fun t -> t.hash) + |+ field "stable" stable_t (fun t -> t.stable) + |+ field "v" v_t (fun t -> t.v) + |> sealr + end + + (** [Val_impl] defines the recursive structure of inodes. + + {3 Inode Layout} + + {4 Layout Types} + + The layout ['a layout] associated to an inode ['a t] defines certain + properties of the inode: + + - When [Total], the inode is self contained and immutable. + - When [Partial], chunks of the inode might be missing but they can be + fetched from the backend when needed using the available [find] function + stored in the layout. Mutable pointers act as cache. + - When [Truncated], chunks of the inode might be missing. Those chunks are + unreachable because the pointer to the backend is missing. The inode is + immutable. + + {4 Layout Instantiation} + + The layout of an inode is determined from the module [Val], it depends on + the way the inode was constructed: + + - When [Total], it originates from [Val.v] or [Val.empty]. + - When [Partial], it originates from [Val.of_bin], which is only used by + [Inode.find]. + - When [Truncated], it originates from an [Irmin.Type] deserialisation + made possible by [Val.t]. + + Almost all other functions in [Val_impl] are polymorphic regarding the + layout of the manipulated inode. + + {4 Details on the [Truncated] Layout} + + The [Truncated] layout is identical to [Partial] except for the missing + [find] function. + + On the one hand, when creating the root of a [Truncated] inode, the + pointers to children inodes - if any - are set to the [Broken] tag, + meaning that we know the hash to such children but we will have to way to + load them in the future. On the other hand, when adding children to a + [Truncated] inode, there is no such problem, the pointer is then set to + the [Intact] tag. + + As of Irmin 2.4 (February 2021), inode deserialisation using Repr happens + in [irmin/slice.ml] and [irmin/sync_ext.ml], and maybe some other places. + + At some point we might want to forbid such deserialisations and instead + use something in the flavour of [Val.of_bin] to create [Partial] inodes. + + {3 Topmost Inode Ancestor} + + [Val_impl.t] is a recursive type, it is labelled with a [depth] integer + that indicates the recursion depth. An inode with [depth = 0] corresponds + to the root of a directory, its hash is the hash of the directory. + + A [Val.t] points to the topmost [Val_impl.t] of an inode tree. In most + scenarios, that topmost inode has [depth = 0], but it is also legal for + the topmost inode to be an intermediate inode, i.e. with [depth > 0]. + + The only way for an inode tree to have an intermediate inode as root is to + fetch it from the backend by calling [Make_ext.find], using the hash of + that inode. + + Write-only operations are not permitted when the root is an intermediate + inode. *) + module Val_impl = struct + open T + + let equal_value = Irmin.Type.(unstage (equal value_t)) + + type _ layout = + | Total : total_ptr layout + | Partial : find -> partial_ptr layout + | Truncated : truncated_ptr layout + + and find = expected_depth:int -> hash -> partial_ptr t option + + and partial_ptr_target = + | Dirty of partial_ptr t + | Lazy of hash + | Lazy_loaded of partial_ptr t + (** A partial pointer differentiates the [Dirty] and [Lazy_loaded] + cases in order to remember that only the latter should be + collected when [clear] is called. + + The child in [Lazy_loaded] can only emanate from the disk. It can + be savely collected on [clear]. + + The child in [Dirty] can only emanate from a user modification, + e.g. through the [add] or [to_concrete] functions. It shouldn't be + collected on [clear] because it will be needed for [save]. *) + + and partial_ptr = { mutable target : partial_ptr_target } + + and total_ptr = Total_ptr of total_ptr t [@@unboxed] + + and truncated_ptr = Broken of hash | Intact of truncated_ptr t + + and 'ptr tree = { depth : int; length : int; entries : 'ptr option array } + + and 'ptr v = Values of value StepMap.t | Tree of 'ptr tree + + and 'ptr t = { hash : hash Lazy.t; stable : bool; v : 'ptr v } + + let depth_of_v = function Values _ -> None | Tree t -> Some t.depth + let depth t = if t.stable then Some 0 else depth_of_v t.v + + module Ptr = struct + let hash : type ptr. ptr layout -> ptr -> _ = function + | Total -> fun (Total_ptr ptr) -> Lazy.force ptr.hash + | Partial _ -> ( + fun { target } -> + match target with + | Lazy hash -> hash + | Dirty { hash; _ } | Lazy_loaded { hash; _ } -> Lazy.force hash) + | Truncated -> ( + function Broken h -> h | Intact ptr -> Lazy.force ptr.hash) + + let target : + type ptr. + depth:int -> + cache:bool -> + force:bool -> + string -> + ptr layout -> + ptr -> + ptr t = + fun ~depth ~cache ~force context layout -> + match layout with + | Total -> fun (Total_ptr t) -> t + | Partial find -> ( + function + | { target = Dirty entry } | { target = Lazy_loaded entry } -> + (* [target] is already cached. [cache] is only concerned with + new cache entries, not the older ones for which the irmin + users can discard using [clear]. *) + entry + | { target = Lazy _ } as t -> ( + let h = hash layout t in + if not force then raise (Dangling_hash { context; hash = h }) + else + match find ~expected_depth:depth h with + | None -> raise (Dangling_hash { context; hash = h }) + | Some x -> + if cache then t.target <- Lazy_loaded x; + x)) + | Truncated -> ( + function + | Intact entry -> entry + | Broken h -> raise (Dangling_hash { context; hash = h })) + + let of_target : type ptr. ptr layout -> ptr t -> ptr = function + | Total -> fun target -> Total_ptr target + | Partial _ -> fun target -> { target = Dirty target } + | Truncated -> fun target -> Intact target + + let of_hash : type ptr. ptr layout -> hash -> ptr = function + | Total -> assert false + | Partial _ -> fun hash -> { target = Lazy hash } + | Truncated -> fun hash -> Broken hash + + let save : + type ptr. + broken:(hash -> unit) -> + save_dirty:(ptr t -> unit) -> + clear:bool -> + ptr layout -> + ptr -> + unit = + fun ~broken ~save_dirty ~clear -> function + | Total -> fun (Total_ptr entry) -> (save_dirty [@tailcall]) entry + | Partial _ -> ( + function + | { target = Dirty entry } as box -> + if clear then box.target <- Lazy (Lazy.force entry.hash) + else + (* Promote from dirty to lazy as it will be saved during + [save_dirty]. *) + box.target <- Lazy_loaded entry; + (save_dirty [@tailcall]) entry + | { target = Lazy_loaded entry } as box -> + if clear then box.target <- Lazy (Lazy.force entry.hash); + (save_dirty [@tailcall]) entry + | { target = Lazy _ } -> ()) + | Truncated -> ( + function + | Broken h -> (broken [@tailcall]) h + | Intact entry -> (save_dirty [@tailcall]) entry) + + let clear : + type ptr. + iter_dirty:(ptr layout -> ptr t -> unit) -> ptr layout -> ptr -> unit + = + fun ~iter_dirty layout ptr -> + match layout with + | Partial _ -> ( + match ptr with + | { target = Lazy _ } -> () + | { target = Dirty ptr } -> iter_dirty layout ptr + | { target = Lazy_loaded ptr } as box -> + let hash = Lazy.force ptr.hash in + (* Since a [Lazy_loaded] used to be a [Lazy], the hash is always + available. *) + box.target <- Lazy hash) + | Total | Truncated -> () + end + + let pred layout t = + match t.v with + | Tree i -> + let hash_of_ptr = Ptr.hash layout in + Array.fold_left + (fun acc -> function + | None -> acc + | Some ptr -> `Inode (hash_of_ptr ptr) :: acc) + [] i.entries + | Values l -> + StepMap.fold + (fun _ v acc -> + let v = + match v with + | `Node _ as k -> k + | `Contents (k, _) -> `Contents k + in + v :: acc) + l [] + + let length_of_v = function + | Values vs -> StepMap.cardinal vs + | Tree vs -> vs.length + + let length t = length_of_v t.v + + let rec clear layout t = + match t.v with + | Tree i -> + Array.iter + (Option.iter (Ptr.clear ~iter_dirty:clear layout)) + i.entries + | Values _ -> () + + let stable t = t.stable + + type cont = off:int -> len:int -> (step * value) Seq.node + + let rec seq_tree layout bucket_seq ~depth ~cache : cont -> cont = + fun k ~off ~len -> + assert (off >= 0); + assert (len > 0); + match bucket_seq () with + | Seq.Nil -> k ~off ~len + | Seq.Cons (None, rest) -> seq_tree layout rest ~depth ~cache k ~off ~len + | Seq.Cons (Some i, rest) -> + let trg = Ptr.target ~depth ~cache ~force:true "seq_tree" layout i in + let trg_len = length trg in + if off - trg_len >= 0 then + (* Skip a branch of the inode tree in case the user asked for a + specific starting offset. + + Without this branch the algorithm would keep the same semantic + because [seq_value] would handles the pagination value by value + instead. *) + let off = off - trg_len in + seq_tree layout rest ~depth ~cache k ~off ~len + else + seq_v layout trg.v ~depth:(Some depth) ~cache + (seq_tree layout rest ~depth ~cache k) + ~off ~len + + and seq_values layout value_seq : cont -> cont = + fun k ~off ~len -> + assert (off >= 0); + assert (len > 0); + match value_seq () with + | Seq.Nil -> k ~off ~len + | Cons (x, rest) -> + if off = 0 then + let len = len - 1 in + if len = 0 then + (* Yield the current value and skip the rest of the inode tree in + case the user asked for a specific length. *) + Seq.Cons (x, Seq.empty) + else Seq.Cons (x, fun () -> seq_values layout rest k ~off ~len) + else + (* Skip one value in case the user asked for a specific starting + offset. *) + let off = off - 1 in + seq_values layout rest k ~off ~len + + and seq_v layout v ~depth ~cache : cont -> cont = + fun k ~off ~len -> + assert (off >= 0); + assert (len > 0); + match (depth, v) with + | Some depth, Tree t -> + seq_tree layout (Array.to_seq t.entries) ~depth:(depth + 1) ~cache k + ~off ~len + | _, Values vs -> seq_values layout (StepMap.to_seq vs) k ~off ~len + | _ -> assert false + + let empty_continuation : cont = fun ~off:_ ~len:_ -> Seq.Nil + + let seq layout ?offset:(off = 0) ?length:(len = Int.max_int) ?(cache = true) + t : (step * value) Seq.t = + if off < 0 then invalid_arg "Invalid pagination offset"; + if len < 0 then invalid_arg "Invalid pagination length"; + if len = 0 then Seq.empty + else fun () -> + seq_v layout t.v ~depth:(depth t) ~cache empty_continuation ~off ~len + + let seq_tree layout ?(cache = true) i : (step * value) Seq.t = + let off = 0 in + let len = Int.max_int in + fun () -> + seq_v layout (Tree i) ~depth:(Some i.depth) ~cache empty_continuation + ~off ~len + + let seq_v layout ?(cache = true) v : (step * value) Seq.t = + let off = 0 in + let len = Int.max_int in + fun () -> + seq_v layout v ~depth:(depth_of_v v) ~cache empty_continuation ~off ~len + + let to_bin_v layout = function + | Values vs -> + let vs = StepMap.bindings vs in + Bin.Values vs + | Tree t -> + let hash_of_ptr = Ptr.hash layout in + let _, entries = + Array.fold_left + (fun (i, acc) -> function + | None -> (i + 1, acc) + | Some ptr -> + let hash = hash_of_ptr ptr in + (i + 1, { Bin.index = i; hash } :: acc)) + (0, []) t.entries + in + let entries = List.rev entries in + Bin.Tree { depth = t.depth; length = t.length; entries } + + let to_bin layout t = + let v = to_bin_v layout t.v in + Bin.v ~stable:t.stable ~hash:t.hash v + + type len = [ `Eq of int | `Ge of int ] [@@deriving irmin] + + module Concrete = struct + type kind = Contents | Contents_x of metadata | Node [@@deriving irmin] + type entry = { name : step; kind : kind; hash : hash } [@@deriving irmin] + + type 'a pointer = { index : int; pointer : hash; tree : 'a } + [@@deriving irmin] + + type 'a tree = { depth : int; length : int; pointers : 'a pointer list } + [@@deriving irmin] + + type t = Tree of t tree | Values of entry list | Blinded + [@@deriving irmin] + + let metadata_equal = Irmin.Type.(unstage (equal metadata_t)) + + let to_entry (name, v) = + match v with + | `Contents (hash, m) -> + if metadata_equal m Node.default then + { name; kind = Contents; hash } + else { name; kind = Contents_x m; hash } + | `Node hash -> { name; kind = Node; hash } + + let of_entry e = + ( e.name, + match e.kind with + | Contents -> `Contents (e.hash, Node.default) + | Contents_x m -> `Contents (e.hash, m) + | Node -> `Node e.hash ) + + type error = + [ `Invalid_hash of hash * hash * t + | `Invalid_depth of int * int * t + | `Invalid_length of len * int * t + | `Duplicated_entries of t + | `Duplicated_pointers of t + | `Unsorted_entries of t + | `Unsorted_pointers of t + | `Blinded_root + | `Empty ] + [@@deriving irmin] + + let rec length = function + | Values l -> `Eq (List.length l) + | Tree t -> + List.fold_left + (fun acc p -> + match (acc, length p.tree) with + | `Eq x, `Eq y -> `Eq (x + y) + | (`Eq x | `Ge x), (`Eq y | `Ge y) -> `Ge (x + y)) + (`Eq 0) t.pointers + | Blinded -> `Ge 0 + + let pp = Irmin.Type.pp_json t + + let pp_len ppf = function + | `Eq e -> Fmt.pf ppf "%d" e + | `Ge e -> Fmt.pf ppf "'at least %d'" e + + let pp_error ppf = function + | `Invalid_hash (got, expected, t) -> + Fmt.pf ppf "invalid hash for %a@,got: %a@,expecting: %a" pp t + pp_hash got pp_hash expected + | `Invalid_depth (got, expected, t) -> + Fmt.pf ppf "invalid depth for %a@,got: %d@,expecting: %d" pp t got + expected + | `Invalid_length (got, expected, t) -> + Fmt.pf ppf "invalid length for %a@,got: %a@,expecting: %d" pp t + pp_len got expected + | `Duplicated_entries t -> Fmt.pf ppf "duplicated entries: %a" pp t + | `Duplicated_pointers t -> Fmt.pf ppf "duplicated pointers: %a" pp t + | `Unsorted_entries t -> Fmt.pf ppf "entries should be sorted: %a" pp t + | `Unsorted_pointers t -> + Fmt.pf ppf "pointers should be sorted: %a" pp t + | `Blinded_root -> Fmt.pf ppf "blinded root" + | `Empty -> Fmt.pf ppf "concrete subtrees cannot be empty" + end + + let to_concrete ~force (la : 'ptr layout) (t : 'ptr t) = + let rec aux t = + match t.v with + | Tree tr -> + ( Lazy.force t.hash, + Concrete.Tree + { + depth = tr.depth; + length = tr.length; + pointers = + Array.fold_left + (fun (i, acc) e -> + match e with + | None -> (i + 1, acc) + | Some t -> + let pointer, tree = + try + aux + (Ptr.target ~depth:tr.depth ~cache:true ~force + "to_concrete" la t) + with Dangling_hash { hash; _ } -> + (hash, Concrete.Blinded) + in + (i + 1, { Concrete.index = i; tree; pointer } :: acc)) + (0, []) tr.entries + |> snd + |> List.rev; + } ) + | Values l -> + ( Lazy.force t.hash, + Concrete.Values (List.map Concrete.to_entry (StepMap.bindings l)) + ) + in + snd (aux t) + + exception Invalid_hash of hash * hash * Concrete.t + exception Invalid_depth of int * int * Concrete.t + exception Invalid_length of len * int * Concrete.t + exception Empty + exception Duplicated_entries of Concrete.t + exception Duplicated_pointers of Concrete.t + exception Unsorted_entries of Concrete.t + exception Unsorted_pointers of Concrete.t + exception Blinded_root + + let hash_equal = Irmin.Type.(unstage (equal hash_t)) + + let of_concrete_exn t = + let sort_entries = + List.sort_uniq (fun x y -> compare x.Concrete.name y.Concrete.name) + in + let sort_pointers = + List.sort_uniq (fun x y -> compare x.Concrete.index y.Concrete.index) + in + let check_entries t es = + if es = [] then raise Empty; + let s = sort_entries es in + if List.length s <> List.length es then raise (Duplicated_entries t); + if s <> es then raise (Unsorted_entries t) + in + let check_pointers t ps = + if ps = [] then raise Empty; + let s = sort_pointers ps in + if List.length s <> List.length ps then raise (Duplicated_pointers t); + if s <> ps then raise (Unsorted_pointers t) + in + let hash v = Bin.V.hash (to_bin_v Truncated v) in + let rec aux depth t = + match t with + | Concrete.Blinded -> None + | Concrete.Values l -> + check_entries t l; + Some (Values (StepMap.of_list (List.map Concrete.of_entry l))) + | Concrete.Tree tr -> + let entries = Array.make Conf.entries None in + check_pointers t tr.pointers; + List.iter + (fun { Concrete.index; pointer; tree } -> + match aux (depth + 1) tree with + | None -> entries.(index) <- Some (Broken pointer) + | Some v -> + let hash = hash v in + if not (hash_equal hash pointer) then + raise (Invalid_hash (hash, pointer, t)); + let t = { hash = lazy pointer; stable = false; v } in + entries.(index) <- Some (Ptr.of_target Truncated t)) + tr.pointers; + if depth <> tr.depth then raise (Invalid_depth (depth, tr.depth, t)); + let () = + match Concrete.length t with + | `Eq length -> + if length <> tr.length then + raise (Invalid_length (`Eq length, tr.length, t)) + | `Ge length -> + if length > tr.length then + raise (Invalid_length (`Ge length, tr.length, t)) + in + + Some (Tree { depth = tr.depth; length = tr.length; entries }) + in + let v = match aux 0 t with None -> raise Blinded_root | Some v -> v in + let length = length_of_v v in + let stable, hash = + if length > Conf.stable_hash then (false, hash v) + else + let node = Node.of_seq (seq_v Truncated v) in + (true, Node.hash node) + in + { hash = lazy hash; stable; v } + + let of_concrete t = + try Ok (of_concrete_exn t) with + | Invalid_hash (x, y, z) -> Error (`Invalid_hash (x, y, z)) + | Invalid_depth (x, y, z) -> Error (`Invalid_depth (x, y, z)) + | Invalid_length (x, y, z) -> Error (`Invalid_length (x, y, z)) + | Empty -> Error `Empty + | Duplicated_entries t -> Error (`Duplicated_entries t) + | Duplicated_pointers t -> Error (`Duplicated_pointers t) + | Unsorted_entries t -> Error (`Unsorted_entries t) + | Unsorted_pointers t -> Error (`Unsorted_pointers t) + | Blinded_root -> Error `Blinded_root + + let hash t = Lazy.force t.hash + + let is_root t = + match t.v with + | Tree { depth; _ } -> depth = 0 + | Values _ -> + (* When [t] is of tag [Values], then [t] is root iff [t] is stable. It + is implied by the following. + + When [t] is stable, then [t] is a root, because: + - Only 2 functions produce stable inodes: [stabilize] and [empty]. + - Only the roots are output of [stabilize]. + - An empty map can only be located at the root. + + When [t] is a root of tag [Value], then [t] is stable, because: + - All the roots are output of [stabilize]. + - When an unstable inode enters [stabilize], it becomes stable if + it has at most [Conf.stable_hash] leaves. + - A [Value] has at most [Conf.stable_hash] leaves because + [Conf.entries <= Conf.stable_hash] is enforced. + *) + t.stable + + let check_write_op_supported t = + if not @@ is_root t then + failwith "Cannot perform operation on non-root inode value." + + let stabilize layout t = + if t.stable then t + else + let n = length t in + if n > Conf.stable_hash then t + else + let hash = + lazy + (let vs = seq layout t in + Node.hash (Node.of_seq vs)) + in + { hash; stable = true; v = t.v } + + let index ~depth k = + if depth >= max_depth then raise (Max_depth depth); + Index.index ~depth k + + (** This function shouldn't be called with the [Total] layout. In the + future, we could add a polymorphic variant to the GADT parameter to + enfoce that. *) + let of_bin layout t = + let v = + match t.Bin.v with + | Bin.Values vs -> + let vs = StepMap.of_list vs in + Values vs + | Tree t -> + let entries = Array.make Conf.entries None in + let ptr_of_hash = Ptr.of_hash layout in + List.iter + (fun { Bin.index; hash } -> + entries.(index) <- Some (ptr_of_hash hash)) + t.entries; + Tree { depth = t.Bin.depth; length = t.length; entries } + in + { hash = t.Bin.hash; stable = t.Bin.stable; v } + + let empty : 'a. 'a layout -> 'a t = + fun _ -> + let hash = lazy (Node.hash Node.empty) in + { stable = true; hash; v = Values StepMap.empty } + + let values layout vs = + let length = StepMap.cardinal vs in + if length = 0 then empty layout + else + let v = Values vs in + let hash = lazy (Bin.V.hash (to_bin_v layout v)) in + { hash; stable = false; v } + + let tree layout is = + let v = Tree is in + let hash = lazy (Bin.V.hash (to_bin_v layout v)) in + { hash; stable = false; v } + + let is_empty t = + match t.v with Values vs -> StepMap.is_empty vs | Tree _ -> false + + let find_value ~cache layout ~depth t s = + let target_of_ptr = Ptr.target ~cache ~force:true "find_value" layout in + let key = Index.key s in + let rec aux ~depth = function + | Values vs -> ( try Some (StepMap.find s vs) with Not_found -> None) + | Tree t -> ( + let i = index ~depth key in + let x = t.entries.(i) in + match x with + | None -> None + | Some i -> + let depth = depth + 1 in + aux ~depth (target_of_ptr ~depth i).v) + in + aux ~depth t.v + + let find ?(cache = true) layout t s = find_value ~cache ~depth:0 layout t s + + let rec add layout ~depth ~copy ~replace t (s, key) v k = + match t.v with + | Values vs -> + let length = + if replace then StepMap.cardinal vs else StepMap.cardinal vs + 1 + in + let t = + if length <= Conf.entries then values layout (StepMap.add s v vs) + else + let vs = StepMap.bindings (StepMap.add s v vs) in + let empty = + tree layout + { length = 0; depth; entries = Array.make Conf.entries None } + in + let aux t (s', v) = + let key' = Index.key s' in + (add [@tailcall]) layout ~depth ~copy:false ~replace t + (s', key') v (fun x -> x) + in + List.fold_left aux empty vs + in + k t + | Tree t -> ( + let length = if replace then t.length else t.length + 1 in + let entries = if copy then Array.copy t.entries else t.entries in + let i = index ~depth key in + match entries.(i) with + | None -> + let target = values layout (StepMap.singleton s v) in + entries.(i) <- Some (Ptr.of_target layout target); + let t = tree layout { depth; length; entries } in + k t + | Some n -> + let t = + (* [cache] is unimportant here as we've already called + [find_value] for that path.*) + Ptr.target ~depth ~cache:true ~force:true "add" layout n + in + (add [@tailcall]) layout ~depth:(depth + 1) ~copy ~replace t + (s, key) v (fun target -> + entries.(i) <- Some (Ptr.of_target layout target); + let t = tree layout { depth; length; entries } in + k t)) + + let add layout ~copy t s v = + (* XXX: [find_value ~depth:42] should break the unit tests. It doesn't. *) + let k = Index.key s in + match find_value ~cache:true ~depth:0 layout t s with + | Some v' when equal_value v v' -> stabilize layout t + | Some _ -> + add ~depth:0 layout ~copy ~replace:true t (s, k) v Fun.id + |> stabilize layout + | None -> + add ~depth:0 layout ~copy ~replace:false t (s, k) v Fun.id + |> stabilize layout + + let rec remove layout ~depth t (s, key) k = + match t.v with + | Values vs -> + let t = values layout (StepMap.remove s vs) in + k t + | Tree t -> ( + let len = t.length - 1 in + if len <= Conf.entries then + let vs = seq_tree layout t in + let vs = StepMap.of_seq vs in + let vs = StepMap.remove s vs in + let t = values layout vs in + k t + else + let entries = Array.copy t.entries in + let i = index ~depth key in + match entries.(i) with + | None -> assert false + | Some t -> + let t = + (* [cache] is unimportant here as we've already called + [find_value] for that path.*) + Ptr.target ~depth ~cache:true ~force:true "remove" layout t + in + if length t = 1 then ( + entries.(i) <- None; + let t = tree layout { depth; length = len; entries } in + k t) + else + remove ~depth:(depth + 1) layout t (s, key) @@ fun target -> + entries.(i) <- Some (Ptr.of_target layout target); + let t = tree layout { depth; length = len; entries } in + k t) + + let remove layout t s = + (* XXX: [find_value ~depth:42] should break the unit tests. It doesn't. *) + let k = Index.key s in + match find_value ~cache:true layout ~depth:0 t s with + | None -> stabilize layout t + | Some _ -> remove layout ~depth:0 t (s, k) Fun.id |> stabilize layout + + let of_seq l = + let t = + let rec aux_big seq inode = + match seq () with + | Seq.Nil -> inode + | Seq.Cons ((s, v), rest) -> + aux_big rest (add Total ~copy:false inode s v) + in + let len = + (* [StepMap.cardinal] is (a bit) expensive to compute, let's track the + size of the map in a [ref] while doing [StepMap.update]. *) + ref 0 + in + let rec aux_small seq map = + match seq () with + | Seq.Nil -> + assert (!len <= Conf.entries); + values Total map + | Seq.Cons ((s, v), rest) -> + let map = + StepMap.update s + (function + | None -> + incr len; + Some v + | Some _ -> Some v) + map + in + if !len = Conf.entries then aux_big rest (values Total map) + else aux_small rest map + in + aux_small l StepMap.empty + in + stabilize Total t + + let save layout ~add ~mem t = + let clear = + (* When set to [true], collect the loaded inodes as soon as they're + saved. + + This parameter is not exposed yet. Ideally it would be exposed and + be forwarded from [Tree.export ?clear] through [P.Node.add]. + + It is currently set to true in order to preserve behaviour *) + false + in + let iter_entries = + let broken h = + (* This function is called when we encounter a Broken pointer with + Truncated layouts. *) + if not @@ mem h then + Fmt.failwith + "You are trying to save to the backend an inode deserialized \ + using [Irmin.Type] that used to contain pointer(s) to inodes \ + which are unknown to the backend. Hash: %a" + pp_hash h + else + (* The backend already knows this target inode, there is no need to + traverse further down. This happens during the unit tests. *) + () + in + fun save_dirty arr -> + let iter_ptr = Ptr.save ~broken ~save_dirty ~clear layout in + Array.iter (Option.iter iter_ptr) arr + in + let rec aux ~depth t = + Log.debug (fun l -> l "save depth:%d" depth); + match t.v with + | Values _ -> add (Lazy.force t.hash) (to_bin layout t) + | Tree n -> + iter_entries + (fun t -> + let hash = Lazy.force t.hash in + if mem hash then () else aux ~depth:(depth + 1) t) + n.entries; + add (Lazy.force t.hash) (to_bin layout t) + in + aux ~depth:0 t + + let check_stable layout t = + let target_of_ptr = + Ptr.target ~cache:true ~force:true "check_stable" layout + in + let rec check ~depth t any_stable_ancestor = + let stable = t.stable || any_stable_ancestor in + match t.v with + | Values _ -> true + | Tree tree -> + Array.for_all + (function + | None -> true + | Some t -> + let depth = depth + 1 in + let t = target_of_ptr ~depth t in + (if stable then not t.stable else true) + && check ~depth t stable) + tree.entries + in + check ~depth:0 t t.stable + + let contains_empty_map layout t = + let target_of_ptr = + Ptr.target ~cache:true ~force:true "contains_empty_map" layout + in + let rec check_lower ~depth t = + match t.v with + | Values l when StepMap.is_empty l -> true + | Values _ -> false + | Tree inodes -> + Array.exists + (function + | None -> false + | Some t -> + let depth = depth + 1 in + target_of_ptr ~depth t |> check_lower ~depth) + inodes.entries + in + check_lower ~depth:0 t + + let is_tree t = match t.v with Tree _ -> true | Values _ -> false + + type proof = Node.proof [@@deriving irmin] + + module Proof = struct + let rec proof_of_concrete : + type a. hash Lazy.t -> Concrete.t -> (proof -> a) -> a = + fun h proof k -> + match proof with + | Blinded -> k (`Blinded (Lazy.force h)) + | Values vs -> k (`Values (List.map Concrete.of_entry vs)) + | Tree tr -> + let proofs = + List.fold_left + (fun acc (e : _ Concrete.pointer) -> + let hash = lazy e.pointer in + proof_of_concrete hash e.tree (fun proof -> + let e = + match proof with + | `Inode (_, [ (i, p) ]) -> (e.index :: i, p) + | _ -> ([ e.index ], proof) + in + e :: acc)) + [] (List.rev tr.pointers) + in + k (`Inode (tr.length, proofs)) + + let hash_v v = Bin.V.hash (to_bin_v Truncated v) + let hash_values l = hash_v (Values (StepMap.of_list l)) + + let hash_inode ~depth ~length es = + let entries = Array.make Conf.entries None in + List.iter (fun (index, ptr) -> entries.(index) <- Some ptr) es; + let v : truncated_ptr v = Tree { depth; length; entries } in + hash_v v + + let length_of_proof = function + | `Blinded _ -> 1 + | `Values ls -> List.length ls + | `Inode (len, _) -> len + + let rec concrete_of_proof : + type a. int -> proof -> (hash -> Concrete.t -> a) -> a = + fun depth proof k -> + match proof with + | `Blinded h -> k h Concrete.Blinded + | `Values vs -> + let hash = hash_values vs in + let c = Concrete.Values (List.map Concrete.to_entry vs) in + k hash c + | `Inode (length, proofs) -> concrete_of_inode ~length ~depth proofs k + + and concrete_of_inode : + type a. + length:int -> + depth:int -> + (int list * proof) list -> + (hash -> Concrete.t -> a) -> + a = + fun ~length ~depth proofs k -> + let rec aux ps es = function + | [] -> + let c = Concrete.Tree { depth; length; pointers = ps } in + let hash = hash_inode ~depth ~length es in + k hash c + | (index, proof) :: proofs -> ( + match index with + | [ index ] -> + concrete_of_proof (depth + 1) proof (fun pointer tree -> + let ps = { Concrete.tree; pointer; index } :: ps in + let es = (index, Broken pointer) :: es in + aux ps es proofs) + | index :: rest -> + let length = length_of_proof proof in + concrete_of_inode ~length ~depth:(depth + 1) [ (rest, proof) ] + (fun pointer tree -> + let ps = { Concrete.tree; pointer; index } :: ps in + let es = (index, Broken pointer) :: es in + aux ps es proofs) + | [] -> assert false) + in + aux [] [] (List.rev proofs) + + let proof_of_concrete h p = proof_of_concrete h p Fun.id + let concrete_of_proof d p = concrete_of_proof d p (fun _ t -> t) + + let to_proof la t = + let p = + if t.stable then + (* To preserve the stable hash, the proof needs to contain + all the underlying values. *) + let bindings = + seq la t + |> Seq.map Concrete.to_entry + |> List.of_seq + |> List.fast_sort (fun x y -> + compare x.Concrete.name y.Concrete.name) + in + Concrete.Values bindings + else to_concrete ~force:false la t + in + proof_of_concrete t.hash p + + let of_proof (proof : proof) = + let c = concrete_of_proof 0 proof in + match of_concrete c with Ok v -> Some v | Error _ -> None + + let of_concrete t = proof_of_concrete (lazy (failwith "blinded root")) t + let to_concrete = concrete_of_proof 0 + end + end + + module Raw = struct + type hash = H.t + type t = Bin.t + + let t = Bin.t + let depth = Bin.depth + + exception Invalid_depth of { expected : int; got : int; v : t } + + let kind (t : t) = + if t.stable then Compress.kind_node else Compress.kind_inode + + let hash t = Bin.hash t + let step_to_bin = Irmin.Type.(unstage (to_bin_string T.step_t)) + let step_of_bin = Irmin.Type.(unstage (of_bin_string T.step_t)) + let encode_compress = Irmin.Type.(unstage (encode_bin Compress.t)) + let decode_compress = Irmin.Type.(unstage (decode_bin Compress.t)) + + let decode_compress_length = + match Irmin.Type.Size.of_encoding Compress.t with + | Unknown | Static _ -> assert false + | Dynamic f -> f + + let encode_bin ~dict ~offset (t : t) k = + let step s : Compress.name = + let str = step_to_bin s in + if String.length str <= 3 then Direct s + else match dict str with Some i -> Indirect i | None -> Direct s + in + let hash h : Compress.address = + match offset h with + | None -> Compress.Direct h + | Some off -> Compress.Indirect off + in + let ptr : Bin.ptr -> Compress.ptr = + fun n -> + let hash = hash n.hash in + { index = n.index; hash } + in + let value : T.step * T.value -> Compress.value = function + | s, `Contents (c, m) -> + let s = step s in + let v = hash c in + Compress.Contents (s, v, m) + | s, `Node n -> + let s = step s in + let v = hash n in + Compress.Node (s, v) + in + (* List.map is fine here as the number of entries is small *) + let v : Bin.v -> Compress.v = function + | Values vs -> Values (List.map value vs) + | Tree { depth; length; entries } -> + let entries = List.map ptr entries in + Tree { Compress.depth; length; entries } + in + let t = Compress.v ~stable:t.stable ~hash:k (v t.v) in + encode_compress t + + exception Exit of [ `Msg of string ] + + let decode_bin ~dict ~hash t off : int * t = + let off, i = decode_compress t off in + let step : Compress.name -> T.step = function + | Direct n -> n + | Indirect s -> ( + match dict s with + | None -> raise_notrace (Exit (`Msg "dict")) + | Some s -> ( + match step_of_bin s with + | Error e -> raise_notrace (Exit e) + | Ok v -> v)) + in + let hash : Compress.address -> H.t = function + | Indirect off -> hash off + | Direct n -> n + in + let ptr : Compress.ptr -> Bin.ptr = + fun n -> + let hash = hash n.hash in + { index = n.index; hash } + in + let value : Compress.value -> T.step * T.value = function + | Contents (n, h, metadata) -> + let name = step n in + let hash = hash h in + (name, `Contents (hash, metadata)) + | Node (n, h) -> + let name = step n in + let hash = hash h in + (name, `Node hash) + in + let t : Compress.v -> Bin.v = function + | Values vs -> Values (List.rev_map value (List.rev vs)) + | Tree { depth; length; entries } -> + let entries = List.map ptr entries in + Tree { depth; length; entries } + in + let t = Bin.v ~stable:i.stable ~hash:(lazy i.hash) (t i.v) in + (off, t) + + let decode_bin_length = decode_compress_length + end + + type hash = T.hash + + let pp_hash = T.pp_hash + + module Val = struct + include T + module I = Val_impl + + type t = + | Total of I.total_ptr I.t + | Partial of I.partial_ptr I.layout * I.partial_ptr I.t + | Truncated of I.truncated_ptr I.t + + type 'b apply_fn = { f : 'a. 'a I.layout -> 'a I.t -> 'b } [@@unboxed] + + let apply : t -> 'b apply_fn -> 'b = + fun t f -> + match t with + | Total v -> f.f I.Total v + | Partial (layout, v) -> f.f layout v + | Truncated v -> f.f I.Truncated v + + type map_fn = { f : 'a. 'a I.layout -> 'a I.t -> 'a I.t } [@@unboxed] + + let map : t -> map_fn -> t = + fun t f -> + match t with + | Total v -> + let v' = f.f I.Total v in + if v == v' then t else Total v' + | Partial (layout, v) -> + let v' = f.f layout v in + if v == v' then t else Partial (layout, v') + | Truncated v -> + let v' = f.f I.Truncated v in + if v == v' then t else Truncated v' + + let pred t = apply t { f = (fun layout v -> I.pred layout v) } + let of_seq l = Total (I.of_seq l) + let of_list l = of_seq (List.to_seq l) + + let seq ?offset ?length ?cache t = + apply t { f = (fun layout v -> I.seq layout ?offset ?length ?cache v) } + + let list ?offset ?length ?cache t = + List.of_seq (seq ?offset ?length ?cache t) + + let empty = of_list [] + let is_empty t = apply t { f = (fun _ v -> I.is_empty v) } + + let find ?cache t s = + apply t { f = (fun layout v -> I.find ?cache layout v s) } + + let add t s value = + let f layout v = + I.check_write_op_supported v; + I.add ~copy:true layout v s value + in + map t { f } + + let remove t s = + let f layout v = + I.check_write_op_supported v; + I.remove layout v s + in + map t { f } + + let pre_hash_binv = Irmin.Type.(unstage (pre_hash Bin.v_t)) + let pre_hash_node = Irmin.Type.(unstage (pre_hash Node.t)) + + let t : t Irmin.Type.t = + let pre_hash x = + let stable = apply x { f = (fun _ v -> I.stable v) } in + if not stable then + let bin = apply x { f = (fun layout v -> I.to_bin layout v) } in + pre_hash_binv bin.v + else + let vs = seq x in + pre_hash_node (Node.of_seq vs) + in + Irmin.Type.map ~pre_hash Bin.t + (fun bin -> Truncated (I.of_bin I.Truncated bin)) + (fun x -> apply x { f = (fun layout v -> I.to_bin layout v) }) + + let hash t = apply t { f = (fun _ v -> I.hash v) } + + let save ~add ~mem t = + let f layout v = + I.check_write_op_supported v; + I.save layout ~add ~mem v + in + apply t { f } + + let of_raw find' v = + let rec find ~expected_depth h = + Option.map (I.of_bin layout) (find' ~expected_depth h) + and layout = I.Partial find in + Partial (layout, I.of_bin layout v) + + let to_raw t = apply t { f = (fun layout v -> I.to_bin layout v) } + let stable t = apply t { f = (fun _ v -> I.stable v) } + let length t = apply t { f = (fun _ v -> I.length v) } + let clear t = apply t { f = (fun layout v -> I.clear layout v) } + let index ~depth s = I.index ~depth (Index.key s) + + let integrity_check t = + let f layout v = + let check_stable () = + let check () = I.check_stable layout v in + let n = length t in + if n > Conf.stable_hash then (not (stable t)) && check () + else stable t && check () + in + let contains_empty_map_non_root () = + let check () = I.contains_empty_map layout v in + (* we are only looking for empty maps that are not at the root *) + if I.is_tree v then check () else false + in + check_stable () && not (contains_empty_map_non_root ()) + in + apply t { f } + + module Concrete = I.Concrete + module Proof = I.Proof + + let to_concrete t = + apply t { f = (fun la v -> I.to_concrete ~force:true la v) } + + let of_concrete t = + match I.of_concrete t with Ok t -> Ok (Truncated t) | Error _ as e -> e + + type proof = I.proof [@@deriving irmin] + + let to_proof (t : t) : proof = + apply t { f = (fun la v -> I.Proof.to_proof la v) } + + let of_proof (p : proof) = + Option.map (fun v -> Truncated v) (I.Proof.of_proof p) + + let with_handler f_env t = + match t with + | Total _ -> t + | Truncated _ -> t + | Partial ((I.Partial find as la), v) -> + (* [f_env] works on [Val.t] while [find] in [Partial find] works on + [Val_impl.t], hence the following wrapping (before applying + [f_env]) and unwrapping (after [f_env]). *) + let find_v ~expected_depth h = + match find ~expected_depth h with + | None -> None + | Some v -> Some (Partial (la, v)) + in + let find = f_env find_v in + let find_ptr ~expected_depth h = + match find ~expected_depth h with + | Some (Partial (_, v)) -> Some v + | _ -> None + in + let la = I.Partial find_ptr in + Partial (la, v) + end +end + +module Make + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S with type hash = H.t) + (Inter : Internal + with type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step) + (Pack : Content_addressable.S + with type key = H.t + and type value = Inter.Raw.t) = +struct + module Key = H + module Val = Inter.Val + + type 'a t = 'a Pack.t + type key = Key.t + type value = Inter.Val.t + + exception Invalid_depth = Inter.Raw.Invalid_depth + + let pp_value = Irmin.Type.pp Inter.Raw.t + + let pp_invalid_depth ppf (expected, got, v) = + Fmt.pf ppf "Invalid depth: got %d, expecting %d (%a)" got expected pp_value + v + + let check_depth_opt ~expected_depth:expected = function + | None -> () + | Some v -> ( + match Inter.Raw.depth v with + | None -> () + | Some got -> + if got <> expected then raise (Invalid_depth { expected; got; v })) + + let mem t k = Pack.mem t k + + let find t k = + Pack.find t k >|= function + | None -> None + | Some v -> + let find ~expected_depth k = + let v = Pack.unsafe_find ~check_integrity:true t k in + check_depth_opt ~expected_depth v; + v + in + let v = Val.of_raw find v in + Some v + + let save t v = + let add k v = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false t k v + in + Val.save ~add ~mem:(Pack.unsafe_mem t) v + + let hash v = Val.hash v + + let add t v = + save t v; + Lwt.return (hash v) + + let equal_hash = Irmin.Type.(unstage (equal H.t)) + + let check_hash expected got = + if equal_hash expected got then () + else + Fmt.invalid_arg "corrupted value: got %a, expecting %a" Inter.pp_hash + expected Inter.pp_hash got + + let unsafe_add t k v = + check_hash k (hash v); + save t v; + Lwt.return_unit + + let batch = Pack.batch + let close = Pack.close + let clear = Pack.clear + let decode_bin_length = Inter.Raw.decode_bin_length + + let protect_from_invalid_depth_exn f = + Lwt.catch f (function + | Invalid_depth { expected; got; v } -> + let msg = Fmt.to_to_string pp_invalid_depth (expected, got, v) in + Lwt.return (Error msg) + | e -> Lwt.fail e) + + let integrity_check_inodes t k = + protect_from_invalid_depth_exn @@ fun () -> + find t k >|= function + | None -> + (* we are traversing the node graph, should find all values *) + assert false + | Some v -> + if Inter.Val.integrity_check v then Ok () + else + let msg = + Fmt.str "Problematic inode %a" (Irmin.Type.pp Inter.Val.t) v + in + Error msg +end + +module Make_persistent + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S with type hash = H.t) + (Inter : Internal + with type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step) + (CA : Pack_store.Maker + with type key = H.t + and type index = Pack_index.Make(H).t) = +struct + module Persistent_pack = CA.Make (Inter.Raw) + module Pack = Persistent_pack + include Make (H) (Node) (Inter) (Pack) + + type index = Pack.index + + let v = Pack.v + let sync = Pack.sync + let integrity_check = Pack.integrity_check + let clear_caches = Pack.clear_caches +end diff --git a/vendors/irmin/irmin-pack/inode.mli b/vendors/irmin/irmin-pack/inode.mli new file mode 100644 index 000000000000..aba3e8b56e6e --- /dev/null +++ b/vendors/irmin/irmin-pack/inode.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Inode_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/inode_intf.ml b/vendors/irmin/irmin-pack/inode_intf.ml new file mode 100644 index 000000000000..b6c78243fd2b --- /dev/null +++ b/vendors/irmin/irmin-pack/inode_intf.ml @@ -0,0 +1,189 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type Value = sig + include Irmin.Private.Node.S + + val pred : t -> [ `Node of hash | `Inode of hash | `Contents of hash ] list +end + +module type S = sig + include Irmin.CONTENT_ADDRESSABLE_STORE + module Key : Irmin.Hash.S with type t = key + module Val : Value with type t = value and type hash = key + + val decode_bin_length : string -> int -> int + val batch : read t -> ([ read | write ] t -> 'a Lwt.t) -> 'a Lwt.t + val close : _ t -> unit Lwt.t +end + +module type Persistent = sig + include S + + type index + + val v : + ?fresh:bool -> + ?readonly:bool -> + ?lru_size:int -> + index:index -> + string -> + read t Lwt.t + + include S.Checkable with type 'a t := 'a t and type key := key + + val sync : ?on_generation_change:(unit -> unit) -> 'a t -> unit + val clear_caches : 'a t -> unit + val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result Lwt.t +end + +(** Unstable internal API agnostic about the underlying storage. Use it only to + implement or test inodes. *) +module type Internal = sig + type hash + + val pp_hash : hash Fmt.t + + module Raw : sig + include Pack_value.S with type hash = hash + + val depth : t -> int option + + exception Invalid_depth of { expected : int; got : int; v : t } + end + + module Val : sig + include Value with type hash = hash + + val of_raw : (expected_depth:int -> hash -> Raw.t option) -> Raw.t -> t + val to_raw : t -> Raw.t + val save : add:(hash -> Raw.t -> unit) -> mem:(hash -> bool) -> t -> unit + val hash : t -> hash + val stable : t -> bool + val length : t -> int + val index : depth:int -> step -> int + + val integrity_check : t -> bool + (** Checks the integrity of an inode. *) + + module Concrete : sig + (** {1 Concrete trees} *) + + (** The type for pointer kinds. *) + type kind = Contents | Contents_x of metadata | Node [@@deriving irmin] + + type entry = { name : step; kind : kind; hash : hash } [@@deriving irmin] + (** The type for entries. *) + + type 'a pointer = { index : int; pointer : hash; tree : 'a } + [@@deriving irmin] + (** The type for pointers. *) + + type 'a tree = { depth : int; length : int; pointers : 'a pointer list } + [@@deriving irmin] + (** The type for trees. *) + + (** The type for concrete trees. *) + type t = Tree of t tree | Values of entry list | Blinded + [@@deriving irmin] + + type len := [ `Eq of int | `Ge of int ] + + type error = + [ `Invalid_hash of hash * hash * t + | `Invalid_depth of int * int * t + | `Invalid_length of len * int * t + | `Duplicated_entries of t + | `Duplicated_pointers of t + | `Unsorted_entries of t + | `Unsorted_pointers of t + | `Blinded_root + | `Empty ] + [@@deriving irmin] + (** The type for errors. *) + + val pp_error : error Fmt.t + (** [pp_error] is the pretty-printer for errors. *) + end + + val to_concrete : t -> Concrete.t + (** [to_concrete t] is the concrete inode tree equivalent to [t]. *) + + val of_concrete : Concrete.t -> (t, Concrete.error) result + (** [of_concrete c] is [Ok t] iff [c] and [t] are equivalent. + + The result is [Error e] when a subtree tree of [c] has an integrity + error. *) + + module Proof : sig + val of_concrete : Concrete.t -> proof + val to_concrete : proof -> Concrete.t + end + end +end + +module type Sigs = sig + module type S = S + module type Persistent = Persistent + module type Internal = Internal + + module Make_internal + (Conf : Conf.S) + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S with type hash = H.t) : + Internal + with type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + + module Make + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S with type hash = H.t) + (Inter : Internal + with type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step) + (Pack : Content_addressable.S + with type key = H.t + and type value = Inter.Raw.t) : + S + with type 'a t = 'a Pack.t + and type key = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type value = Inter.Val.t + + module Make_persistent + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S with type hash = H.t) + (Inter : Internal + with type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step) + (CA : Pack_store.Maker + with type key = H.t + and type index = Pack_index.Make(H).t) : sig + include + Persistent + with type key = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type index = Pack_index.Make(H).t + and type value = Inter.Val.t + end +end diff --git a/vendors/irmin/irmin-pack/irmin_pack.ml b/vendors/irmin/irmin-pack/irmin_pack.ml new file mode 100644 index 000000000000..6a5fafe2853f --- /dev/null +++ b/vendors/irmin/irmin-pack/irmin_pack.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Ext +include Irmin_pack_intf + +let config = Conf.v + +exception RO_not_allowed = S.RO_not_allowed + +module type S = S.S + +module Content_addressable = Content_addressable +module Atomic_write = Atomic_write +module Dict = Pack_dict +module Hash = Irmin.Hash.BLAKE2B +module Path = Irmin.Path.String_list +module Metadata = Irmin.Metadata.None +module Make_ext = Ext.Maker +module Version = Version +module Index = Pack_index +module Conf = Conf + +let migrate = Migrate.run + +module Make (V : Version.S) (Config : Conf.S) = + Make_ext (V) (Config) (Irmin.Private.Node.Make) (Irmin.Private.Commit.Make) + +module V1 = Make (Version.V1) +module V2 = Make (Version.V2) + +module KV (V : Version.S) (Config : Conf.S) (C : Irmin.Contents.S) = + Make (V) (Config) (Metadata) (C) (Path) (Irmin.Branch.String) (Hash) + +module Stats = Stats +module Layout = Layout +module Checks = Checks +module Inode = Inode +module IO = IO +module Utils = Utils +module Pack_value = Pack_value +module Vx = Version.V1 +module Pack_store = Pack_store diff --git a/vendors/irmin/irmin-pack/irmin_pack.mli b/vendors/irmin/irmin-pack/irmin_pack.mli new file mode 100644 index 000000000000..c82e8fa19c15 --- /dev/null +++ b/vendors/irmin/irmin-pack/irmin_pack.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_pack_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/irmin_pack_intf.ml b/vendors/irmin/irmin-pack/irmin_pack_intf.ml new file mode 100644 index 000000000000..2a4eb3bf45ff --- /dev/null +++ b/vendors/irmin/irmin-pack/irmin_pack_intf.ml @@ -0,0 +1,84 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Maker = functor (_ : Conf.S) -> S.Maker +module type Specifics = S.Specifics + +module type Sigs = sig + module Dict = Pack_dict + module Index = Pack_index + module Conf = Conf + module Inode = Inode + module Pack_value = Pack_value + module Pack_store = Pack_store + module Version = Version + + val config : + ?fresh:bool -> + ?readonly:bool -> + ?lru_size:int -> + ?index_log_size:int -> + ?merge_throttle:Conf.merge_throttle -> + ?freeze_throttle:Conf.freeze_throttle -> + string -> + Irmin.config + (** Configuration options for stores. + + @param fresh whether an existing store should be overwritten. + @param read_only whether read-only mode is enabled for this store. + @param lru_size the maximum number of bindings in the lru cache. + @param index_log_size the maximum number of bindings in the index cache. + @param index_throttle + the strategy to use when the index cache is full and an async + [Index.merge] in already in progress. [Block_writes] (the default) + blocks any new writes until the merge is completed. [Overcommit_memory] + does not block but indefinitely expands the in-memory cache. *) + + exception RO_not_allowed + + module Make (_ : Version.S) : Maker + module V1 : Maker + module V2 : Maker + module KV (_ : Version.S) (_ : Conf.S) : Irmin.KV_MAKER + + module type S = S.S + module type Specifics = S.Specifics + + module Make_ext + (_ : Version.S) + (_ : Conf.S) + (N : Irmin.Private.Node.Maker) + (CT : Irmin.Private.Commit.Maker) : S.Maker + + module Stats = Stats + module Layout = Layout + module Checks = Checks + + val migrate : Irmin.config -> unit + (** [migrate conf] upgrades the repository with configuration [conf] to use + the latest storage format. + + {b Note:} performing concurrent store operations during the migration, or + attempting to use pre-migration instances of the repository after the + migration is complete, will result in undefined behaviour. *) + + module Content_addressable = Content_addressable + module Atomic_write = Atomic_write + module IO = IO + module Utils = Utils + + module type Maker = functor (_ : Conf.S) -> S.Maker +end diff --git a/vendors/irmin/irmin-pack/layered/IO_layers.ml b/vendors/irmin/irmin-pack/layered/IO_layers.ml new file mode 100644 index 000000000000..f330538c2567 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/IO_layers.ml @@ -0,0 +1,94 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let src = Logs.Src.create "irmin.layers.io" ~doc:"IO for irmin-layers" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type t + + val v : string -> t Lwt.t + val close : t -> unit Lwt.t + val read_flip : t -> bool Lwt.t + val write_flip : bool -> t -> unit Lwt.t +end + +module IO = struct + type t = { file : string; fd : Lwt_unix.file_descr } + + let lseek ~offset t = + let* off = Lwt_unix.lseek t.fd offset Lwt_unix.SEEK_SET in + if off <> offset then Lwt.fail_with "invalid lseek" else Lwt.return_unit + + let write ~offset t buf = + lseek ~offset t >>= fun () -> + let len = Bytes.length buf in + let* n = Lwt_unix.write t.fd buf 0 len in + if n <> len then Lwt.fail_with "invalid write" else Lwt.return_unit + + let read ~offset t buf = + lseek ~offset t >>= fun () -> + let len = Bytes.length buf in + let* n = Lwt_unix.read t.fd buf 0 len in + if n <> len then Lwt.fail_with "invalid read" else Lwt.return_unit + + let close t = Lwt_unix.close t.fd + + let read_flip t = + let buf = Bytes.create 1 in + read ~offset:0 t buf >>= fun () -> + let ch = Bytes.get buf 0 in + match int_of_char ch with + | 0 -> Lwt.return_false + | 1 -> Lwt.return_true + | d -> Lwt.fail_with ("corrupted flip file " ^ string_of_int d) + + let write_flip flip t = + let buf = Bytes.make 1 (char_of_int (if flip then 1 else 0)) in + write ~offset:0 t buf + + let v file = + match Sys.file_exists file with + | false -> + let* fd = + Lwt_unix.openfile file Lwt_unix.[ O_CREAT; O_RDWR; O_CLOEXEC ] 0o644 + in + let t = { file; fd } in + write_flip true t >|= fun () -> t + | true -> + Lwt_unix.openfile file Lwt_unix.[ O_EXCL; O_RDWR; O_CLOEXEC ] 0o644 + >|= fun fd -> { file; fd } +end + +module Lock = struct + type t = { file : string; fd : Lwt_unix.file_descr } + + let v file = + let pid = string_of_int (Unix.getpid ()) in + let* fd = + Lwt_unix.openfile file Unix.[ O_CREAT; O_WRONLY; O_TRUNC ] 0o644 + in + let* n = Lwt_unix.write_string fd pid 0 (String.length pid) in + if n <> String.length pid then Lwt.fail_with "invalid write for lock file" + else Lwt.return { file; fd } + + let test = Sys.file_exists + let unlink = Lwt_unix.unlink + let close { fd; file } = Lwt_unix.close fd >>= fun () -> unlink file +end diff --git a/vendors/irmin/irmin-pack/layered/IO_layers.mli b/vendors/irmin/irmin-pack/layered/IO_layers.mli new file mode 100644 index 000000000000..d336c751fa24 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/IO_layers.mli @@ -0,0 +1,37 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESIrmin. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type t + + val v : string -> t Lwt.t + val close : t -> unit Lwt.t + val read_flip : t -> bool Lwt.t + val write_flip : bool -> t -> unit Lwt.t +end + +module IO : S + +module Lock : sig + type t + + val v : string -> t Lwt.t + val close : t -> unit Lwt.t + val unlink : string -> unit Lwt.t + val test : string -> bool +end diff --git a/vendors/irmin/irmin-pack/layered/checks.ml b/vendors/irmin/irmin-pack/layered/checks.ml new file mode 100644 index 000000000000..37c0e282647f --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/checks.ml @@ -0,0 +1,212 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Irmin_pack.Checks +module IO = Irmin_pack.IO.Unix + +module type S = sig + include S + + module Check_self_contained : sig + val run : root:string -> heads:string list option -> unit Lwt.t + (** Ensure that the upper layer of the store is self-contained.*) + + val term : (unit -> unit) Cmdliner.Term.t + (** A pre-packaged [Cmdliner] term for executing {!run}. *) + end + + val cli : unit -> empty + (** Run a [Cmdliner] binary containing tools for running offline checks. *) +end + +module Layout = struct + include Layout + + (** Only works for layered stores that use the default names for layers. *) + let lower, upper0, upper1 = + let of_id id ~root = + Filename.concat root (Irmin_layers.Layer_id.to_string id) + in + (of_id `Lower, of_id `Upper0, of_id `Upper1) + + let toplevel root = + [ Layout.flip ~root; lower ~root; upper1 ~root; upper0 ~root ] +end + +module Make (M : Maker) (Store : S.Store) = struct + module Simple = Make (M) + module Hash = Store.Hash + + let read_flip ~root = + let path = Layout.flip ~root in + match IO.exists path with + | false -> Lwt.return_none + | true -> + let* t = IO_layers.IO.v path in + let* a = + IO_layers.IO.read_flip t >|= function + | true -> `Upper1 + | false -> `Upper0 + in + IO_layers.IO.close t >|= fun () -> Some a + + module Stat = struct + module Layer_stat = Simple.Stat + + type files_layer = { + flip : [ `Upper1 | `Upper0 ] option; + lower : Layer_stat.files; + upper1 : Layer_stat.files; + upper0 : Layer_stat.files; + } + [@@deriving irmin] + + type objects_layer = { + lower : Layer_stat.objects; + upper1 : Layer_stat.objects; + upper0 : Layer_stat.objects; + } + [@@deriving irmin] + + type t = { + hash_size : Layer_stat.size; + log_size : int; + files : files_layer; + objects : objects_layer; + } + [@@deriving irmin] + + let v = Layer_stat.v ~version:`V2 + + let v ~root = + read_flip ~root >|= fun flip -> + let lower = v ~root:(Layout.lower ~root) + and upper1 = v ~root:(Layout.upper1 ~root) + and upper0 = v ~root:(Layout.upper0 ~root) in + { flip; lower; upper1; upper0 } + + let conf root = Irmin_pack.Conf.v ~readonly:false ~fresh:false root + + let traverse_indexes ~root log_size = + let lower = Layer_stat.traverse_index ~root:(Layout.lower ~root) log_size + and upper1 = + Layer_stat.traverse_index ~root:(Layout.upper1 ~root) log_size + and upper0 = + Layer_stat.traverse_index ~root:(Layout.upper0 ~root) log_size + in + { lower; upper1; upper0 } + + let run ~root = + Logs.app (fun f -> f "Getting statistics for store: `%s'@," root); + let log_size = conf root |> Irmin_pack.Conf.index_log_size in + let objects = traverse_indexes ~root log_size in + let+ files = v ~root in + { hash_size = Bytes Hash.hash_size; log_size; files; objects } + |> Irmin.Type.pp_json ~minify:false t Fmt.stdout + + let term_internal = + Cmdliner.Term.(const (fun root () -> Lwt_main.run (run ~root)) $ path) + + let term = + let doc = "Print high-level statistics about the store." in + Cmdliner.Term.(term_internal $ setup_log, info ~doc "stat") + end + + module Integrity_check = struct + let conf root = Irmin_pack.Conf.v ~readonly:false ~fresh:false root + + let run ~root ~auto_repair = + let conf = conf root in + let lower_root = Layout.lower ~root in + let upper_root1 = Layout.upper1 ~root in + let upper_root0 = Layout.upper0 ~root in + let conf = Conf.v ~conf ~lower_root ~upper_root1 ~upper_root0 () in + let+ repo = Store.Repo.v conf in + let res = Store.integrity_check ~auto_repair repo in + List.iter + (fun (r, id) -> + Simple.Integrity_check.handle_result + ~name:(Irmin_layers.Layer_id.to_string id) + r) + res + + let term_internal = + let auto_repair = + let open Cmdliner.Arg in + value + & (flag @@ info ~doc:"Automatically repair issues" [ "auto-repair" ]) + in + Cmdliner.Term.( + const (fun root auto_repair () -> Lwt_main.run (run ~root ~auto_repair)) + $ path + $ auto_repair) + + let term = + let doc = "Check integrity of an existing store." in + Cmdliner.Term.(term_internal $ setup_log, info ~doc "integrity-check") + end + + module Check_self_contained = struct + let conf root = + let conf = Irmin_pack.Conf.v ~readonly:true root in + Conf.v ~conf ~with_lower:false () + + let heads = + let open Cmdliner.Arg in + value + & opt (some (list ~sep:',' string)) None + & info [ "heads" ] ~doc:"List of head commit hashes" ~docv:"HEADS" + + let check_store ~root ~heads (module S : S.Store) = + let* repo = S.Repo.v (conf root) in + let* heads = + match heads with + | None -> S.Repo.heads repo + | Some heads -> + Lwt_list.filter_map_s + (fun x -> + match Repr.of_string S.Hash.t x with + | Ok x -> S.Commit.of_hash repo x + | _ -> Lwt.return None) + heads + in + + let* () = + S.check_self_contained ~heads repo >|= function + | Ok (`Msg msg) -> Logs.app (fun l -> l "Ok -- %s" msg) + | Error (`Msg msg) -> Logs.err (fun l -> l "Error -- %s" msg) + in + S.Repo.close repo + + let run ~root ~heads = check_store ~root ~heads (module Store) + + let term_internal = + Cmdliner.Term.( + const (fun root heads () -> Lwt_main.run (run ~root ~heads)) + $ path + $ heads) + + let term = + let doc = "Check that the upper layer of the store is self contained." in + Cmdliner.Term.(term_internal $ setup_log, info ~doc "check-self-contained") + end + + let cli () = + Simple.cli + ~terms:[ Stat.term; Integrity_check.term; Check_self_contained.term ] + () +end diff --git a/vendors/irmin/irmin-pack/layered/conf.ml b/vendors/irmin/irmin-pack/layered/conf.ml new file mode 100644 index 000000000000..5561ed42097c --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/conf.ml @@ -0,0 +1,70 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Default = struct + let lower_root = Irmin_layers.Layer_id.to_string `Lower + let upper0_root = Irmin_layers.Layer_id.to_string `Upper0 + let upper1_root = Irmin_layers.Layer_id.to_string `Upper1 + let with_lower = true + let blocking_copy_size = 64 +end + +module Conf = Irmin.Private.Conf +module Pack = Irmin_pack.Conf + +let lower_root_key = + Conf.key ~doc:"The root directory for the lower layer." "root_lower" + Conf.string Default.lower_root + +let lower_root conf = Conf.get conf lower_root_key + +let upper_root1_key = + Conf.key ~doc:"The root directory for the upper layer." "root_upper" + Conf.string Default.upper1_root + +let upper_root1 conf = Conf.get conf upper_root1_key + +let upper_root0_key = + Conf.key ~doc:"The root directory for the secondary upper layer." + "root_second" Conf.string Default.upper0_root + +let upper_root0 conf = Conf.get conf upper_root0_key + +let with_lower_key = + Conf.key ~doc:"Use a lower layer." "with-lower" Conf.bool Default.with_lower + +let with_lower conf = Conf.get conf with_lower_key + +let blocking_copy_size_key = + Conf.key + ~doc: + "Specify the maximum size (in bytes) that can be copied in the blocking \ + portion of the freeze." + "blocking-copy" Conf.int Default.blocking_copy_size + +let blocking_copy_size conf = Conf.get conf blocking_copy_size_key + +let v ?(conf = Conf.empty) ?(lower_root = Default.lower_root) + ?(upper_root1 = Default.upper1_root) ?(upper_root0 = Default.upper0_root) + ?(with_lower = Default.with_lower) + ?(blocking_copy_size = Default.blocking_copy_size) () = + let with_binding k v c = Conf.add c k v in + conf + |> with_binding lower_root_key lower_root + |> with_binding upper_root1_key upper_root1 + |> with_binding upper_root0_key upper_root0 + |> with_binding with_lower_key with_lower + |> with_binding blocking_copy_size_key blocking_copy_size diff --git a/vendors/irmin/irmin-pack/layered/conf.mli b/vendors/irmin/irmin-pack/layered/conf.mli new file mode 100644 index 000000000000..ee2eba2c3a1f --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/conf.mli @@ -0,0 +1,35 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type config := Irmin.Private.Conf.t + +module Pack : module type of Irmin_pack.Conf + +val lower_root : config -> string +val upper_root0 : config -> string +val upper_root1 : config -> string +val with_lower : config -> bool +val blocking_copy_size : config -> int + +val v : + ?conf:config -> + ?lower_root:string -> + ?upper_root1:string -> + ?upper_root0:string -> + ?with_lower:bool -> + ?blocking_copy_size:int -> + unit -> + config diff --git a/vendors/irmin/irmin-pack/layered/dune b/vendors/irmin/irmin-pack/layered/dune new file mode 100644 index 000000000000..714c054a6ec0 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/dune @@ -0,0 +1,6 @@ +(library + (public_name irmin-pack.layered) + (name irmin_pack_layered) + (libraries irmin-pack irmin-layers) + (preprocess + (pps ppx_irmin))) diff --git a/vendors/irmin/irmin-pack/layered/ext_layered.ml b/vendors/irmin/irmin-pack/layered/ext_layered.ml new file mode 100644 index 000000000000..b1c116a8fa4e --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/ext_layered.ml @@ -0,0 +1,865 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +(* TODO(craigfe): better namespacing of modules shared with [irmin-pack] *) +module Layout_layered = Layout +module V = Irmin_pack.Version.V2 + +let cache_size = 10_000 + +exception Cancelled + +module IO = Irmin_pack.IO.Unix +module Lock = IO_layers.Lock +module IO_layers = IO_layers.IO + +let may f = function None -> Lwt.return_unit | Some bf -> f bf +let lock_path root = Filename.concat root "lock" + +module Maker + (Config : Conf.Pack.S) + (Node : Irmin.Private.Node.Maker) + (Commit : Irmin.Private.Commit.Maker) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) = +struct + module Index = Irmin_pack.Index.Make (H) + module Pack = Irmin_pack.Pack_store.Maker (V) (Index) (H) + + type store_handle = + | Commit_t : H.t -> store_handle + | Node_t : H.t -> store_handle + | Content_t : H.t -> store_handle + + module X = struct + module Hash = H + + module Contents = struct + module Pack_value = Irmin_pack.Pack_value.Of_contents (H) (C) + + (* FIXME: remove duplication with irmin-pack/ext.ml *) + module CA = struct + module Key = H + module Val = C + module CA = Pack.Make (Pack_value) + include Layered_store.Content_addressable (H) (Index) (CA) (CA) + end + + include Irmin.Contents.Store (CA) + end + + module Node = struct + module Pa = Layered_store.Pack_maker (H) (Index) (Pack) + module Node = Node (H) (P) (M) + module CA = Inode_layers.Make (Config) (H) (Pa) (Node) + include Irmin.Private.Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module Commit = Commit (H) + module Pack_value = Irmin_pack.Pack_value.Of_commit (H) (Commit) + + module CA = struct + module Key = H + module Val = Commit + module CA = Pack.Make (Pack_value) + include Layered_store.Content_addressable (H) (Index) (CA) (CA) + end + + include Irmin.Private.Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + + module Atomic_write = struct + module AW = Irmin_pack.Atomic_write.Make_persistent (V) (Key) (Val) + include Irmin_pack.Atomic_write.Closeable (AW) + + let v ?fresh ?readonly path = + AW.v ?fresh ?readonly path >|= make_closeable + end + + include Layered_store.Atomic_write (Key) (Atomic_write) (Atomic_write) + end + + module Slice = Irmin.Private.Slice.Make (Contents) (Node) (Commit) + module Sync = Irmin.Private.Sync.None (H) (B) + + module Repo = struct + type upper_layer = { + contents : read Contents.CA.U.t; + node : read Node.CA.U.t; + commit : read Commit.CA.U.t; + branch : Branch.U.t; + index : Index.t; + } + + type lower_layer = { + lcontents : read Contents.CA.L.t; + lnode : read Node.CA.L.t; + lcommit : read Commit.CA.L.t; + lbranch : Branch.L.t; + lindex : Index.t; + } + + type freeze_info = { + throttle : Conf.Pack.freeze_throttle; + lock : Lwt_mutex.t; + mutable state : [ `None | `Running | `Cancel ]; + } + + type t = { + root : string; + readonly : bool; + blocking_copy_size : int; + with_lower : bool; + contents : read Contents.CA.t; + node : read Node.CA.t; + branch : Branch.t; + commit : read Commit.CA.t; + lower_index : Index.t option; + uppers_index : Index.t * Index.t; + mutable flip : bool; + mutable closed : bool; + flip_file : IO_layers.t; + batch_lock : Lwt_mutex.t; + freeze : freeze_info; + } + + let contents_t t = t.contents + let node_t t = (contents_t t, t.node) + let commit_t t = (node_t t, t.commit) + let branch_t t = t.branch + + module Iterate = struct + module Contents = struct + include Contents.CA + + type t = read Contents.CA.t + end + + module Nodes = struct + include Node.CA + + type t = read Node.CA.t + end + + module Commits = struct + include Commit.CA + + type t = read Commit.CA.t + end + + type 'a store_fn = { + f : 't. (module S.Layered with type t = 't) -> 't -> 'a; + } + [@@ocaml.unboxed] + + let iter_lwt (f : unit Lwt.t store_fn) t : unit Lwt.t = + f.f (module Contents) t.contents >>= fun () -> + f.f (module Nodes) t.node >>= fun () -> + f.f (module Commits) t.commit >>= fun () -> + f.f (module Branch) t.branch + + let iter (f : unit store_fn) t : unit = + f.f (module Contents) t.contents; + f.f (module Nodes) t.node; + f.f (module Commits) t.commit; + f.f (module Branch) t.branch + end + + let batch t f = + Lwt_mutex.with_lock t.batch_lock @@ fun () -> + Contents.CA.batch t.contents (fun contents -> + Node.CA.batch t.node (fun node -> + Commit.CA.batch t.commit (fun commit -> + let contents : 'a Contents.t = contents in + let node : 'a Node.t = (contents, node) in + let commit : 'a Commit.t = (node, commit) in + f contents node commit))) + + let unsafe_v_upper root config = + let fresh = Conf.Pack.fresh config in + let lru_size = Conf.Pack.lru_size config in + let readonly = Conf.Pack.readonly config in + let log_size = Conf.Pack.index_log_size config in + let throttle = Conf.Pack.merge_throttle config in + let f = ref (fun () -> ()) in + let index = + Index.v + ~flush_callback:(fun () -> !f ()) + (* backpatching to add pack flush before an index flush *) + ~fresh ~readonly ~throttle ~log_size root + in + let* contents = + Contents.CA.U.v ~fresh ~readonly ~lru_size ~index root + in + let* node = Node.CA.U.v ~fresh ~readonly ~lru_size ~index root in + let* commit = Commit.CA.U.v ~fresh ~readonly ~lru_size ~index root in + let+ branch = Branch.U.v ~fresh ~readonly root in + (f := fun () -> Contents.CA.U.flush ~index:false contents); + ({ index; contents; node; commit; branch } : upper_layer) + + let unsafe_v_lower root config = + let fresh = Conf.Pack.fresh config in + let lru_size = Conf.Pack.lru_size config in + let readonly = Conf.Pack.readonly config in + let log_size = Conf.Pack.index_log_size config in + let throttle = Conf.Pack.merge_throttle config in + let f = ref (fun () -> ()) in + let index = + Index.v + ~flush_callback:(fun () -> !f ()) + ~fresh ~readonly ~throttle ~log_size root + in + let* lcontents = + Contents.CA.L.v ~fresh ~readonly ~lru_size ~index root + in + let* lnode = Node.CA.L.v ~fresh ~readonly ~lru_size ~index root in + let* lcommit = Commit.CA.L.v ~fresh ~readonly ~lru_size ~index root in + let+ lbranch = Branch.L.v ~fresh ~readonly root in + (f := fun () -> Contents.CA.L.flush ~index:false lcontents); + ({ lindex = index; lcontents; lnode; lcommit; lbranch } : lower_layer) + + let v_layer ~v root config = + Lwt.catch + (fun () -> v root config) + (function + | Irmin_pack.Version.Invalid { expected; found } as e + when expected = V.version -> + Log.err (fun m -> + m "[%s] Attempted to open store of unsupported version %a" + root Irmin_pack.Version.pp found); + Lwt.fail e + | e -> Lwt.fail e) + + let freeze_info throttle = + { throttle; state = `None; lock = Lwt_mutex.create () } + + let v config = + let root = Conf.Pack.root config in + let upper1 = Filename.concat root (Conf.upper_root1 config) in + let* upper1 = v_layer ~v:unsafe_v_upper upper1 config in + let upper0 = Filename.concat root (Conf.upper_root0 config) in + let* upper0 = v_layer ~v:unsafe_v_upper upper0 config in + let with_lower = Conf.with_lower config in + let lower_root = Filename.concat root (Conf.lower_root config) in + let* lower = + if with_lower then + v_layer ~v:unsafe_v_lower lower_root config >|= Option.some + else Lwt.return_none + in + let file = Layout_layered.flip ~root in + let* flip_file = IO_layers.v file in + let* flip = IO_layers.read_flip flip_file in + (* A fresh store has to unlink the lock file as well. *) + let fresh = Conf.Pack.fresh config in + let freeze = freeze_info (Conf.Pack.freeze_throttle config) in + let lock_file = lock_path root in + let freeze_in_progress () = freeze.state = `Running in + let always_false () = false in + let batch_lock = Lwt_mutex.create () in + let+ () = + if fresh && Lock.test lock_file then Lock.unlink lock_file + else Lwt.return_unit + in + let lower_contents = Option.map (fun x -> x.lcontents) lower in + let contents = + Contents.CA.v upper1.contents upper0.contents lower_contents ~flip + ~freeze_in_progress:always_false + in + let lower_node = Option.map (fun x -> x.lnode) lower in + let node = + Node.CA.v upper1.node upper0.node lower_node ~flip + ~freeze_in_progress:always_false + in + let lower_commit = Option.map (fun x -> x.lcommit) lower in + let commit = + Commit.CA.v upper1.commit upper0.commit lower_commit ~flip + ~freeze_in_progress + in + let lower_branch = Option.map (fun x -> x.lbranch) lower in + let branch = + Branch.v upper1.branch upper0.branch lower_branch ~flip + ~freeze_in_progress + in + let lower_index = Option.map (fun x -> x.lindex) lower in + let readonly = Conf.Pack.readonly config in + let blocking_copy_size = Conf.blocking_copy_size config in + { + contents; + node; + commit; + branch; + root; + readonly; + with_lower; + blocking_copy_size; + lower_index; + uppers_index = (upper1.index, upper0.index); + flip; + closed = false; + flip_file; + freeze; + batch_lock; + } + + let unsafe_close t = + t.closed <- true; + (match t.lower_index with Some x -> Index.close x | None -> ()); + Index.close (fst t.uppers_index); + Index.close (snd t.uppers_index); + IO_layers.close t.flip_file >>= fun () -> + let f : unit Lwt.t Iterate.store_fn = + { + f = + (fun (type a) (module C : S.Layered with type t = a) (x : a) -> + C.close x); + } + in + Iterate.iter_lwt f t + + let close t = Lwt_mutex.with_lock t.freeze.lock (fun () -> unsafe_close t) + + (** RO uses the generation to sync the stores, so to prevent races (async + reads of flip and generation) the generation is used to update the + flip. The first store reads the flip and syncs with the files on disk, + the other stores only need to update the flip. *) + let sync t = + let on_generation_change () = + Node.CA.clear_caches t.node; + Commit.CA.clear_caches t.commit + in + let on_generation_change_next_upper () = + Node.CA.clear_caches_next_upper t.node; + Commit.CA.clear_caches_next_upper t.commit + in + let flip = + Contents.CA.sync ~on_generation_change + ~on_generation_change_next_upper t.contents + in + t.flip <- flip; + let f : unit Iterate.store_fn = + { + f = + (fun (type a) (module C : S.Layered with type t = a) (x : a) -> + C.update_flip ~flip x); + } + in + Iterate.iter f t + + let clear t = Contents.CA.clear t.contents + + (** migrate can be called on a layered store where only one layer exists + on disk. As migration fails on an empty store, we check which layer is + in the wrong version. *) + let migrate config = + if Conf.Pack.readonly config then raise Irmin_pack.RO_not_allowed; + let root = Conf.Pack.root config in + Conf.[ upper_root1; upper_root0; lower_root ] + |> List.map (fun name -> + let root = Filename.concat root (name config) in + let config = + Irmin.Private.Conf.add config Conf.Pack.root_key (Some root) + in + try + let io = + IO.v ~version:(Some V.version) ~fresh:false ~readonly:true + (Layout.pack ~root) + in + (config, Some io) + with + | Irmin_pack.Version.Invalid _ -> (config, None) + | e -> raise e) + |> List.fold_left + (fun to_migrate (config, io) -> + match io with + | None -> config :: to_migrate + | Some io -> + IO.close io; + to_migrate) + [] + |> List.iter (fun config -> Irmin_pack.migrate config) + + let layer_id t store_handler = + match store_handler with + | Commit_t k -> Commit.CA.layer_id t.commit k + | Node_t k -> Node.CA.layer_id t.node k + | Content_t k -> Contents.CA.layer_id t.contents k + + let flush t = + Contents.CA.flush t.contents; + Branch.flush t.branch + + let flush_next_lower t = + Contents.CA.flush_next_lower t.contents; + Branch.flush_next_lower t.branch + + (** Store share instances of the underlying IO files, so it is enough to + call clear on one store. However, each store has its own caches, which + need to be cleared too. *) + let clear_previous_upper ?keep_generation t = + Log.debug (fun l -> l "clear previous upper"); + Contents.CA.clear_previous_upper ?keep_generation t.contents + >>= fun () -> + Node.CA.clear_caches_next_upper t.node; + Commit.CA.clear_caches_next_upper t.commit; + Branch.clear_previous_upper t.branch + + let flip_upper t = + t.flip <- not t.flip; + let f : unit Iterate.store_fn = + { + f = + (fun (type a) (module C : S.Layered with type t = a) (x : a) -> + C.flip_upper x); + } + in + Iterate.iter f t + + let write_flip t = IO_layers.write_flip t.flip t.flip_file + let upper_in_use t = if t.flip then `Upper1 else `Upper0 + let offset t = Contents.CA.offset t.contents + end + end + + let integrity_check ?ppf ~auto_repair t = + let module Checks = Irmin_pack.Checks.Index (Index) in + let contents = X.Repo.contents_t t in + let nodes = X.Repo.node_t t |> snd in + let commits = X.Repo.commit_t t |> snd in + let integrity_check_layer ~layer index = + let check ~kind ~offset ~length k = + match kind with + | `Contents -> + X.Contents.CA.integrity_check ~offset ~length ~layer k contents + | `Node -> X.Node.CA.integrity_check ~offset ~length ~layer k nodes + | `Commit -> + X.Commit.CA.integrity_check ~offset ~length ~layer k commits + in + Checks.integrity_check ?ppf ~auto_repair ~check index + in + [ + (`Upper1, Some (fst t.X.Repo.uppers_index)); + (`Upper0, Some (snd t.X.Repo.uppers_index)); + (`Lower, t.lower_index); + ] + |> List.map (fun (layer, index) -> + match index with + | Some index -> (integrity_check_layer ~layer index, layer) + | None -> (Ok `No_error, layer)) + + include Irmin.Of_private (X) + + let sync = X.Repo.sync + let clear = X.Repo.clear + let migrate = X.Repo.migrate + let flush = X.Repo.flush + let pp_commits = Fmt.list ~sep:Fmt.comma Commit.pp_hash + + module Copy = struct + let mem_commit_lower t = X.Commit.CA.mem_lower t.X.Repo.commit + let mem_commit_next t = X.Commit.CA.mem_next t.X.Repo.commit + let mem_node_lower t = X.Node.CA.mem_lower t.X.Repo.node + let mem_node_next t = X.Node.CA.mem_next t.X.Repo.node + let mem_contents_lower t = X.Contents.CA.mem_lower t.X.Repo.contents + let mem_contents_next t = X.Contents.CA.mem_next t.X.Repo.contents + + let copy_branches t = + X.Branch.copy ~mem_commit_lower:(mem_commit_lower t) + ~mem_commit_upper:(mem_commit_next t) t.X.Repo.branch + + let skip_with_stats ~skip h = + skip h >|= fun should_skip -> + Irmin_layers.Stats.skip_test should_skip; + should_skip + + let no_skip _ = Lwt.return false + + let pred_node t k = + let n = snd (X.Repo.node_t t) in + X.Node.CA.find n k >|= function + | None -> [] + | Some v -> + List.rev_map + (function `Inode x -> `Node x | (`Node _ | `Contents _) as x -> x) + (X.Node.CA.Val.pred v) + + let always_false _ = false + let with_cancel cancel f = if cancel () then Lwt.fail Cancelled else f () + + let iter_copy (contents, nodes, commits) ?(skip_commits = no_skip) + ?(cancel = always_false) ?(skip_nodes = no_skip) + ?(skip_contents = no_skip) t ?(min = []) max = + (* if node or contents are already in dst then they are skipped by + Graph.iter; there is no need to check this again when the object is + copied *) + let commit k = + with_cancel cancel @@ fun () -> + X.Commit.CA.copy commits t.X.Repo.commit "Commit" k; + Irmin_layers.Stats.freeze_yield (); + let* () = Lwt.pause () in + Irmin_layers.Stats.freeze_yield_end (); + Lwt.return_unit + in + let node k = + with_cancel cancel @@ fun () -> + X.Node.CA.copy nodes t.X.Repo.node k; + Lwt.return_unit + in + let contents k = + with_cancel cancel @@ fun () -> + X.Contents.CA.copy contents t.X.Repo.contents "Contents" k; + Lwt.return_unit + in + let skip_node h = skip_with_stats ~skip:skip_nodes h in + let skip_contents h = skip_with_stats ~skip:skip_contents h in + let skip_commit h = skip_with_stats ~skip:skip_commits h in + let+ () = + Repo.iter ~cache_size ~min ~max ~commit ~node ~contents ~skip_node + ~skip_contents ~pred_node ~skip_commit t + in + X.Repo.flush t + + module CopyToLower = struct + let on_lower t f = + let contents = + (X.Contents.CA.Lower, X.Contents.CA.lower t.X.Repo.contents) + in + let nodes = (X.Node.CA.Lower, X.Node.CA.lower t.X.Repo.node) in + let commits = (X.Commit.CA.Lower, X.Commit.CA.lower t.X.Repo.commit) in + f (contents, nodes, commits) + + let copy ?cancel ?(min = []) t commits = + Log.debug (fun f -> + f "@[<2>copy to lower:@ min=%a,@ max=%a@]" pp_commits min pp_commits + commits); + let max = List.map (fun x -> `Commit (Commit.hash x)) commits in + let min = List.map (fun x -> `Commit (Commit.hash x)) min in + on_lower t (fun l -> + iter_copy ?cancel l ~skip_commits:(mem_commit_lower t) + ~skip_nodes:(mem_node_lower t) + ~skip_contents:(mem_contents_lower t) t ~min max) + end + + module CopyToUpper = struct + let on_next_upper t f = + let contents = + (X.Contents.CA.Upper, X.Contents.CA.next_upper t.X.Repo.contents) + in + let nodes = (X.Node.CA.Upper, X.Node.CA.next_upper t.X.Repo.node) in + let commits = + (X.Commit.CA.Upper, X.Commit.CA.next_upper t.X.Repo.commit) + in + f (contents, nodes, commits) + + let copy ?cancel ?(min = []) t commits = + Log.debug (fun f -> + f "@[<2>copy to next upper:@ min=%a,@ max=%a@]" pp_commits min + pp_commits commits); + let max = List.map (fun x -> `Commit (Commit.hash x)) commits in + let min = List.map (fun x -> `Commit (Commit.hash x)) min in + on_next_upper t (fun u -> + iter_copy ?cancel u ~skip_commits:(mem_commit_next t) + ~skip_nodes:(mem_node_next t) ~skip_contents:(mem_contents_next t) + ~min t max) + + (** Newies are the objects added in current upper during the freeze. They + are copied to the next upper before the freeze ends. When copying the + newies we have to traverse them as well, to ensure that all objects + used by a newies are also copied in the next upper. We only keep track + of commit newies and rely on `Repo.iter` to compute the transitive + closures of all the newies. *) + let copy_newies ~cancel t = + let newies = X.Commit.CA.consume_newies t.X.Repo.commit in + let newies = List.rev_map (fun x -> `Commit x) newies in + Log.debug (fun l -> l "copy newies"); + (* we want to copy all the new commits; stop whenever one + commmit already in the other upper or in lower. *) + let skip_commits k = + mem_commit_next t k >>= function + | true -> Lwt.return true + | false -> mem_commit_lower t k + in + on_next_upper t (fun u -> + iter_copy u ?cancel ~skip_commits ~skip_nodes:(mem_node_next t) + ~skip_contents:(mem_contents_next t) t newies) + >>= fun () -> X.Branch.copy_newies_to_next_upper t.branch + + (** Repeatedly call [copy_newies] as long as there are many newies (more + than newies_limit bytes added). *) + let rec copy_newies_to_next_upper ~cancel t former_offset = + let newies_limit = Int63.of_int t.X.Repo.blocking_copy_size in + let offset = X.Repo.offset t in + if offset -- former_offset >= newies_limit then ( + Irmin_layers.Stats.copy_newies_loop (); + copy_newies ~cancel t >>= fun () -> + (copy_newies_to_next_upper ~cancel t offset [@tail])) + else Lwt.return_unit + end + + module CopyFromLower = struct + (* FIXME(samoht): copy/paste from iter_copy with s/copy/copy_from_lower *) + let iter_copy (contents, nodes, commits) ?(skip_commits = no_skip) + ?(cancel = always_false) ?(skip_nodes = no_skip) + ?(skip_contents = no_skip) t ?(min = []) cs = + (* if node or contents are already in dst then they are skipped by + Graph.iter; there is no need to check this again when the object is + copied *) + let commit k = + with_cancel cancel @@ fun () -> + X.Commit.CA.copy_from_lower ~dst:commits t.X.Repo.commit "Commit" k + in + let node k = + with_cancel cancel @@ fun () -> + X.Node.CA.copy_from_lower ~dst:nodes t.X.Repo.node k + in + let contents k = + with_cancel cancel @@ fun () -> + X.Contents.CA.copy_from_lower ~dst:contents t.X.Repo.contents + "Contents" k + in + let skip_node h = skip_with_stats ~skip:skip_nodes h in + let skip_contents h = skip_with_stats ~skip:skip_contents h in + let skip_commit h = skip_with_stats ~skip:skip_commits h in + let max = List.map (fun c -> `Commit c) cs in + let min = List.map (fun c -> `Commit c) min in + let+ () = + Repo.iter ~cache_size ~min ~max ~commit ~node ~contents ~skip_node + ~skip_contents ~pred_node ~skip_commit t + in + X.Repo.flush t + + let on_current_upper t f = + let contents = X.Contents.CA.current_upper t.X.Repo.contents in + let nodes = X.Node.CA.current_upper t.X.Repo.node in + let commits = X.Commit.CA.current_upper t.X.Repo.commit in + f (contents, nodes, commits) + + (** An object can be in either lower or upper or both. We can't skip an + object already in upper as some predecessors could still be in lower. *) + let self_contained ?min ~max t = + let max = List.map (fun x -> Commit.hash x) max in + let min = + match min with + | None -> max (* if min is empty then copy only the max commits *) + | Some min -> List.map (fun x -> Commit.hash x) min + in + (* FIXME(samoht): do this in 2 steps: 1/ find the shallow + hashes in upper 2/ iterates with max=shallow + + (ngoguey): we could stop at the uppers directly following a lower. + *) + Log.debug (fun l -> + l + "self_contained: copy commits min:%a; max:%a from lower into \ + upper to make the upper self contained" + (Fmt.list (Irmin.Type.pp H.t)) + min + (Fmt.list (Irmin.Type.pp H.t)) + max); + on_current_upper t (fun u -> iter_copy u ~min t max) + end + end + + let copy ~cancel ~min_lower ~max_lower ~min_upper ~max_upper t = + (* Copy commits to lower. + In case cancellation of the freeze, copies to the lower layer will not + be reverted. Since the copying is performed in the [rev] order, the next + freeze will resume copying where the previous freeze stopped. *) + Irmin_layers.Stats.freeze_section "copy to lower"; + (if t.X.Repo.with_lower then + Copy.CopyToLower.copy ~cancel t ~min:min_lower max_lower + else Lwt.return_unit) + >>= fun () -> + (* Copy [min_upper, max_upper] to next_upper. In case of cancellation of the + freeze, the next upper will be cleared. *) + Irmin_layers.Stats.freeze_section "copy to next upper"; + Copy.CopyToUpper.copy t ~cancel ~min:min_upper max_upper >>= fun () -> + Irmin_layers.Stats.freeze_section "copy branches"; + (* Copy branches to both lower and next_upper *) + Copy.copy_branches t + + module Field = struct + type t = F : 'a Fmt.t * string * 'a -> t | E + + let pp ppf = function E -> () | F (pp, k, v) -> Fmt.pf ppf "%s=%a" k pp v + + let pps ppf t = + Fmt.list ~sep:(Fmt.any "; ") pp ppf (List.filter (fun x -> x <> E) t) + + let commits k = function [] -> E | v -> F (pp_commits, k, v) + end + + let pp_repo ppf t = + Fmt.pf ppf "%a" Layered_store.pp_current_upper t.X.Repo.flip + + let unsafe_freeze ~min_lower ~max_lower ~min_upper ~max_upper ?hook t = + Log.info (fun l -> + l "[%a] freeze starts { %a }" pp_repo t Field.pps + [ + Field.commits "min_lower" min_lower; + Field.commits "max_lower" max_lower; + Field.commits "min_upper" min_upper; + Field.commits "max_upper" max_upper; + ]); + let offset = X.Repo.offset t in + let lock_file = lock_path t.root in + (* We take a file lock here to signal that a freeze was in progess in + case of crash, to trigger the recovery path. *) + let* lock_file = Lock.v lock_file in + let cancel () = t.freeze.state = `Cancel in + let copy () = + may (fun f -> f `Before_Copy) hook >>= fun () -> + copy ~cancel ~min_lower ~max_lower ~min_upper ~max_upper t >>= fun () -> + Irmin_layers.Stats.freeze_section "flush lower"; + X.Repo.flush_next_lower t; + may (fun f -> f `Before_Copy_Newies) hook >>= fun () -> + Irmin_layers.Stats.freeze_section "copy newies (loop)"; + Copy.CopyToUpper.copy_newies_to_next_upper ~cancel:(Some cancel) t offset + >>= fun () -> + may (fun f -> f `Before_Copy_Last_Newies) hook >>= fun () -> + (* Let's finish the freeze under the batch lock so that no concurrent + modifications occur until the uppers are flipped. No more cancellations + from this point on. There are only a few newies left (less than + [newies_limit] bytes) so this lock should be quickly released. *) + Irmin_layers.Stats.freeze_section "wait for batch lock"; + Irmin_layers.Stats.freeze_yield (); + Lwt_mutex.with_lock t.batch_lock (fun () -> + Irmin_layers.Stats.freeze_yield_end (); + Irmin_layers.Stats.freeze_section "copy newies (last)"; + Copy.CopyToUpper.copy_newies ~cancel:None t >>= fun () -> + Irmin_layers.Stats.freeze_section "misc"; + may (fun f -> f `Before_Flip) hook >>= fun () -> + X.Repo.flip_upper t; + may (fun f -> f `Before_Clear) hook >>= fun () -> + X.Repo.clear_previous_upper t) + >>= fun () -> + (* RO reads generation from pack file to detect a flip change, so it's + ok to write the flip file outside the lock *) + X.Repo.write_flip t + in + let finalize cancelled () = + Irmin_layers.Stats.freeze_section "finalize"; + t.freeze.state <- `None; + (if cancelled then X.Repo.clear_previous_upper ~keep_generation:() t + else Lwt.return_unit) + >>= fun () -> + Lock.close lock_file >>= fun () -> + Lwt_mutex.unlock t.freeze.lock; + may (fun f -> f `After_Clear) hook >|= fun () -> + Irmin_layers.Stats.freeze_stop (); + (* Fmt.pr "\n%a%!" Irmin_layers.Stats.pp_latest (); *) + () + in + let async () = + Lwt.try_bind copy (finalize false) (function + | Cancelled -> finalize true () + | e -> Lwt.fail e) + in + Lwt.async async; + Lwt.return_unit + + (** Main thread takes the [t.freeze.lock] at the begining of freeze and async + thread releases it at the end. This is to ensure that no two freezes can + run simultaneously. *) + let freeze' ?min_lower ?max_lower ?min_upper ?max_upper ?(recovery = false) + ?hook t = + let* () = + if recovery then X.Repo.clear_previous_upper ~keep_generation:() t + else Lwt.return_unit + in + let freeze () = + let t0 = Mtime_clock.now () in + Lwt_mutex.lock t.freeze.lock >>= fun () -> + t.freeze.state <- `Running; + Irmin_layers.Stats.freeze_start t0 "wait for freeze lock"; + Irmin_layers.Stats.freeze_section "misc"; + let min_lower = Option.value min_lower ~default:[] in + let* max_lower = + match max_lower with Some l -> Lwt.return l | None -> Repo.heads t + in + let max_upper = Option.value max_upper ~default:max_lower in + let min_upper = Option.value min_upper ~default:max_upper in + unsafe_freeze ~min_lower ~max_lower ~min_upper ~max_upper ?hook t + in + if t.X.Repo.closed then Lwt.fail_with "store is closed" + else if t.readonly then raise Irmin_pack.RO_not_allowed + else + match (t.freeze.state, t.freeze.throttle) with + | `Running, `Overcommit_memory -> Lwt.return () + | `Running, `Cancel_existing -> + t.freeze.state <- `Cancel; + freeze () + | _ -> freeze () + + let layer_id = X.Repo.layer_id + let freeze = freeze' ?hook:None + let async_freeze (t : Repo.t) = Lock.test (lock_path t.X.Repo.root) + let upper_in_use = X.Repo.upper_in_use + let self_contained = Copy.CopyFromLower.self_contained + let needs_recovery t = Lock.test (lock_path t.X.Repo.root) + + let check_self_contained ?heads t = + Log.debug (fun l -> l "Check that the upper layer is self contained"); + let errors = ref 0 in + let none () = + incr errors; + Lwt.return_unit + in + let node k = X.Node.CA.check t.X.Repo.node ~none k in + let contents k = X.Contents.CA.check t.X.Repo.contents ~none k in + let commit k = X.Commit.CA.check t.X.Repo.commit ~none k in + let* heads = + match heads with None -> Repo.heads t | Some m -> Lwt.return m + in + let hashes = List.map (fun x -> `Commit (Commit.hash x)) heads in + let+ () = + Repo.iter ~cache_size ~min:[] ~max:hashes ~commit ~node ~contents t + in + let pp_commits = Fmt.list ~sep:Fmt.comma Commit.pp_hash in + if !errors = 0 then + Fmt.kstr + (fun x -> Ok (`Msg x)) + "Upper layer is self contained for heads %a" pp_commits heads + else + Fmt.kstr + (fun x -> Error (`Msg x)) + "Upper layer is not self contained for heads %a: %n phantom objects \ + detected" + pp_commits heads !errors + + module Private_layer = struct + module Hook = struct + type 'a t = 'a -> unit Lwt.t + + let v f = f + end + + let wait_for_freeze (t : Repo.t) = + Lwt_mutex.with_lock t.freeze.lock (fun () -> Lwt.return_unit) + + let freeze' = freeze' + let upper_in_use = upper_in_use + end +end diff --git a/vendors/irmin/irmin-pack/layered/ext_layered.mli b/vendors/irmin/irmin-pack/layered/ext_layered.mli new file mode 100644 index 000000000000..f275e6ce2935 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/ext_layered.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESIrmin. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Maker + (_ : Irmin_pack.Conf.S) + (_ : Irmin.Private.Node.Maker) + (_ : Irmin.Private.Commit.Maker) : S.Maker diff --git a/vendors/irmin/irmin-pack/layered/import.ml b/vendors/irmin/irmin-pack/layered/import.ml new file mode 100644 index 000000000000..1b88184b47c8 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/import.ml @@ -0,0 +1,26 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends +module Int63 = Optint.Int63 + +let src = Logs.Src.create "irmin.layers" ~doc:"irmin-pack layered backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +type int63 = Int63.t + +let ( -- ) = Int63.sub diff --git a/vendors/irmin/irmin-pack/layered/inode_layers.ml b/vendors/irmin/irmin-pack/layered/inode_layers.ml new file mode 100644 index 000000000000..5a9d200eba7b --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/inode_layers.ml @@ -0,0 +1,111 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Inode_layers_intf + +module Make + (Conf : Irmin_pack.Conf.S) + (H : Irmin.Hash.S) + (Maker : S.Content_addressable_maker + with type key = H.t + and type index := Index.Make(H).t) + (Node : Irmin.Private.Node.S with type hash = H.t) = +struct + type index = Index.Make(H).t + + module Internal = Irmin_pack.Inode.Make_internal (Conf) (H) (Node) + module P = Maker.Make (Internal.Raw) + module Val = Internal.Val + module Key = H + + type 'a t = 'a P.t + type key = Key.t + type value = Val.t + + let mem t k = P.mem t k + let unsafe_find = P.unsafe_find + + let find t k = + P.find t k >|= function + | None -> None + | Some v -> + let find ~expected_depth:_ = unsafe_find ~check_integrity:true t in + let v = Val.of_raw find v in + Some v + + let hash v = Val.hash v + let equal_hash = Irmin.Type.(unstage (equal H.t)) + + let check_hash expected got = + if equal_hash expected got then () + else + Fmt.invalid_arg "corrupted value: got %a, expecting %a" Internal.pp_hash + expected Internal.pp_hash got + + let batch = P.batch + let v = P.v + let integrity_check = P.integrity_check + let close = P.close + let sync = P.sync + let clear = P.clear + let clear_caches = P.clear_caches + + let save t v = + let add k v = P.unsafe_append ~ensure_unique:true ~overcommit:false t k v in + Val.save ~add ~mem:(P.unsafe_mem t) v + + let add t v = + save t v; + Lwt.return (hash v) + + let unsafe_add t k v = + check_hash k (hash v); + save t v; + Lwt.return () + + let clear_caches_next_upper = P.clear_caches_next_upper + + module U = P.U + module L = P.L + + let layer_id = P.layer_id + let mem_lower = P.mem_lower + let lower = P.lower + let mem_next = P.mem_next + let flip_upper = P.flip_upper + let next_upper = P.next_upper + let current_upper = P.current_upper + let consume_newies = P.consume_newies + let update_flip = P.update_flip + let flush ?index t = P.flush ?index t + + type 'a layer_type = + | Upper : read U.t layer_type + | Lower : read L.t layer_type + + let copy_from_lower ~dst t = P.copy_from_lower t "Node" ~dst + + let copy : type l. l layer_type * l -> read t -> key -> unit = + fun (layer, dst) t -> + match layer with + | Lower -> P.copy (Lower, dst) t "Node" + | Upper -> P.copy (Upper, dst) t "Node" + + let check = P.check + let decode_bin_length = Internal.Raw.decode_bin_length + let integrity_check_inodes _ _ = failwith "TODO" +end diff --git a/vendors/irmin/irmin-pack/layered/inode_layers.mli b/vendors/irmin/irmin-pack/layered/inode_layers.mli new file mode 100644 index 000000000000..f26b8bfe79e4 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/inode_layers.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Inode_layers_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/layered/inode_layers_intf.ml b/vendors/irmin/irmin-pack/layered/inode_layers_intf.ml new file mode 100644 index 000000000000..659f34dcdb7b --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/inode_layers_intf.ml @@ -0,0 +1,92 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + include Irmin_pack.Inode.Persistent + module U : Irmin_pack.Pack_store.S with type index := index + module L : Irmin_pack.Pack_store.S with type index := index + + val v : + read U.t -> + read U.t -> + read L.t option -> + flip:bool -> + freeze_in_progress:(unit -> bool) -> + read t + + val layer_id : read t -> key -> Irmin_layers.Layer_id.t Lwt.t + + type 'a layer_type = + | Upper : read U.t layer_type + | Lower : read L.t layer_type + + val copy : 'l layer_type * 'l -> read t -> key -> unit + val mem_lower : 'a t -> key -> bool Lwt.t + val mem_next : [> read ] t -> key -> bool Lwt.t + val next_upper : 'a t -> read U.t + val current_upper : 'a t -> read U.t + val lower : 'a t -> read L.t + + include S.Layered_general with type 'a t := 'a t + + val clear_caches_next_upper : 'a t -> unit + + val sync : + ?on_generation_change:(unit -> unit) -> + ?on_generation_change_next_upper:(unit -> unit) -> + 'a t -> + bool + + val integrity_check : + offset:int63 -> + length:int -> + layer:Irmin_layers.Layer_id.t -> + key -> + 'a t -> + (unit, Irmin_pack.Checks.integrity_error) result + + val flush : ?index:bool -> 'a t -> unit + val copy_from_lower : dst:'a U.t -> read t -> key -> unit Lwt.t + val consume_newies : 'a t -> key list + + val check : + 'a t -> + ?none:(unit -> unit Lwt.t) -> + ?some:(U.value -> unit Lwt.t) -> + key -> + unit Lwt.t +end + +module Index = Irmin_pack.Index + +module type Sigs = sig + module type S = S + + module Make + (_ : Irmin_pack.Conf.S) + (H : Irmin.Hash.S) + (_ : S.Content_addressable_maker + with type key = H.t + and type index = Index.Make(H).t) + (Node : Irmin.Private.Node.S with type hash = H.t) : + S + with type key = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type index = Index.Make(H).t +end diff --git a/vendors/irmin/irmin-pack/layered/irmin_pack_layered.ml b/vendors/irmin/irmin-pack/layered/irmin_pack_layered.ml new file mode 100644 index 000000000000..ed2bdff24844 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/irmin_pack_layered.ml @@ -0,0 +1,28 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Ext_layered +module Maker_ext = Ext_layered.Maker + +module type S = S.Store +module type Maker = S.Maker + +module Maker (Config : Irmin_pack.Conf.S) = + Maker_ext (Config) (Irmin.Private.Node.Make) (Irmin.Private.Commit.Make) + +module Checks = Checks + +let config = Conf.v diff --git a/vendors/irmin/irmin-pack/layered/irmin_pack_layered.mli b/vendors/irmin/irmin-pack/layered/irmin_pack_layered.mli new file mode 100644 index 000000000000..b025d42ae986 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/irmin_pack_layered.mli @@ -0,0 +1,53 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESIrmin. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val config : + ?conf:Irmin.config -> + ?lower_root:string -> + ?upper_root1:string -> + ?upper_root0:string -> + ?with_lower:bool -> + ?blocking_copy_size:int -> + unit -> + Irmin.config +(** Configuration options for layered stores. + + @param conf is an irmin-pack configuration. + @param lower_root is the root of the lower store, "lower" is the default. + @param upper_root1 + is the root of one of the upper stores, "upper1" is the default. + @param upper_root0 + is the root of one of the upper stores, "upper0" is the default. + @param with_lower if true (the default) use a lower layer during freezes. + @param blocking_copy_size + specifies the maximum size (in bytes) that can be copied in the blocking + portion of the freeze. *) + +module type S = sig + include S.Store + (** @inline *) +end + +module type Maker = S.Maker + +module Maker (_ : Irmin_pack.Conf.S) : Maker + +module Maker_ext + (_ : Irmin_pack.Conf.S) + (_ : Irmin.Private.Node.Maker) + (_ : Irmin.Private.Commit.Maker) : Maker + +module Checks = Checks diff --git a/vendors/irmin/irmin-pack/layered/layered_store.ml b/vendors/irmin/irmin-pack/layered/layered_store.ml new file mode 100644 index 000000000000..6e820ed3a658 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/layered_store.ml @@ -0,0 +1,538 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = Irmin_pack.Pack_store.S + +let stats = function + | "Contents" -> Irmin_layers.Stats.copy_contents () + | "Node" -> Irmin_layers.Stats.copy_nodes () + | "Commit" -> Irmin_layers.Stats.copy_commits () + | _ -> failwith "unexpected type in stats" + +module Copy + (Key : Irmin.Hash.S) + (SRC : Irmin_pack.Content_addressable.S with type key := Key.t) + (DST : Irmin_pack.Content_addressable.S + with type key := Key.t + and type value = SRC.value) = +struct + let ignore_lwt _ = Lwt.return_unit + + let copy ~src ~dst str k = + Log.debug (fun l -> l "copy %s %a" str (Irmin.Type.pp Key.t) k); + match SRC.unsafe_find ~check_integrity:false src k with + | None -> + Log.warn (fun l -> + l "Attempt to copy %s %a not contained in upper." str + (Irmin.Type.pp Key.t) k) + | Some v -> + stats str; + DST.unsafe_append ~ensure_unique:false ~overcommit:true dst k v + + let check ~src ?(some = ignore_lwt) ?(none = ignore_lwt) k = + SRC.find src k >>= function None -> none () | Some v -> some v +end + +let pp_during_freeze ppf = function + | true -> Fmt.string ppf " during freeze" + | false -> () + +let pp_layer_id = Irmin_layers.Layer_id.pp +let pp_current_upper ppf t = pp_layer_id ppf (if t then `Upper1 else `Upper0) +let pp_next_upper ppf t = pp_layer_id ppf (if t then `Upper0 else `Upper1) + +module Content_addressable + (H : Irmin.Hash.S) + (Index : Irmin_pack.Index.S) + (U : S with type index := Index.t and type key = H.t) + (L : S + with type index := Index.t + and type key = U.key + and type value = U.value) = +struct + type index = Index.t + type key = U.key + type value = U.value + + type 'a t = { + lower : read L.t option; + mutable flip : bool; + uppers : read U.t * read U.t; + freeze_in_progress : unit -> bool; + mutable newies : key list; + } + + module U = U + module L = L + + let v upper1 upper0 lower ~flip ~freeze_in_progress = + Log.debug (fun l -> l "v flip = %b" flip); + { lower; flip; uppers = (upper1, upper0); freeze_in_progress; newies = [] } + + let next_upper t = if t.flip then snd t.uppers else fst t.uppers + let current_upper t = if t.flip then fst t.uppers else snd t.uppers + let lower t = Option.get t.lower + let pp_current_upper ppf t = pp_current_upper ppf t.flip + let pp_next_upper ppf t = pp_next_upper ppf t.flip + + let mem_lower t k = + match t.lower with None -> Lwt.return false | Some lower -> L.mem lower k + + let mem_next t k = U.mem (next_upper t) k + + let consume_newies t = + let newies = t.newies in + t.newies <- []; + newies + + let add t v = + let freeze = t.freeze_in_progress () in + Log.debug (fun l -> + l "add in %a%a" pp_current_upper t pp_during_freeze freeze); + Irmin_layers.Stats.add (); + let upper = current_upper t in + U.add upper v >|= fun k -> + if freeze then t.newies <- k :: t.newies; + k + + let unsafe_add t k v = + let freeze = t.freeze_in_progress () in + Log.debug (fun l -> + l "unsafe_add in %a%a" pp_current_upper t pp_during_freeze freeze); + Irmin_layers.Stats.add (); + let upper = current_upper t in + U.unsafe_add upper k v >|= fun () -> + if freeze then t.newies <- k :: t.newies + + let unsafe_append ~ensure_unique ~overcommit t k v = + let freeze = t.freeze_in_progress () in + Log.debug (fun l -> + l "unsafe_append in %a%a" pp_current_upper t pp_during_freeze freeze); + Irmin_layers.Stats.add (); + let upper = current_upper t in + U.unsafe_append ~ensure_unique ~overcommit upper k v; + if freeze then t.newies <- k :: t.newies + + (** Everything is in current upper, no need to look in next upper. *) + let find t k = + let current = current_upper t in + Log.debug (fun l -> l "find in %a" pp_current_upper t); + U.find current k >>= function + | Some v -> Lwt.return_some v + | None -> ( + match t.lower with + | None -> Lwt.return_none + | Some lower -> + Log.debug (fun l -> l "find in lower"); + L.find lower k) + + let unsafe_find ~check_integrity t k = + let current = current_upper t in + Log.debug (fun l -> l "unsafe_find in %a" pp_current_upper t); + match U.unsafe_find ~check_integrity current k with + | Some v -> Some v + | None -> ( + match t.lower with + | None -> None + | Some lower -> + Log.debug (fun l -> l "unsafe_find in lower"); + L.unsafe_find ~check_integrity lower k) + + let mem t k = + let current = current_upper t in + U.mem current k >>= function + | true -> Lwt.return_true + | false -> ( + match t.lower with + | None -> Lwt.return_false + | Some lower -> L.mem lower k) + + let unsafe_mem t k = + let current = current_upper t in + U.unsafe_mem current k + || match t.lower with None -> false | Some lower -> L.unsafe_mem lower k + + (** Only flush current upper, to prevent concurrent flushing and appends + during copy. Next upper and lower are flushed at the end of a freeze. *) + let flush ?index ?index_merge t = + let current = current_upper t in + U.flush ?index ?index_merge current + + let flush_next_lower t = + let next = next_upper t in + U.flush ~index_merge:true next; + match t.lower with None -> () | Some x -> L.flush ~index_merge:true x + + let cast t = (t :> read_write t) + + let batch t f = + f (cast t) >|= fun r -> + flush ~index:true t; + r + + (** If the generation changed, then the upper changed too. TODO: This + assumption is ok for now, but does not hold if: + + - the RW store is opened after the RO, + - if RW is closed in the meantime, + - if the RW freezes an even number of times before an RO sync. + + See https://github.com/mirage/irmin/issues/1225 *) + let sync ?on_generation_change ?on_generation_change_next_upper t = + Log.debug (fun l -> l "sync %a" pp_current_upper t); + (* a first implementation where only the current upper is synced *) + let current = current_upper t in + let former_generation = U.generation current in + U.sync ?on_generation_change current; + let generation = U.generation current in + if former_generation <> generation then ( + Log.debug (fun l -> l "generation change, RO updates upper"); + t.flip <- not t.flip; + let current = current_upper t in + U.sync ?on_generation_change:on_generation_change_next_upper current; + match t.lower with None -> () | Some x -> L.sync ?on_generation_change x); + t.flip + + let update_flip ~flip t = t.flip <- flip + + let close t = + U.close (fst t.uppers) >>= fun () -> + U.close (snd t.uppers) >>= fun () -> + match t.lower with None -> Lwt.return_unit | Some x -> L.close x + + let integrity_check ~offset ~length ~layer k t = + match layer with + | `Upper1 -> U.integrity_check ~offset ~length k (fst t.uppers) + | `Upper0 -> U.integrity_check ~offset ~length k (snd t.uppers) + | `Lower -> L.integrity_check ~offset ~length k (lower t) + + let layer_id t k = + let current, upper = + if t.flip then (fst t.uppers, `Upper1) else (snd t.uppers, `Upper0) + in + U.mem current k >>= function + | true -> Lwt.return upper + | false -> ( + match t.lower with + | None -> raise Not_found + | Some lower -> ( + L.mem lower k >|= function + | true -> `Lower + | false -> raise Not_found)) + + let clear t = + U.clear (fst t.uppers) >>= fun () -> + U.clear (snd t.uppers) >>= fun () -> + match t.lower with None -> Lwt.return_unit | Some x -> L.clear x + + let clear_keep_generation t = + U.clear_keep_generation (fst t.uppers) >>= fun () -> + U.clear_keep_generation (snd t.uppers) >>= fun () -> + match t.lower with + | None -> Lwt.return_unit + | Some x -> L.clear_keep_generation x + + let clear_caches t = + let current = current_upper t in + U.clear_caches current + + let clear_caches_next_upper t = + let next = next_upper t in + U.clear_caches next + + (** After clearing the previous upper, we also needs to flush current upper to + disk, otherwise values are not found by the RO. *) + let clear_previous_upper ?keep_generation t = + let previous = next_upper t in + let current = current_upper t in + U.flush current; + match keep_generation with + | Some () -> U.clear_keep_generation previous + | None -> U.clear previous + + let version t = U.version (fst t.uppers) + + let generation t = + let current = current_upper t in + U.generation current + + let offset t = + let current = current_upper t in + U.offset current + + let flip_upper t = + Log.debug (fun l -> l "flip_upper to %a" pp_next_upper t); + t.flip <- not t.flip + + module CopyUpper = Copy (H) (U) (U) + module CopyLower = Copy (H) (U) (L) + + type 'a layer_type = + | Upper : read U.t layer_type + | Lower : read L.t layer_type + + let copy_to_lower t ~dst str k = + CopyLower.copy ~src:(current_upper t) ~dst str k + + let copy_to_next t ~dst str k = + CopyUpper.copy ~src:(current_upper t) ~dst str k + + let check t ?none ?some k = + CopyUpper.check ~src:(current_upper t) ?none ?some k + + let copy : type l. l layer_type * l -> read t -> string -> key -> unit = + fun (ltype, dst) -> + match ltype with Lower -> copy_to_lower ~dst | Upper -> copy_to_next ~dst + + (** The object [k] can be in either lower or upper. If already in upper then + do not copy it. *) + let copy_from_lower t ~dst ?(aux = fun _ -> Lwt.return_unit) str k = + (* FIXME(samoht): why does this function need to be different from the previous one? *) + let lower = lower t in + let current = current_upper t in + U.find current k >>= function + | Some v -> aux v + | None -> ( + L.find lower k >>= function + | Some v -> + aux v >>= fun () -> + stats str; + U.unsafe_add dst k v + | None -> Fmt.failwith "%s %a not found" str (Irmin.Type.pp H.t) k) +end + +module Pack_maker + (H : Irmin.Hash.S) + (Index : Irmin_pack.Index.S) + (P : Irmin_pack.Pack_store.Maker + with type key = H.t + and type index := Index.t) = +struct + type index = Index.t + type key = P.key + + module Make (V : Irmin_pack.Pack_value.S with type hash := key) = struct + module Upper = P.Make (V) + include Content_addressable (H) (Index) (Upper) (Upper) + end +end + +module Atomic_write + (K : Irmin.Branch.S) + (U : Irmin_pack.Atomic_write.Persistent with type key = K.t) + (L : Irmin_pack.Atomic_write.Persistent + with type key = U.key + and type value = U.value) = +struct + type key = U.key + type value = U.value + + module U = U + module L = L + + type t = { + lower : L.t option; + mutable flip : bool; + uppers : U.t * U.t; + freeze_in_progress : unit -> bool; + mutable newies : (key * value option) list; + } + + let current_upper t = if t.flip then fst t.uppers else snd t.uppers + let next_upper t = if t.flip then snd t.uppers else fst t.uppers + let pp_current_upper ppf t = pp_current_upper ppf t.flip + let pp_next_upper ppf t = pp_next_upper ppf t.flip + let pp_branch = Irmin.Type.pp K.t + + let mem t k = + let current = current_upper t in + Log.debug (fun l -> + l "[branches] mem %a in %a" pp_branch k pp_current_upper t); + U.mem current k >>= function + | true -> Lwt.return_true + | false -> ( + match t.lower with + | None -> Lwt.return_false + | Some lower -> + Log.debug (fun l -> l "[branches] mem in lower"); + L.mem lower k) + + let find t k = + let current = current_upper t in + Log.debug (fun l -> l "[branches] find in %a" pp_current_upper t); + U.find current k >>= function + | Some v -> Lwt.return_some v + | None -> ( + match t.lower with + | None -> Lwt.return_none + | Some lower -> + Log.debug (fun l -> l "[branches] find in lower"); + L.find lower k) + + let set t k v = + let freeze = t.freeze_in_progress () in + Log.debug (fun l -> + l "[branches] set %a in %a%a" pp_branch k pp_current_upper t + pp_during_freeze freeze); + let upper = current_upper t in + U.set upper k v >|= fun () -> + if freeze then t.newies <- (k, Some v) :: t.newies + + (** Copy back into upper the branch against we want to do test and set. *) + let test_and_set t k ~test ~set = + let freeze = t.freeze_in_progress () in + Log.debug (fun l -> + l "[branches] test_and_set %a in %a%a" pp_branch k pp_current_upper t + pp_during_freeze freeze); + let current = current_upper t in + let find_in_lower () = + (match t.lower with + | None -> Lwt.return_none + | Some lower -> L.find lower k) + >>= function + | None -> U.test_and_set current k ~test:None ~set + | Some v -> + U.set current k v >>= fun () -> U.test_and_set current k ~test ~set + in + (U.mem current k >>= function + | true -> U.test_and_set current k ~test ~set + | false -> find_in_lower ()) + >|= fun update -> + if update && freeze then t.newies <- (k, set) :: t.newies; + update + + let remove t k = + let freeze = t.freeze_in_progress () in + Log.debug (fun l -> + l "[branches] remove %a in %a%a" pp_branch k pp_current_upper t + pp_during_freeze freeze); + U.remove (fst t.uppers) k >>= fun () -> + U.remove (snd t.uppers) k >>= fun () -> + if freeze then t.newies <- (k, None) :: t.newies; + match t.lower with + | None -> Lwt.return_unit + | Some lower -> L.remove lower k + + let list t = + let current = current_upper t in + U.list current >>= fun upper -> + (match t.lower with None -> Lwt.return_nil | Some lower -> L.list lower) + >|= fun lower -> + List.fold_left + (fun acc b -> if List.mem b acc then acc else b :: acc) + lower upper + + type watch = U.watch + + let watch t = U.watch (current_upper t) + let watch_key t = U.watch_key (current_upper t) + let unwatch t = U.unwatch (current_upper t) + + let close t = + U.close (fst t.uppers) >>= fun () -> + U.close (snd t.uppers) >>= fun () -> + match t.lower with None -> Lwt.return_unit | Some x -> L.close x + + let v upper1 upper0 lower ~flip ~freeze_in_progress = + { lower; flip; uppers = (upper1, upper0); freeze_in_progress; newies = [] } + + let clear t = + U.clear (fst t.uppers) >>= fun () -> + U.clear (snd t.uppers) >>= fun () -> + match t.lower with None -> Lwt.return_unit | Some x -> L.clear x + + let flush t = + let current = current_upper t in + U.flush current + + (** Do not copy branches that point to commits not copied. *) + let copy ~mem_commit_lower ~mem_commit_upper t = + let next = next_upper t in + let current = current_upper t in + U.list current >>= fun branches -> + Lwt_list.iter_p + (fun branch -> + U.find current branch >>= function + | None -> Lwt.fail_with "branch not found in current upper" + | Some hash -> ( + (match t.lower with + | None -> Lwt.return_unit + | Some lower -> ( + mem_commit_lower hash >>= function + | true -> + Log.debug (fun l -> + l "[branches] copy to lower %a" (Irmin.Type.pp K.t) + branch); + Irmin_layers.Stats.copy_branches (); + L.set lower branch hash + | false -> Lwt.return_unit)) + >>= fun () -> + mem_commit_upper hash >>= function + | true -> + Log.debug (fun l -> + l "[branches] copy to next %a" (Irmin.Type.pp K.t) branch); + Irmin_layers.Stats.copy_branches (); + U.set next branch hash + | false -> + Log.debug (fun l -> + l "branch %a not copied" (Irmin.Type.pp K.t) branch); + Lwt.return_unit)) + branches + + let flip_upper t = + Log.debug (fun l -> l "[branches] flip to %a" pp_next_upper t); + t.flip <- not t.flip + + (** After clearing the previous upper, we also needs to flush current upper to + disk, otherwise values are not found by the RO. *) + let clear_previous_upper ?keep_generation t = + let current = current_upper t in + let previous = next_upper t in + U.flush current; + match keep_generation with + | Some () -> U.clear_keep_generation previous + | None -> U.clear previous + + let flush_next_lower t = + let next = next_upper t in + U.flush next; + match t.lower with None -> () | Some x -> L.flush x + + let copy_newies_to_next_upper t = + Log.debug (fun l -> + l "[branches] copy %d newies to %a" (List.length t.newies) pp_next_upper + t); + let next = next_upper t in + let newies = t.newies in + t.newies <- []; + Lwt_list.iter_s + (fun (k, v) -> + match v with None -> U.remove next k | Some v -> U.set next k v) + (List.rev newies) + + (** RO syncs the branch store at every find call, but it still needs to update + the upper in use.*) + let update_flip ~flip t = t.flip <- flip + + let clear_keep_generation t = + U.clear_keep_generation (fst t.uppers) >>= fun () -> + U.clear_keep_generation (snd t.uppers) >>= fun () -> + match t.lower with + | None -> Lwt.return_unit + | Some x -> L.clear_keep_generation x +end diff --git a/vendors/irmin/irmin-pack/layered/layered_store.mli b/vendors/irmin/irmin-pack/layered/layered_store.mli new file mode 100644 index 000000000000..8eeab66984de --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/layered_store.mli @@ -0,0 +1,49 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESIrmin. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val pp_current_upper : bool Fmt.t + +module Content_addressable + (H : Irmin.Hash.S) + (Index : Irmin_pack.Index.S) + (U : Irmin_pack.Pack_store.S with type index := Index.t and type key = H.t) + (L : Irmin_pack.Pack_store.S + with type index := Index.t + and type key = U.key + and type value = U.value) : + S.Content_addressable + with type index = Index.t + and type key = U.key + and type U.key = H.t + and type L.key = H.t + and type value = U.value + and type L.value = U.value + +module Atomic_write + (K : Irmin.Branch.S) + (U : Irmin_pack.Atomic_write.Persistent with type key = K.t) + (L : Irmin_pack.Atomic_write.Persistent + with type key = U.key + and type value = U.value) : + S.Atomic_write with type key = U.key and type value = U.value + +module Pack_maker + (H : Irmin.Hash.S) + (Index : Irmin_pack.Index.S) + (P : Irmin_pack.Pack_store.Maker + with type key = H.t + and type index := Index.t) : + S.Content_addressable_maker with type key = P.key and type index = Index.t diff --git a/vendors/irmin/irmin-pack/layered/layout.ml b/vendors/irmin/irmin-pack/layered/layout.ml new file mode 100644 index 000000000000..97989c1d10c2 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/layout.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_pack.Layout + +let flip = toplevel "flip" diff --git a/vendors/irmin/irmin-pack/layered/s.ml b/vendors/irmin/irmin-pack/layered/s.ml new file mode 100644 index 000000000000..2a3c3f51f372 --- /dev/null +++ b/vendors/irmin/irmin-pack/layered/s.ml @@ -0,0 +1,173 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type Store = sig + include Irmin_layers.S + include Irmin_pack.Specifics with type repo := repo and type commit := commit + + val integrity_check : + ?ppf:Format.formatter -> + auto_repair:bool -> + repo -> + (( [> `Fixed of int | `No_error ], + [> `Cannot_fix of string | `Corrupted of int ] ) + result + * Irmin_layers.Layer_id.t) + list +end + +module type Maker = functor + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) + -> + Store + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + +module type Layered_general = sig + type 'a t + + val close : _ t -> unit Lwt.t + val update_flip : flip:bool -> _ t -> unit + val flip_upper : _ t -> unit +end + +module type Layered = sig + type t + + include Layered_general with type _ t := t +end + +module type Atomic_write = sig + open Irmin_pack.Atomic_write + include S + module U : Persistent + module L : Persistent + + val v : + U.t -> + U.t -> + L.t option -> + flip:bool -> + freeze_in_progress:(unit -> bool) -> + t + + val copy : + mem_commit_lower:(value -> bool Lwt.t) -> + mem_commit_upper:(value -> bool Lwt.t) -> + t -> + unit Lwt.t + + include Layered with type t := t + + val flush_next_lower : t -> unit + val clear_previous_upper : ?keep_generation:unit -> t -> unit Lwt.t + val copy_newies_to_next_upper : t -> unit Lwt.t +end + +module type Content_addressable = sig + open Irmin_pack.Pack_store + include S + module U : S with type value = value and type index := index + module L : S with type index := index + + val v : + read U.t -> + read U.t -> + read L.t option -> + flip:bool -> + freeze_in_progress:(unit -> bool) -> + read t + + val layer_id : read t -> key -> Irmin_layers.Layer_id.t Lwt.t + + type 'a layer_type = + | Upper : read U.t layer_type + | Lower : read L.t layer_type + + val copy : 'l layer_type * 'l -> read t -> string -> key -> unit + + val copy_from_lower : + read t -> + dst:'a U.t -> + ?aux:(value -> unit Lwt.t) -> + string -> + key -> + unit Lwt.t + + val mem_lower : 'a t -> key -> bool Lwt.t + val mem_next : [> read ] t -> key -> bool Lwt.t + val current_upper : 'a t -> read U.t + val next_upper : 'a t -> read U.t + val lower : 'a t -> read L.t + val clear_previous_upper : ?keep_generation:unit -> 'a t -> unit Lwt.t + + val sync : + ?on_generation_change:(unit -> unit) -> + ?on_generation_change_next_upper:(unit -> unit) -> + 'a t -> + bool + + include Layered_general with type 'a t := 'a t + + val clear_caches_next_upper : 'a t -> unit + + val unsafe_append : + ensure_unique:bool -> overcommit:bool -> 'a t -> key -> value -> unit + + val flush_next_lower : 'a t -> unit + + val integrity_check : + offset:int63 -> + length:int -> + layer:Irmin_layers.Layer_id.t -> + key -> + _ t -> + (unit, Irmin_pack.Checks.integrity_error) result + + val consume_newies : 'a t -> key list + + val check : + 'a t -> + ?none:(unit -> unit Lwt.t) -> + ?some:(value -> unit Lwt.t) -> + key -> + unit Lwt.t +end + +module type Content_addressable_maker = sig + type key + type index + + module Make (V : Irmin_pack.Pack_value.S with type hash := key) : + Content_addressable + with type key = key + and type value = V.t + and type index = index + and type U.key = key + and type L.key = key + and type U.value = V.t + and type L.value = V.t +end diff --git a/vendors/irmin/irmin-pack/layout.ml b/vendors/irmin/irmin-pack/layout.ml new file mode 100644 index 000000000000..b49b7817ca50 --- /dev/null +++ b/vendors/irmin/irmin-pack/layout.ml @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let toplevel name ~root = Filename.(concat root name) +let pack = toplevel "store.pack" +let branch = toplevel "store.branches" +let dict = toplevel "store.dict" +let stores ~root = [ pack ~root; branch ~root; dict ~root ] diff --git a/vendors/irmin/irmin-pack/layout.mli b/vendors/irmin/irmin-pack/layout.mli new file mode 100644 index 000000000000..0599774b5500 --- /dev/null +++ b/vendors/irmin/irmin-pack/layout.mli @@ -0,0 +1,28 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Defines the location of the IO instances within the main [irmin-pack] store + directory. *) + +type path := root:string -> string + +val toplevel : string -> path +(** A file in the top-level directory of a store *) + +val pack : path +val branch : path +val dict : path +val stores : root:string -> string list diff --git a/vendors/irmin/irmin-pack/mem/content_addressable.ml b/vendors/irmin/irmin-pack/mem/content_addressable.ml new file mode 100644 index 000000000000..3daee08f28c8 --- /dev/null +++ b/vendors/irmin/irmin-pack/mem/content_addressable.ml @@ -0,0 +1,148 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Pool : sig + type ('k, 'v) t + (** Reference-counted pool of values with corresponding keys. *) + + val create : alloc:('k -> 'v) -> ('k, 'v) t + (** Get an empty pool, given a function for allocating new instances from IDs. *) + + val take : ('k, 'v) t -> 'k -> 'v + (** Get an instance from the pool by its key, allocating it if necessary. *) + + val drop : ('k, 'v) t -> 'k -> unit + (** Reduce the reference count of an element, discarding it if the reference + count drops to 0. *) +end = struct + type 'v elt = { mutable refcount : int; instance : 'v } + type ('k, 'v) t = { instances : ('k, 'v elt) Hashtbl.t; alloc : 'k -> 'v } + + let create ~alloc = { instances = Hashtbl.create 0; alloc } + + let take t k = + match Hashtbl.find_opt t.instances k with + | Some elt -> + elt.refcount <- succ elt.refcount; + elt.instance + | None -> + let instance = t.alloc k in + Hashtbl.add t.instances k { instance; refcount = 1 }; + instance + + let drop t k = + match Hashtbl.find_opt t.instances k with + | None -> failwith "Pool.drop: double free" + | Some { refcount; _ } when refcount <= 0 -> assert false + | Some { refcount = 1; _ } -> Hashtbl.remove t.instances k + | Some elt -> elt.refcount <- pred elt.refcount +end + +module Maker (K : Irmin.Hash.S) = struct + type key = K.t + + module Make (Val : Irmin_pack.Pack_value.S with type hash := K.t) = struct + module KMap = Map.Make (struct + type t = K.t + + let compare = Irmin.Type.(unstage (compare K.t)) + end) + + type key = K.t + type value = Val.t + + type 'a t = { + name : string; + mutable t : value KMap.t; + mutable generation : int63; + } + + let instances = + Pool.create ~alloc:(fun name -> + { name; t = KMap.empty; generation = Int63.zero }) + + let v name = Lwt.return (Pool.take instances name) + let equal_key = Irmin.Type.(unstage (equal K.t)) + + let clear_keep_generation t = + Log.debug (fun f -> f "clear_keep_generation"); + t.t <- KMap.empty; + Lwt.return_unit + + let clear t = + Log.debug (fun f -> f "clear"); + t.t <- KMap.empty; + t.generation <- Int63.succ t.generation; + Lwt.return_unit + + let close t = + Log.debug (fun f -> f "close"); + Pool.drop instances t.name; + Lwt.return_unit + + let cast t = (t :> read_write t) + let batch t f = f (cast t) + let pp_key = Irmin.Type.pp K.t + + let check_key k v = + let k' = Val.hash v in + if equal_key k k' then Ok () else Error (k, k') + + let find t k = + try + let v = KMap.find k t.t in + check_key k v |> Result.map (fun () -> Some v) + with Not_found -> Ok None + + let unsafe_find ~check_integrity:_ t k = + Log.debug (fun f -> f "unsafe find %a" pp_key k); + find t k |> function + | Ok r -> r + | Error (k, k') -> + Fmt.invalid_arg "corrupted value: got %a, expecting %a" pp_key k' + pp_key k + + let find t k = + Log.debug (fun f -> f "find %a" pp_key k); + find t k |> function + | Ok r -> Lwt.return r + | Error (k, k') -> + Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + pp_key k' pp_key k + + let unsafe_mem t k = + Log.debug (fun f -> f "mem %a" pp_key k); + KMap.mem k t.t + + let mem t k = Lwt.return (unsafe_mem t k) + + let unsafe_append ~ensure_unique:_ ~overcommit:_ t k v = + Log.debug (fun f -> f "add -> %a" pp_key k); + t.t <- KMap.add k v t.t + + let unsafe_add t k v = + unsafe_append ~ensure_unique:true ~overcommit:true t k v; + Lwt.return_unit + + let add t v = + let k = Val.hash v in + unsafe_add t k v >|= fun () -> k + + let generation t = t.generation + end +end diff --git a/vendors/irmin/irmin-pack/mem/content_addressable.mli b/vendors/irmin/irmin-pack/mem/content_addressable.mli new file mode 100644 index 000000000000..78b8659ca464 --- /dev/null +++ b/vendors/irmin/irmin-pack/mem/content_addressable.mli @@ -0,0 +1,29 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open! Import + +module Maker (K : Irmin.Hash.S) : sig + type key = K.t + + module Make (Val : Irmin_pack.Pack_value.S with type hash := K.t) : sig + include + Irmin_pack.Content_addressable.S + with type key = K.t + and type value = Val.t + + val v : string -> read t Lwt.t + end +end diff --git a/vendors/irmin/irmin-pack/mem/dune b/vendors/irmin/irmin-pack/mem/dune new file mode 100644 index 000000000000..dc742d08483c --- /dev/null +++ b/vendors/irmin/irmin-pack/mem/dune @@ -0,0 +1,6 @@ +(library + (public_name irmin-pack.mem) + (name irmin_pack_mem) + (libraries irmin-pack irmin.mem) + (preprocess + (pps ppx_irmin))) diff --git a/vendors/irmin/irmin-pack/mem/import.ml b/vendors/irmin/irmin-pack/mem/import.ml new file mode 100644 index 000000000000..543ba01dc6d3 --- /dev/null +++ b/vendors/irmin/irmin-pack/mem/import.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends +module Int63 = Optint.Int63 + +let src = Logs.Src.create "irmin-pack.mem" ~doc:"irmin-pack mem backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +type int63 = Int63.t diff --git a/vendors/irmin/irmin-pack/mem/irmin_pack_mem.ml b/vendors/irmin/irmin-pack/mem/irmin_pack_mem.ml new file mode 100644 index 000000000000..0567cf5f1520 --- /dev/null +++ b/vendors/irmin/irmin-pack/mem/irmin_pack_mem.ml @@ -0,0 +1,159 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct + module AW = Irmin_mem.Atomic_write (K) (V) + include AW + + let v () = AW.v (Irmin_mem.config ()) + let flush _t = () + let clear_keep_generation _ = Lwt.return_unit +end + +module Make + (Node : Irmin.Private.Node.Maker) + (Commit : Irmin.Private.Commit.Maker) + (Config : Irmin_pack.Conf.S) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) = +struct + module Pack = Content_addressable.Maker (H) + + module X = struct + module Hash = H + + type 'a value = { hash : H.t; magic : char; v : 'a } [@@deriving irmin] + + module Contents = struct + module Pack_value = Irmin_pack.Pack_value.Of_contents (H) (C) + + module CA = struct + module Key = H + module Val = C + module CA = Pack.Make (Pack_value) + include Irmin_pack.Content_addressable.Closeable (CA) + + let v x = CA.v x >|= make_closeable + end + + include Irmin.Contents.Store (CA) + end + + module Node = struct + module Node = Node (H) (P) (M) + + module CA = struct + module Inter = Irmin_pack.Inode.Make_internal (Config) (H) (Node) + module CA = Pack.Make (Inter.Raw) + include Irmin_pack.Inode.Make (H) (Node) (Inter) (CA) + + let v = CA.v + end + + include Irmin.Private.Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module Commit = Commit (H) + module Pack_value = Irmin_pack.Pack_value.Of_commit (H) (Commit) + + module CA = struct + module Key = H + module Val = Commit + module CA = Pack.Make (Pack_value) + include Irmin_pack.Content_addressable.Closeable (CA) + + let v x = CA.v x >|= make_closeable + end + + include Irmin.Private.Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + module AW = Atomic_write (Key) (Val) + include Irmin_pack.Atomic_write.Closeable (AW) + + let v () = AW.v () >|= make_closeable + end + + module Slice = Irmin.Private.Slice.Make (Contents) (Node) (Commit) + module Sync = Irmin.Private.Sync.None (H) (B) + + module Repo = struct + type t = { + config : Irmin.Private.Conf.t; + contents : read Contents.CA.t; + node : read Node.CA.t; + commit : read Commit.CA.t; + branch : Branch.t; + } + + let contents_t t : 'a Contents.t = t.contents + let node_t t : 'a Node.t = (contents_t t, t.node) + let commit_t t : 'a Commit.t = (node_t t, t.commit) + let branch_t t = t.branch + + let batch t f = + Commit.CA.batch t.commit (fun commit -> + Node.CA.batch t.node (fun node -> + Contents.CA.batch t.contents (fun contents -> + let contents : 'a Contents.t = contents in + let node : 'a Node.t = (contents, node) in + let commit : 'a Commit.t = (node, commit) in + f contents node commit))) + + let v config = + let root = Irmin_pack.Conf.root config in + let* contents = Contents.CA.v root in + let* node = Node.CA.v root in + let* commit = Commit.CA.v root in + let+ branch = Branch.v () in + { contents; node; commit; branch; config } + + let close t = + Contents.CA.close (contents_t t) >>= fun () -> + Node.CA.close (snd (node_t t)) >>= fun () -> + Commit.CA.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch + + (* An in-memory store is always in sync. *) + let sync _ = () + let flush _ = () + + (* Stores share instances so one clear is enough. *) + let clear t = Contents.CA.clear (contents_t t) + end + end + + include Irmin.Of_private (X) + + let integrity_check_inodes ?heads:_ _ = + Lwt.return + (Error (`Msg "Not supported: integrity checking of in-memory inodes")) + + let sync = X.Repo.sync + let clear = X.Repo.clear + let migrate = Irmin_pack.migrate + let flush = X.Repo.flush + let integrity_check ?ppf:_ ~auto_repair:_ _t = Ok `No_error + let traverse_pack_file _ _ = () +end diff --git a/vendors/irmin/irmin-pack/mem/irmin_pack_mem.mli b/vendors/irmin/irmin-pack/mem/irmin_pack_mem.mli new file mode 100644 index 000000000000..858f3959fc54 --- /dev/null +++ b/vendors/irmin/irmin-pack/mem/irmin_pack_mem.mli @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** A fully in-memory implementation of the [Irmin_pack] flavour of Irmin + backend, intended for users that must be interoperable with the + idiosyncrasies of the persistent implementation. *) + +module Make (_ : Irmin.Private.Node.Maker) (_ : Irmin.Private.Commit.Maker) : + Irmin_pack.Maker diff --git a/vendors/irmin/irmin-pack/migrate.ml b/vendors/irmin/irmin-pack/migrate.ml new file mode 100644 index 000000000000..8853add0e3b0 --- /dev/null +++ b/vendors/irmin/irmin-pack/migrate.ml @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module IO = IO.Unix + +let latest_version = `V2 + +(** Migrate data from the IO [src] (with [name] in path [root_old]) into the + temporary dir [root_tmp], then swap in the replaced version. *) +let migrate_io_to_v2 ~progress src = + IO.migrate ~progress src `V2 |> function + | Ok () -> IO.close src + | Error (`Msg s) -> invalid_arg s + +let run config = + if Conf.readonly config then raise S.RO_not_allowed; + Log.debug (fun l -> l "[%s] migrate" (Conf.root config)); + Layout.stores ~root:(Conf.root config) + |> List.map (fun store -> + let io = IO.v ~version:None ~fresh:false ~readonly:true store in + let version = IO.version io in + (store, io, version)) + |> List.partition (fun (_, _, v) -> v = latest_version) + |> function + | migrated, [] -> + Log.info (fun l -> + l "Store at %s is already in current version (%a)" (Conf.root config) + Version.pp latest_version); + List.iter (fun (_, io, _) -> IO.close io) migrated + | migrated, to_migrate -> + List.iter (fun (_, io, _) -> IO.close io) migrated; + (match migrated with + | [] -> () + | _ :: _ -> + let pp_ios = Fmt.(Dump.list (using (fun (n, _, _) -> n) string)) in + Log.warn (fun l -> + l + "Store is in an inconsistent state: files %a have already been \ + upgraded, but %a have not. Upgrading the remaining files now." + pp_ios migrated pp_ios to_migrate)); + let total = + to_migrate + |> List.map (fun (_, io, _) -> IO.offset io) + |> List.fold_left Int63.add Int63.zero + in + let bar, progress = + Utils.Progress.counter ~total ~sampling_interval:100 + ~message:"Migrating store" ~pp_count:Utils.pp_bytes () + in + List.iter (fun (_, io, _) -> migrate_io_to_v2 ~progress io) to_migrate; + Utils.Progress.finalise bar diff --git a/vendors/irmin/irmin-pack/migrate.mli b/vendors/irmin/irmin-pack/migrate.mli new file mode 100644 index 000000000000..7aa432e980b4 --- /dev/null +++ b/vendors/irmin/irmin-pack/migrate.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val run : Irmin.config -> unit diff --git a/vendors/irmin/irmin-pack/pack_dict.ml b/vendors/irmin/irmin-pack/pack_dict.ml new file mode 100644 index 000000000000..3f0d4f70aaf0 --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_dict.ml @@ -0,0 +1,35 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Dict.S + + val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t +end + +module Make (V : Version.S) = struct + include Dict.Make (V) (IO.Unix) + + (* Add IO caching around Dict.v *) + let IO.Cache.{ v } = + let v_no_cache ~fresh ~readonly = v ~fresh ~readonly in + IO.Cache.memoize ~clear ~valid + ~v:(fun capacity -> v_no_cache ~capacity) + Layout.dict + + let v ?fresh ?readonly ?(capacity = 100_000) root = + v capacity ?fresh ?readonly root +end diff --git a/vendors/irmin/irmin-pack/pack_dict.mli b/vendors/irmin/irmin-pack/pack_dict.mli new file mode 100644 index 000000000000..37dec25b5e62 --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_dict.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Dict.S + + val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t +end + +module Make (_ : Version.S) : S diff --git a/vendors/irmin/irmin-pack/pack_index.ml b/vendors/irmin/irmin-pack/pack_index.ml new file mode 100644 index 000000000000..b0881bb9e460 --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_index.ml @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Pack_index_intf + +module Make (K : Irmin.Hash.S) = struct + module Key = struct + type t = K.t [@@deriving irmin] + + let hash = Irmin.Type.(unstage (short_hash K.t)) ?seed:None + let hash_size = 30 + let equal = Irmin.Type.(unstage (equal K.t)) + let encode = Irmin.Type.(unstage (to_bin_string K.t)) + let encoded_size = K.hash_size + let decode_bin = Irmin.Type.(unstage (decode_bin K.t)) + + let decode s off = + let _, v = decode_bin s off in + v + end + + module Val = struct + type t = int63 * int * Pack_value.Kind.t [@@deriving irmin] + + let encoded_size = (64 / 8) + (32 / 8) + 1 + + let encode ((off, len, kind) : t) = + let buf = Bytes.create encoded_size in + Bytes.set_int64_be buf 0 (Int63.to_int64 off); + Bytes.set_int32_be buf 8 (Int32.of_int len); + Bytes.set buf 12 (Pack_value.Kind.to_magic kind); + Bytes.unsafe_to_string buf + + let decode s pos : t = + let buf = Bytes.unsafe_of_string s in + let off = Bytes.get_int64_be buf pos |> Int63.of_int64 in + let len = Bytes.get_int32_be buf (pos + 8) |> Int32.to_int in + let kind = Bytes.get buf (pos + 12) |> Pack_value.Kind.of_magic_exn in + (off, len, kind) + end + + module Stats = Index.Stats + module Index = Index_unix.Make (Key) (Val) (Index.Cache.Unbounded) + include Index + + (** Implicit caching of Index instances. TODO: Require the user to pass Pack + instance caches explicitly. See + https://github.com/mirage/irmin/issues/1017. *) + let cache = Index.empty_cache () + + let v = Index.v ~cache + let add ?overcommit t k v = replace ?overcommit t k v + let find t k = match find t k with exception Not_found -> None | h -> Some h + let close t = Index.close t +end diff --git a/vendors/irmin/irmin-pack/pack_index.mli b/vendors/irmin/irmin-pack/pack_index.mli new file mode 100644 index 000000000000..1af43c6043db --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_index.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Pack_index_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/pack_index_intf.ml b/vendors/irmin/irmin-pack/pack_index_intf.ml new file mode 100644 index 000000000000..e4665616c008 --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_index_intf.ml @@ -0,0 +1,45 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + include Index.S with type value = int63 * int * Pack_value.Kind.t + + val v : + ?flush_callback:(unit -> unit) -> + ?fresh:bool -> + ?readonly:bool -> + ?throttle:[ `Block_writes | `Overcommit_memory ] -> + ?lru_size:int -> + log_size:int -> + string -> + t + (** Constructor for indices, memoized by [(path, readonly)] pairs. *) + + val find : t -> key -> value option + val add : ?overcommit:bool -> t -> key -> value -> unit + val close : t -> unit + val merge : t -> unit + + module Stats = Index.Stats +end + +module type Sigs = sig + module type S = S + + module Make (K : Irmin.Hash.S) : S with type key = K.t +end diff --git a/vendors/irmin/irmin-pack/pack_store.ml b/vendors/irmin/irmin-pack/pack_store.ml new file mode 100644 index 000000000000..a39dccf1d407 --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_store.ml @@ -0,0 +1,328 @@ +open! Import +include Pack_store_intf + +module Table (K : Irmin.Hash.S) = Hashtbl.Make (struct + type t = K.t + + let hash = K.short_hash + let equal = Irmin.Type.(unstage (equal K.t)) +end) + +module Maker + (V : Version.S) + (Index : Pack_index.S) + (K : Irmin.Hash.S with type t = Index.key) : + Maker with type key = K.t and type index = Index.t = struct + module IO_cache = IO.Cache + module IO = IO.Unix + module Tbl = Table (K) + module Dict = Pack_dict.Make (V) + + type index = Index.t + + type 'a t = { + mutable block : IO.t; + index : Index.t; + dict : Dict.t; + mutable open_instances : int; + } + + let clear ?keep_generation t = + if IO.offset t.block <> Int63.zero then ( + Index.clear t.index; + match V.version with + | `V1 -> IO.truncate t.block + | `V2 -> + IO.clear ?keep_generation t.block; + Dict.clear t.dict) + + let valid t = + if t.open_instances <> 0 then ( + t.open_instances <- t.open_instances + 1; + true) + else false + + let unsafe_v ~index ~fresh ~readonly file = + let root = Filename.dirname file in + let dict = Dict.v ~fresh ~readonly root in + let block = IO.v ~version:(Some V.version) ~fresh ~readonly file in + { block; index; dict; open_instances = 1 } + + let IO_cache.{ v } = + IO_cache.memoize ~clear ~valid ~v:(fun index -> unsafe_v ~index) Layout.pack + + type key = K.t + + let close t = + t.open_instances <- t.open_instances - 1; + if t.open_instances = 0 then ( + if not (IO.readonly t.block) then IO.flush t.block; + IO.close t.block; + Dict.close t.dict) + + module Make_without_close_checks (Val : Pack_value.S with type hash := K.t) = + struct + module H = struct + include K + + let hash = K.short_hash + let equal = Irmin.Type.(unstage (equal K.t)) + end + + module Tbl = Table (K) + module Lru = Irmin.Private.Lru.Make (H) + + type nonrec 'a t = { + pack : 'a t; + lru : Val.t Lru.t; + staging : Val.t Tbl.t; + mutable open_instances : int; + readonly : bool; + } + + type key = K.t + + let equal_key = Irmin.Type.(unstage (equal K.t)) + + type value = Val.t + type index = Index.t + + let unsafe_clear ?keep_generation t = + clear ?keep_generation t.pack; + Tbl.clear t.staging; + Lru.clear t.lru + + (* we need another cache here, as we want to share the LRU and + staging caches too. *) + + let roots = Hashtbl.create 10 + + let valid t = + if t.open_instances <> 0 then ( + t.open_instances <- t.open_instances + 1; + true) + else false + + let flush ?(index = true) ?(index_merge = false) t = + if index_merge then Index.merge t.pack.index; + Dict.flush t.pack.dict; + IO.flush t.pack.block; + if index then Index.flush ~no_callback:() t.pack.index; + Tbl.clear t.staging + + let unsafe_v_no_cache ~fresh ~readonly ~lru_size ~index root = + let pack = v index ~fresh ~readonly root in + let staging = Tbl.create 127 in + let lru = Lru.create lru_size in + { staging; lru; pack; open_instances = 1; readonly } + + let unsafe_v ?(fresh = false) ?(readonly = false) ?(lru_size = 10_000) + ~index root = + try + let t = Hashtbl.find roots (root, readonly) in + if valid t then ( + if fresh then unsafe_clear t; + t) + else ( + Hashtbl.remove roots (root, readonly); + raise Not_found) + with Not_found -> + let t = unsafe_v_no_cache ~fresh ~readonly ~lru_size ~index root in + if fresh then unsafe_clear t; + Hashtbl.add roots (root, readonly) t; + t + + let v ?fresh ?readonly ?lru_size ~index root = + let t = unsafe_v ?fresh ?readonly ?lru_size ~index root in + Lwt.return t + + let pp_hash = Irmin.Type.pp K.t + let decode_key = Irmin.Type.(unstage (decode_bin K.t)) + + let io_read_and_decode_hash ~off t = + let buf = Bytes.create K.hash_size in + let n = IO.read t.pack.block ~off buf in + assert (n = K.hash_size); + let _, v = decode_key (Bytes.unsafe_to_string buf) 0 in + v + + let unsafe_mem t k = + Log.debug (fun l -> l "[pack] mem %a" pp_hash k); + Tbl.mem t.staging k || Lru.mem t.lru k || Index.mem t.pack.index k + + let mem t k = + let b = unsafe_mem t k in + Lwt.return b + + let check_key k v = + let k' = Val.hash v in + if equal_key k k' then Ok () else Error (k, k') + + exception Invalid_read + + let io_read_and_decode ~off ~len t = + if (not (IO.readonly t.pack.block)) && off > IO.offset t.pack.block then + raise Invalid_read; + let buf = Bytes.create len in + let n = IO.read t.pack.block ~off buf in + if n <> len then raise Invalid_read; + let hash off = io_read_and_decode_hash ~off t in + let dict = Dict.find t.pack.dict in + Val.decode_bin ~hash ~dict (Bytes.unsafe_to_string buf) 0 + + let pp_io ppf t = + let name = Filename.basename (Filename.dirname (IO.name t.pack.block)) in + let mode = if t.readonly then ":RO" else "" in + Fmt.pf ppf "%s%s" name mode + + let unsafe_find ~check_integrity t k = + Log.debug (fun l -> l "[pack:%a] find %a" pp_io t pp_hash k); + Stats.incr_finds (); + match Tbl.find t.staging k with + | v -> + Lru.add t.lru k v; + Some v + | exception Not_found -> ( + match Lru.find t.lru k with + | v -> Some v + | exception Not_found -> ( + Stats.incr_cache_misses (); + match Index.find t.pack.index k with + | None -> None + | Some (off, len, _) -> + let v = snd (io_read_and_decode ~off ~len t) in + (if check_integrity then + check_key k v |> function + | Ok () -> () + | Error (expected, got) -> + Fmt.failwith "corrupted value: got %a, expecting %a." + pp_hash got pp_hash expected); + Lru.add t.lru k v; + Some v)) + + let find t k = + let v = unsafe_find ~check_integrity:true t k in + Lwt.return v + + let cast t = (t :> read_write t) + + let integrity_check ~offset ~length k t = + try + let value = snd (io_read_and_decode ~off:offset ~len:length t) in + match check_key k value with + | Ok () -> Ok () + | Error _ -> Error `Wrong_hash + with Invalid_read -> Error `Absent_value + + let batch t f = + let* r = f (cast t) in + if Tbl.length t.staging = 0 then Lwt.return r + else ( + flush t; + Lwt.return r) + + let auto_flush = 1024 + + let unsafe_append ~ensure_unique ~overcommit t k v = + if ensure_unique && unsafe_mem t k then () + else ( + Log.debug (fun l -> l "[pack] append %a" pp_hash k); + let offset k = + match Index.find t.pack.index k with + | None -> + Stats.incr_appended_hashes (); + None + | Some (off, _, _) -> + Stats.incr_appended_offsets (); + Some off + in + let dict = Dict.index t.pack.dict in + let off = IO.offset t.pack.block in + Val.encode_bin ~offset ~dict v k (IO.append t.pack.block); + let len = Int63.to_int (IO.offset t.pack.block -- off) in + Index.add ~overcommit t.pack.index k (off, len, Val.kind v); + if Tbl.length t.staging >= auto_flush then flush t + else Tbl.add t.staging k v; + Lru.add t.lru k v) + + let add t v = + let k = Val.hash v in + unsafe_append ~ensure_unique:true ~overcommit:false t k v; + Lwt.return k + + let unsafe_add t k v = + unsafe_append ~ensure_unique:true ~overcommit:false t k v; + Lwt.return () + + let unsafe_close t = + t.open_instances <- t.open_instances - 1; + if t.open_instances = 0 then ( + Log.debug (fun l -> l "[pack] close %s" (IO.name t.pack.block)); + Tbl.clear t.staging; + Lru.clear t.lru; + close t.pack) + + let close t = + unsafe_close t; + Lwt.return_unit + + let clear t = + unsafe_clear t; + Lwt.return_unit + + let clear_keep_generation t = + unsafe_clear ~keep_generation:() t; + Lwt.return_unit + + let clear_caches t = + Tbl.clear t.staging; + Lru.clear t.lru + + let sync ?(on_generation_change = Fun.id) t = + let former_offset = IO.offset t.pack.block in + let former_generation = IO.generation t.pack.block in + let h = IO.force_headers t.pack.block in + if former_generation <> h.generation then ( + Log.debug (fun l -> l "[pack] generation changed, refill buffers"); + clear_caches t; + on_generation_change (); + IO.close t.pack.block; + let block = + IO.v ~fresh:false ~version:(Some V.version) ~readonly:true + (IO.name t.pack.block) + in + t.pack.block <- block; + Dict.sync t.pack.dict; + Index.sync t.pack.index) + else if h.offset > former_offset then ( + Dict.sync t.pack.dict; + Index.sync t.pack.index) + + let version t = IO.version t.pack.block + let generation t = IO.generation t.pack.block + let offset t = IO.offset t.pack.block + end + + module Make (Val : Pack_value.S with type hash := K.t) = struct + module Inner = Make_without_close_checks (Val) + include Content_addressable.Closeable (Inner) + + let v ?fresh ?readonly ?lru_size ~index path = + Inner.v ?fresh ?readonly ?lru_size ~index path >|= make_closeable + + type index = Inner.index + + let sync ?on_generation_change t = + Inner.sync ?on_generation_change (get_open_exn t) + + let flush ?index ?index_merge t = + Inner.flush ?index ?index_merge (get_open_exn t) + + let version t = Inner.version (get_open_exn t) + let offset t = Inner.offset (get_open_exn t) + let clear_caches t = Inner.clear_caches (get_open_exn t) + + let integrity_check ~offset ~length k t = + Inner.integrity_check ~offset ~length k (get_open_exn t) + end +end diff --git a/vendors/irmin/irmin-pack/pack_store.mli b/vendors/irmin/irmin-pack/pack_store.mli new file mode 100644 index 000000000000..8264322f5c5f --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_store.mli @@ -0,0 +1,2 @@ +include Pack_store_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/pack_store_intf.ml b/vendors/irmin/irmin-pack/pack_store_intf.ml new file mode 100644 index 000000000000..d4c4895553bc --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_store_intf.ml @@ -0,0 +1,59 @@ +open! Import + +(** A [Pack_store.S] is a closeable, persistent implementation of + {!Content_addressable.S} that uses an append-only file of variable-length + data blocks. The data file is indexed by hash via {!Pack_index.S} + implementation. *) +module type S = sig + include Content_addressable.S + + type index + + val v : + ?fresh:bool -> + ?readonly:bool -> + ?lru_size:int -> + index:index -> + string -> + read t Lwt.t + + val sync : ?on_generation_change:(unit -> unit) -> 'a t -> unit + (** syncs a readonly instance with the files on disk. The same file instance + is shared between several pack instances. Therefore only the first pack + instance that checks a generation change, can see it. + [on_generation_change] is a callback for all pack instances to react to a + generation change. *) + + val flush : ?index:bool -> ?index_merge:bool -> 'a t -> unit + val version : _ t -> Version.t + val offset : 'a t -> int63 + + val clear_caches : 'a t -> unit + (** [clear_cache t] clears all the in-memory caches of [t]. Persistent data + are not removed. *) + + (** @inline *) + include S.Checkable with type 'a t := 'a t and type key := key +end + +module type Maker = sig + type key + type index + + (** Save multiple kind of values in the same pack file. Values will be + distinguished using [V.magic], so they have to all be different. *) + + module Make (V : Pack_value.S with type hash := key) : + S with type key = key and type value = V.t and type index = index +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + module Maker + (V : Version.S) + (Index : Pack_index.S) + (K : Irmin.Hash.S with type t = Index.key) : + Maker with type key = K.t and type index = Index.t +end diff --git a/vendors/irmin/irmin-pack/pack_value.ml b/vendors/irmin/irmin-pack/pack_value.ml new file mode 100644 index 000000000000..c3e6de7de98f --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_value.ml @@ -0,0 +1,67 @@ +open! Import +include Pack_value_intf + +module Kind = struct + type t = Commit | Contents | Inode | Node + + let to_magic = function + | Commit -> 'C' + | Contents -> 'B' + | Inode -> 'I' + | Node -> 'N' + + let of_magic_exn = function + | 'C' -> Commit + | 'B' -> Contents + | 'I' -> Inode + | 'N' -> Node + | c -> Fmt.failwith "Kind.of_magic: unexpected magic char %C" c + + let t = Irmin.Type.(map char) of_magic_exn to_magic + let pp = Fmt.using to_magic Fmt.char +end + +type ('h, 'a) value = { hash : 'h; kind : Kind.t; v : 'a } [@@deriving irmin] + +module type S = S with type kind := Kind.t + +module Make (Config : sig + val selected_kind : Kind.t +end) +(Hash : Irmin.Hash.S) +(Data : Irmin.Type.S) = +struct + module Hash = Irmin.Hash.Typed (Hash) (Data) + + type t = Data.t [@@deriving irmin] + type hash = Hash.t + + let hash = Hash.hash + let kind = Config.selected_kind + let value = [%typ: (Hash.t, Data.t) value] + let encode_value = Irmin.Type.(unstage (encode_bin value)) + let decode_value = Irmin.Type.(unstage (decode_bin value)) + let encode_bin ~dict:_ ~offset:_ v hash = encode_value { kind; hash; v } + + let decode_bin ~dict:_ ~hash:_ s off = + let len, t = decode_value s off in + (len, t.v) + + let decode_bin_length = + match Irmin.Type.(Size.of_encoding value) with + | Unknown -> + Fmt.failwith "Type must have a recoverable encoded length: %a" + Irmin.Type.pp_ty t + | Static n -> fun _ _ -> n + | Dynamic f -> f + + let kind _ = Config.selected_kind +end + +module Of_contents = Make (struct + let selected_kind = Kind.Contents +end) + +module Of_commit = Make (struct + let selected_kind = Kind.Commit +end) diff --git a/vendors/irmin/irmin-pack/pack_value.mli b/vendors/irmin/irmin-pack/pack_value.mli new file mode 100644 index 000000000000..25d6a544e98b --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_value.mli @@ -0,0 +1,2 @@ +include Pack_value_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/irmin-pack/pack_value_intf.ml b/vendors/irmin/irmin-pack/pack_value_intf.ml new file mode 100644 index 000000000000..d09e8324f426 --- /dev/null +++ b/vendors/irmin/irmin-pack/pack_value_intf.ml @@ -0,0 +1,52 @@ +open! Import + +module type S = sig + include Irmin.Type.S + + type hash + type kind + + val hash : t -> hash + val kind : t -> kind + + val encode_bin : + dict:(string -> int option) -> + offset:(hash -> int63 option) -> + t -> + hash -> + (string -> unit) -> + unit + + val decode_bin : + dict:(int -> string option) -> + hash:(int63 -> hash) -> + string -> + int -> + int * t + + val decode_bin_length : string -> int -> int +end + +module type Sigs = sig + module Kind : sig + type t = Commit | Contents | Inode | Node [@@deriving irmin] + + val to_magic : t -> char + val of_magic_exn : char -> t + val pp : t Fmt.t + end + + module type S = S with type kind := Kind.t + + module Make (_ : sig + val selected_kind : Kind.t + end) + (Hash : Irmin.Hash.S) + (Data : Irmin.Type.S) : S with type hash = Hash.t + + module Of_contents (Hash : Irmin.Hash.S) (Contents : Irmin.Contents.S) : + S with type t = Contents.t and type hash = Hash.t + + module Of_commit (Hash : Irmin.Hash.S) (Commit : Irmin.Private.Commit.S) : + S with type t = Commit.t and type hash = Hash.t +end diff --git a/vendors/irmin/irmin-pack/s.ml b/vendors/irmin/irmin-pack/s.ml new file mode 100644 index 000000000000..1b670079b474 --- /dev/null +++ b/vendors/irmin/irmin-pack/s.ml @@ -0,0 +1,106 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +exception RO_not_allowed + +module type Checkable = sig + type 'a t + type key + + val integrity_check : + offset:int63 -> + length:int -> + key -> + _ t -> + (unit, [ `Wrong_hash | `Absent_value ]) result +end + +(** [Irmin-pack]-specific extensions to the [Store] module type. *) +module type Specifics = sig + type repo + type commit + + val integrity_check : + ?ppf:Format.formatter -> + auto_repair:bool -> + repo -> + ( [> `Fixed of int | `No_error ], + [> `Cannot_fix of string | `Corrupted of int ] ) + result + (** Checks the integrity of the repository. if [auto_repair] is [true], will + also try to fix the issues. [ppf] is a formatter for progressive + reporting. [`Fixed] and [`Corrupted] report the number of fixed/corrupted + entries. *) + + val sync : repo -> unit + (** [sync t] syncs a readonly pack with the files on disk. Raises + [invalid_argument] if called by a read-write pack.*) + + val clear : repo -> unit Lwt.t + (** [clear t] removes all the data persisted in [t]. This operations provides + snapshot isolation guarantees for read-only instances: read-only instance + will continue to see all the data until they explicitely call {!sync}. *) + + val migrate : Irmin.config -> unit + (** [migrate conf] upgrades the repository with configuration [conf] to use + the latest storage format. + + {b Note:} performing concurrent store operations during the migration, or + attempting to use pre-migration instances of the repository after the + migration is complete, will result in undefined behaviour. *) + + val flush : repo -> unit + (** [flush t] flush read-write pack on disk. Raises [RO_Not_Allowed] if called + by a readonly instance.*) +end + +module type S = sig + include Irmin.S + include Specifics with type repo := repo and type commit := commit + + val integrity_check_inodes : + ?heads:commit list -> + repo -> + ([> `Msg of string ], [> `Msg of string ]) result Lwt.t + + val traverse_pack_file : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit +end + +module S_is_a_store (X : S) : Irmin.S = X + +module type Maker = functor + (Metadata : Irmin.Metadata.S) + (Contents : Irmin.Contents.S) + (Path : Irmin.Path.S) + (Branch : Irmin.Branch.S) + (Hash : Irmin.Hash.S) + -> + S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step + and type Private.Sync.endpoint = unit diff --git a/vendors/irmin/irmin-pack/stats.ml b/vendors/irmin/irmin-pack/stats.ml new file mode 100644 index 000000000000..6255c2fc278a --- /dev/null +++ b/vendors/irmin/irmin-pack/stats.ml @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = { + mutable finds : int; + mutable cache_misses : int; + mutable appended_hashes : int; + mutable appended_offsets : int; +} + +let fresh_stats () = + { finds = 0; cache_misses = 0; appended_hashes = 0; appended_offsets = 0 } + +let stats = fresh_stats () + +let reset_stats () = + stats.finds <- 0; + stats.cache_misses <- 0; + stats.appended_hashes <- 0; + stats.appended_offsets <- 0; + () + +let get () = stats +let incr_finds () = stats.finds <- succ stats.finds +let incr_cache_misses () = stats.cache_misses <- succ stats.cache_misses + +let incr_appended_hashes () = + stats.appended_hashes <- succ stats.appended_hashes + +let incr_appended_offsets () = + stats.appended_offsets <- succ stats.appended_offsets + +type cache_stats = { cache_misses : float } +type offset_stats = { offset_ratio : float; offset_significance : int } + +let div_or_zero a b = if b = 0 then 0. else float_of_int a /. float_of_int b + +let get_cache_stats () = + { cache_misses = div_or_zero stats.cache_misses stats.finds } + +let get_offset_stats () = + { + offset_ratio = + div_or_zero stats.appended_offsets + (stats.appended_offsets + stats.appended_hashes); + offset_significance = stats.appended_offsets + stats.appended_hashes; + } diff --git a/vendors/irmin/irmin-pack/stats.mli b/vendors/irmin/irmin-pack/stats.mli new file mode 100644 index 000000000000..8edef3d23858 --- /dev/null +++ b/vendors/irmin/irmin-pack/stats.mli @@ -0,0 +1,46 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = { + mutable finds : int; + mutable cache_misses : int; + mutable appended_hashes : int; + mutable appended_offsets : int; +} +(** The type for stats for a store S. + + - [finds] is the number of calls to [S.find]; + - [cache_misses] is the number of times a cache miss occured during calls to + [S.find]; + - [appended_hashes] is the number of times a hash was appended, during calls + to [add]; + - [appended_offsets] is the number of times an offset was appended, during + calls to [add]; + + [appended_hashes] + [appended_offsets] = the number of calls to [add] *) + +val reset_stats : unit -> unit +val get : unit -> t +val incr_finds : unit -> unit +val incr_cache_misses : unit -> unit +val incr_appended_hashes : unit -> unit +val incr_appended_offsets : unit -> unit + +type cache_stats = { cache_misses : float } +type offset_stats = { offset_ratio : float; offset_significance : int } + +val get_cache_stats : unit -> cache_stats +val get_offset_stats : unit -> offset_stats diff --git a/vendors/irmin/irmin-pack/traverse_pack_file.ml b/vendors/irmin/irmin-pack/traverse_pack_file.ml new file mode 100644 index 000000000000..9199275a2990 --- /dev/null +++ b/vendors/irmin/irmin-pack/traverse_pack_file.ml @@ -0,0 +1,334 @@ +open! Import +module IO = IO.Unix + +module Stats : sig + type t + + val empty : unit -> t + val add : t -> Pack_value.Kind.t -> unit + val duplicate_entry : t -> unit + val missing_hash : t -> unit + val pp : t Fmt.t +end = struct + open Pack_value.Kind + + type t = { + pack_values : int array; + mutable duplicates : int; + mutable missing_hashes : int; + } + + let empty () = + let pack_values = Array.make 4 0 in + { pack_values; duplicates = 0; missing_hashes = 0 } + + let incr t n = t.pack_values.(n) <- t.pack_values.(n) + 1 + + let add t = function + | Contents -> incr t 0 + | Commit -> incr t 1 + | Node -> incr t 2 + | Inode -> incr t 3 + + let duplicate_entry t = t.duplicates <- t.duplicates + 1 + let missing_hash t = t.missing_hashes <- t.missing_hashes + 1 + + let pp = + let open Fmt.Dump in + record + [ + field "Contents" (fun t -> t.pack_values.(0)) Fmt.int; + field "Commit" (fun t -> t.pack_values.(1)) Fmt.int; + field "Node" (fun t -> t.pack_values.(2)) Fmt.int; + field "Inode" (fun t -> t.pack_values.(3)) Fmt.int; + field "Duplicated entries" (fun t -> t.duplicates) Fmt.int; + field "Missing entries" (fun t -> t.missing_hashes) Fmt.int; + ] +end + +module type Args = sig + module Version : Version.S + module Hash : Irmin.Hash.S + module Index : Pack_index.S with type key := Hash.t + module Inode : Inode.S with type key := Hash.t + module Dict : Pack_dict.S + module Contents : Pack_value.S + module Commit : Pack_value.S +end + +module Make (Args : Args) : sig + val run : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit +end = struct + open Args + + let pp_key = Irmin.Type.pp Hash.t + let decode_key = Irmin.Type.(unstage (decode_bin Hash.t)) + let decode_kind = Irmin.Type.(unstage (decode_bin Pack_value.Kind.t)) + + (* [Repr] doesn't yet support buffered binary decoders, so we hack one + together by re-interpreting [Invalid_argument _] exceptions from [Repr] + as requests for more data. *) + exception Not_enough_buffer + + type index_value = int63 * int * Pack_value.Kind.t [@@deriving irmin] + type index_binding = { key : Hash.t; data : index_value } + type missing_hash = { idx_pack : int; binding : index_binding } + + let equal_index_value (off1, len1, kind1) (off2, len2, kind2) = + Int63.equal off1 off2 + && len1 = len2 + && Pack_value.Kind.to_magic kind1 = Pack_value.Kind.to_magic kind2 + + let pp_binding ppf x = + let off, len, kind = x.data in + Fmt.pf ppf "@[%s with hash %a@,pack offset = %a, length = %d@]" + (match kind with + | Pack_value.Kind.Contents -> "Contents" + | Commit -> "Commit" + | Node -> "Node" + | Inode -> "Inode") + pp_key x.key Int63.pp off len + + module Index_reconstructor = struct + let create ~dest config = + let dest = + match dest with + | `Output path -> + if IO.exists path then + Fmt.invalid_arg "Can't reconstruct index. File already exits."; + path + | `In_place -> + if Conf.readonly config then raise S.RO_not_allowed; + Conf.root config + in + let log_size = Conf.index_log_size config in + Log.app (fun f -> + f "Beginning index reconstruction with parameters: { log_size = %d }" + log_size); + let index = Index.v ~fresh:true ~readonly:false ~log_size dest in + index + + let iter_pack_entry index key data = + Index.add index key data; + Ok () + + let finalise index () = + (* Ensure that the log file is empty, so that subsequent opens with a + smaller [log_size] don't immediately trigger a merge operation. *) + Log.app (fun f -> + f "Completed indexing of pack entries. Running a final merge ..."); + Index.try_merge index; + Index.close index + end + + module Index_checker = struct + let create config = + let log_size = Conf.index_log_size config in + Log.app (fun f -> + f "Beginning index checking with parameters: { log_size = %d }" + log_size); + let index = + Index.v ~fresh:false ~readonly:true ~log_size (Conf.root config) + in + (index, ref 0) + + let iter_pack_entry (index, idx_ref) key data = + match Index.find index key with + | None -> + Error (`Missing_hash { idx_pack = !idx_ref; binding = { key; data } }) + | Some data' when not @@ equal_index_value data data' -> + Error `Inconsistent_entry + | Some _ -> + incr idx_ref; + Ok () + + let finalise (index, _) () = Index.close index + end + + module Index_check_and_fix = struct + let create config = + let log_size = Conf.index_log_size config in + Log.app (fun f -> + f "Beginning index checking with parameters: { log_size = %d }" + log_size); + let index = + Index.v ~fresh:false ~readonly:false ~log_size (Conf.root config) + in + (index, ref 0) + + let iter_pack_entry (index, idx_ref) key data = + match Index.find index key with + | None -> + Index.add index key data; + Error (`Missing_hash { idx_pack = !idx_ref; binding = { key; data } }) + | Some data' when not @@ equal_index_value data data' -> + Error `Inconsistent_entry + | Some _ -> + incr idx_ref; + Ok () + + let finalise (index, _) () = + Log.app (fun f -> + f "Completed indexing of pack entries. Running a final merge ..."); + Index.try_merge index; + Index.close index + end + + let decode_entry_length = function + | Pack_value.Kind.Contents -> Contents.decode_bin_length + | Commit -> Commit.decode_bin_length + | Node | Inode -> Inode.decode_bin_length + + let decode_entry_exn ~off ~buffer ~buffer_off = + try + (* Decode the key and kind by hand *) + let off_after_key, key = decode_key buffer buffer_off in + assert (off_after_key = buffer_off + Hash.hash_size); + let off_after_kind, kind = decode_kind buffer off_after_key in + assert (off_after_kind = buffer_off + Hash.hash_size + 1); + (* Get the length of the entire entry *) + let entry_len = decode_entry_length kind buffer buffer_off in + { key; data = (off, entry_len, kind) } + with + | Invalid_argument msg when msg = "index out of bounds" -> + raise Not_enough_buffer + | Invalid_argument msg when msg = "String.blit / Bytes.blit_string" -> + raise Not_enough_buffer + + let ingest_data_file ~progress ~total pack iter_pack_entry = + let buffer = ref (Bytes.create 1024) in + let refill_buffer ~from = + let read = IO.read pack ~off:from !buffer in + let filled = read = Bytes.length !buffer in + let eof = Int63.equal total (Int63.add from (Int63.of_int read)) in + if (not filled) && not eof then + Fmt.failwith + "When refilling from offset %#Ld (total %#Ld), read %#d but expected \ + %#d" + (Int63.to_int64 from) (Int63.to_int64 total) read + (Bytes.length !buffer) + in + let expand_and_refill_buffer ~from = + let length = Bytes.length !buffer in + if length > 1_000_000_000 (* 1 GB *) then + Fmt.failwith + "Couldn't decode the value at offset %a in %d of buffer space. \ + Corrupted data file?" + Int63.pp from length + else ( + buffer := Bytes.create (2 * length); + refill_buffer ~from) + in + let stats = Stats.empty () in + let rec loop_entries ~buffer_off off missing_hash = + if off >= total then (stats, missing_hash) + else + let buffer_off, off, missing_hash = + match + decode_entry_exn ~off + ~buffer:(Bytes.unsafe_to_string !buffer) + ~buffer_off + with + | { key; data } -> + let off', entry_len, kind = data in + let entry_lenL = Int63.of_int entry_len in + assert (off = off'); + Log.debug (fun l -> + l "k = %a (off, len, kind) = (%a, %d, %a)" pp_key key Int63.pp + off entry_len Pack_value.Kind.pp kind); + Stats.add stats kind; + let missing_hash = + match iter_pack_entry key data with + | Ok () -> Option.map Fun.id missing_hash + | Error `Inconsistent_entry -> + Stats.duplicate_entry stats; + Option.map Fun.id missing_hash + | Error (`Missing_hash x) -> + Stats.missing_hash stats; + Some x + in + progress entry_lenL; + (buffer_off + entry_len, off ++ entry_lenL, missing_hash) + | exception Not_enough_buffer -> + let () = + if buffer_off > 0 then + (* Try again with the value at the start of the buffer. *) + refill_buffer ~from:off + else + (* The entire buffer isn't enough to hold this value: expand it. *) + expand_and_refill_buffer ~from:off + in + (0, off, missing_hash) + in + loop_entries ~buffer_off off missing_hash + in + refill_buffer ~from:Int63.zero; + loop_entries ~buffer_off:0 Int63.zero None + + let run mode config = + let iter_pack_entry, finalise, message = + match mode with + | `Reconstruct_index dest -> + let open Index_reconstructor in + let v = create ~dest config in + (iter_pack_entry v, finalise v, "Reconstructing index") + | `Check_index -> + let open Index_checker in + let v = create config in + (iter_pack_entry v, finalise v, "Checking index") + | `Check_and_fix_index -> + let open Index_check_and_fix in + let v = create config in + (iter_pack_entry v, finalise v, "Checking and fixing index") + in + let run_duration = Mtime_clock.counter () in + let root = Conf.root config in + let pack_file = Filename.concat root "store.pack" in + let pack = + IO.v ~fresh:false ~readonly:true ~version:(Some Version.version) pack_file + in + let total = IO.offset pack in + let bar, progress = + Utils.Progress.counter ~total ~sampling_interval:100 ~message + ~pp_count:Utils.pp_bytes () + in + let stats, missing_hash = + ingest_data_file ~progress ~total pack iter_pack_entry + in + Utils.Progress.finalise bar; + finalise (); + IO.close pack; + let run_duration = Mtime_clock.count run_duration in + let store_stats fmt = + Fmt.pf fmt "Store statistics:@, @[%a@]" Stats.pp stats + in + match missing_hash with + | None -> + Log.app (fun f -> + f "%a in %a. %t" + Fmt.(styled `Green string) + "Success" Mtime.Span.pp run_duration store_stats) + | Some x -> + let msg = + match mode with + | `Check_index -> "Detected missing entries" + | `Check_and_fix_index -> + "Detected missing entries and added them to index" + | _ -> assert false + in + Logs.err (fun f -> + f + "%a in %a.@,\ + First pack entry missing from index is the %d entry of the \ + pack:@,\ + \ %a@,\ + %t" + Fmt.(styled `Red string) + msg Mtime.Span.pp run_duration x.idx_pack pp_binding x.binding + store_stats) +end diff --git a/vendors/irmin/irmin-pack/utils.ml b/vendors/irmin/irmin-pack/utils.ml new file mode 100644 index 000000000000..120a91fa26dc --- /dev/null +++ b/vendors/irmin/irmin-pack/utils.ml @@ -0,0 +1,140 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +type 'a fixed_width_fmt = 'a Fmt.t * int + +(** Pretty-printer for byte counts *) +let pp_bytes : int63 fixed_width_fmt = + (* Round down to the nearest 0.1 *) + let trunc f = Float.trunc (f *. 10.) /. 10. in + let pp ppf i = + match Int63.to_float i with + | n when n < 1024. -> Fmt.pf ppf "%6.1f B " (trunc n) + | n when n < 1024. ** 2. -> Fmt.pf ppf "%6.1f KiB" (trunc (n /. 1024.)) + | n when n < 1024. ** 3. -> + Fmt.pf ppf "%6.1f MiB" (trunc (n /. (1024. ** 2.))) + | n -> Fmt.pf ppf "%6.1f GiB" (trunc (n /. (1024. ** 3.))) + in + (pp, 10) + +module Progress : sig + type t + + val counter : + total:int63 -> + sampling_interval:int -> + ?columns:int -> + message:string -> + ?pp_count:int63 fixed_width_fmt -> + ?ppf:Format.formatter -> + unit -> + t * (int63 -> unit) + (** Renders a progress bar of the form: + + [ MM:SS \[########..............................\] XX%] + + @param ppf Defaults to {!Format.err_formatter} *) + + val finalise : t -> unit + + val increment : + ?ppf:Format.formatter -> + unit -> + t * ((unit -> unit) * (unit -> unit) * (unit -> unit)) + + val finalise_with_stats : t -> int * int * int +end = struct + type stats = int * int * int + + type t = { + ppf : Format.formatter; + update : unit -> unit; + stats : (unit -> stats) option; + } + + let bar width percentage = + let filled = + Float.to_int (Float.of_int (width - 2) *. percentage /. 100.) + in + let not_filled = width - 2 - filled in + "[" + ^ String.init filled (fun _ -> '#') + ^ String.init not_filled (fun _ -> '.') + ^ "]" + + let counter ~total ~sampling_interval ?(columns = 80) ~message + ?pp_count:(pp_count, count_width = (Fmt.nop, 0)) + ?(ppf = Format.err_formatter) () = + let count = ref Int63.zero in + let percentage i = + min (Float.trunc (Int63.to_float i *. 100. /. Int63.to_float total)) 100. + in + let start_time = Mtime_clock.counter () in + let should_update : unit -> bool = + let ticker = ref 0 in + fun () -> + ticker := (!ticker + 1) mod sampling_interval; + !ticker = 0 + in + let bar_width = columns - String.length message - count_width - 16 in + if bar_width < 3 then invalid_arg "Not enough space for a progress bar"; + let update ~first = + let seconds = Mtime_clock.count start_time |> Mtime.Span.to_s in + let percentage = percentage !count in + if first then Format.pp_open_box ppf 0 else Fmt.pf ppf "\r"; + Fmt.pf ppf "%s %a %02.0f:%02.0f %s %3.0f%%%!" message pp_count !count + (Float.div seconds 60.) (Float.rem seconds 60.) + (bar bar_width percentage) percentage + in + let progress i = + count := Int63.add !count i; + if should_update () then update ~first:false + in + update ~first:true; + ({ ppf; update = (fun () -> update ~first:false); stats = None }, progress) + + let increment ?(ppf = Format.err_formatter) () = + let nb_commits = ref 0 in + let nb_nodes = ref 0 in + let nb_contents = ref 0 in + let update ~first = + if first then Format.pp_open_box ppf 0 else Fmt.pf ppf "\r"; + Fmt.pf ppf "\t%dk contents / %dk nodes / %dk commits%!" + (!nb_contents / 1000) (!nb_nodes / 1000) (!nb_commits / 1000) + in + let stats = Some (fun () -> (!nb_commits, !nb_nodes, !nb_contents)) in + let progress count = + incr count; + if !count mod 1000 = 0 then update ~first:false + in + let commits () = progress nb_commits in + let nodes () = progress nb_nodes in + let contents () = progress nb_contents in + update ~first:true; + ( { ppf; update = (fun () -> update ~first:false); stats }, + (contents, nodes, commits) ) + + let finalise { ppf; update; _ } = + update (); + Fmt.pf ppf "@,@]%!" + + let finalise_with_stats { ppf; update; stats } = + update (); + Fmt.pf ppf "@,@]%!"; + (Option.get stats) () +end diff --git a/vendors/irmin/irmin-pack/version.ml b/vendors/irmin/irmin-pack/version.ml new file mode 100644 index 000000000000..78f1513304f6 --- /dev/null +++ b/vendors/irmin/irmin-pack/version.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* For every new version, update the [version] type and [versions] + headers. *) + +type t = [ `V1 | `V2 ] + +exception Invalid of { expected : t; found : t } + +module type S = sig + val version : t +end + +module V1 = struct + let version = `V1 +end + +module V2 = struct + let version = `V2 +end + +let enum = [ (`V1, "00000001"); (`V2, "00000002") ] +let pp = Fmt.of_to_string (function `V1 -> "v1" | `V2 -> "v2") +let to_bin v = List.assoc v enum + +let invalid_arg v = + let pp_full_version ppf v = Fmt.pf ppf "%a (%S)" pp v (to_bin v) in + Fmt.invalid_arg "invalid version: got %S, expecting %a" v + Fmt.(Dump.list pp_full_version) + (List.map fst enum) + +let of_bin b = + try Some (List.assoc b (List.map (fun (x, y) -> (y, x)) enum)) + with Not_found -> None + +let () = + Printexc.register_printer (function + | Invalid v -> + Some + (Fmt.str "Irmin_pack.Version.Invalid { expected:%a; found:%a }" pp + v.expected pp v.found) + | _ -> None) diff --git a/vendors/irmin/irmin-pack/version.mli b/vendors/irmin/irmin-pack/version.mli new file mode 100644 index 000000000000..ab9ed2841577 --- /dev/null +++ b/vendors/irmin/irmin-pack/version.mli @@ -0,0 +1,41 @@ +(* + * Copyright (c) 2018-2021 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Management of disk-format versions. *) + +type t = [ `V1 | `V2 ] +(** The type for version numbers. *) + +val pp : t Fmt.t +(** [pp] is the pretty-format for version numbers. *) + +val to_bin : t -> string +(** [to_bin t] is the 8-bytes binary representation of [t]. *) + +val of_bin : string -> t option +(** [of_bin s] is [Some t] is [to_bin t] is [s] and [None] otherwise. *) + +val invalid_arg : string -> 'a +(** [invalid_arg str] raises [Invalid_argument]. *) + +exception Invalid of { expected : t; found : t } + +module type S = sig + val version : t +end + +module V1 : S +module V2 : S diff --git a/vendors/irmin/irmin/branch.ml b/vendors/irmin/irmin/branch.ml new file mode 100644 index 000000000000..851c014ba3cd --- /dev/null +++ b/vendors/irmin/irmin/branch.ml @@ -0,0 +1,36 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Branch_intf + +module String = struct + type t = string + + let t = Type.string + let master = "master" + + let is_valid s = + let ok = ref true in + let n = String.length s in + let i = ref 0 in + while !i < n do + (match s.[!i] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '.' -> () + | _ -> ok := false); + incr i + done; + !ok +end diff --git a/vendors/irmin/irmin/branch.mli b/vendors/irmin/irmin/branch.mli new file mode 100644 index 000000000000..e2d7c625c617 --- /dev/null +++ b/vendors/irmin/irmin/branch.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** User-defined branches. *) + +include Branch_intf.Branch +(** @inline *) diff --git a/vendors/irmin/irmin/branch_intf.ml b/vendors/irmin/irmin/branch_intf.ml new file mode 100644 index 000000000000..4d2ce4468c6c --- /dev/null +++ b/vendors/irmin/irmin/branch_intf.ml @@ -0,0 +1,62 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open S + +module type S = sig + (** {1 Signature for Branches} *) + + type t [@@deriving irmin] + (** The type for branches. *) + + val master : t + (** The name of the master branch. *) + + val is_valid : t -> bool + (** Check if the branch is valid. *) +end + +module type STORE = sig + (** {1 Branch Store} *) + + include ATOMIC_WRITE_STORE + + module Key : S with type t = key + (** Base functions on keys. *) + + module Val : Hash.S with type t = value + (** Base functions on values. *) +end + +module type Branch = sig + (** {1 Branches} *) + + module type S = S + (** The signature for branches. Irmin branches are similar to Git branches: + they are used to associated user-defined names to head commits. Branches + have a default value: the {{!Branch.S.master} master} branch. *) + + module String : S with type t = string + (** [String] is an implementation of {{!Branch.S} S} where branches are + strings. The [master] branch is ["master"]. Valid branch names contain + only alpha-numeric characters, [-], [_], [.], and [/]. *) + + module type STORE = STORE + (** [STORE] specifies the signature for branch stores. + + A {i branch store} is a mutable and reactive key / value store, where keys + are branch names created by users and values are keys are head commmits. *) +end diff --git a/vendors/irmin/irmin/commit.ml b/vendors/irmin/irmin/commit.ml new file mode 100644 index 000000000000..6989809a81bf --- /dev/null +++ b/vendors/irmin/irmin/commit.ml @@ -0,0 +1,528 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open S +include Commit_intf +open Merge.Infix + +let src = Logs.Src.create "irmin.commit" ~doc:"Irmin commits" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (K : Type.S) = struct + type hash = K.t [@@deriving irmin] + + type t = { node : hash; parents : hash list; info : Info.t } + [@@deriving irmin] + + let parents t = t.parents + let node t = t.node + let info t = t.info + let compare_hash = Type.(unstage (compare K.t)) + + let v ~info ~node ~parents = + let parents = List.fast_sort compare_hash parents in + { node; parents; info } +end + +module Store + (N : Node.STORE) (S : sig + include CONTENT_ADDRESSABLE_STORE with type key = N.key + module Key : Hash.S with type t = key + module Val : S with type t = value and type hash = key + end) = +struct + module Node = N + + type 'a t = 'a N.t * 'a S.t + type key = S.key + type value = S.value + + let add (_, t) = S.add t + let unsafe_add (_, t) = S.unsafe_add t + let mem (_, t) = S.mem t + let find (_, t) = S.find t + let clear (_, t) = S.clear t + let merge_node (t, _) = Merge.f (N.merge t) + let pp_key = Type.pp S.Key.t + let err_not_found k = Fmt.kstr invalid_arg "Commit.get: %a not found" pp_key k + + let get (_, t) k = + S.find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + + let empty_if_none (n, _) = function + | None -> N.add n N.Val.empty + | Some node -> Lwt.return node + + let equal_opt_keys = Type.(unstage (equal (option S.Key.t))) + + let merge_commit info t ~old k1 k2 = + let* v1 = get t k1 in + let* v2 = get t k2 in + if List.mem k1 (S.Val.parents v2) then Merge.ok k2 + else if List.mem k2 (S.Val.parents v1) then Merge.ok k1 + else + (* If we get an error while looking the the lca, then we + assume that there is no common ancestor. Maybe we want to + expose this to the user in a more structured way. But maybe + that's too much low-level details. *) + let* old = + old () >>= function + | Error (`Conflict msg) -> + Log.debug (fun f -> f "old: conflict %s" msg); + Lwt.return_none + | Ok o -> Lwt.return o + in + if equal_opt_keys old (Some k1) then Merge.ok k2 + else if equal_opt_keys old (Some k2) then Merge.ok k1 + else + let old () = + match old with + | None -> Merge.ok None + | Some old -> + let* vold = get t old in + Merge.ok (Some (Some (S.Val.node vold))) + in + merge_node t ~old (Some (S.Val.node v1)) (Some (S.Val.node v2)) + >>=* fun node -> + let* node = empty_if_none t node in + let parents = [ k1; k2 ] in + let commit = S.Val.v ~node ~parents ~info:(info ()) in + let* key = add t commit in + Merge.ok key + + let merge t ~info = Merge.(option (v S.Key.t (merge_commit info t))) + + module Key = Hash.Typed (S.Key) (S.Val) + module Val = S.Val +end + +module History (S : STORE) = struct + type commit = S.Key.t [@@deriving irmin] + type node = S.Node.key + type 'a t = 'a S.t + type v = S.Val.t + + let merge t ~info = + let f ~old c1 c2 = + let somify = Merge.map_promise (fun x -> Some x) in + let merge = S.merge t ~info in + Merge.f merge ~old:(somify old) (Some c1) (Some c2) >>=* function + | None -> Merge.conflict "History.merge" + | Some x -> Merge.ok x + in + Merge.v S.Key.t f + + let v t ~node ~parents ~info = + let commit = S.Val.v ~node ~parents ~info in + let+ hash = S.add t commit in + (hash, commit) + + let pp_key = Type.pp S.Key.t + + let parents t c = + Log.debug (fun f -> f "parents %a" pp_key c); + S.find t c >|= function None -> [] | Some c -> S.Val.parents c + + module U = struct + type t = unit [@@deriving irmin] + end + + module Graph = Object_graph.Make (S.Key) (U) + + let edges t = + Log.debug (fun f -> f "edges"); + [ `Node (S.Val.node t) ] @ List.map (fun k -> `Commit k) (S.Val.parents t) + + let closure t ~min ~max = + Log.debug (fun f -> f "closure"); + let pred = function + | `Commit k -> ( S.find t k >|= function Some r -> edges r | None -> []) + | _ -> Lwt.return_nil + in + let min = List.map (fun k -> `Commit k) min in + let max = List.map (fun k -> `Commit k) max in + let+ g = Graph.closure ~pred ~min ~max () in + List.fold_left + (fun acc -> function `Commit k -> k :: acc | _ -> acc) + [] (Graph.vertex g) + + let ignore_lwt _ = Lwt.return_unit + + let iter t ~min ~max ?(commit = ignore_lwt) ?edge + ?(skip = fun _ -> Lwt.return_false) ?(rev = true) () = + let max = List.map (fun x -> `Commit x) max in + let min = List.map (fun x -> `Commit x) min in + let node = function `Commit x -> commit x | _ -> assert false in + let skip = function `Commit x -> skip x | _ -> assert false in + let pred = function + | `Commit k -> parents t k >|= List.map (fun x -> `Commit x) + | _ -> assert false + in + let edge = + Option.map + (fun edge n pred -> + match (n, pred) with + | `Commit src, `Commit dst -> edge src dst + | _ -> assert false) + edge + in + Graph.iter ~pred ~min ~max ~node ?edge ~skip ~rev () + + module K = struct + type t = S.Key.t + + let compare = Type.(unstage (compare S.Key.t)) + let hash = S.Key.short_hash + let equal = Type.(unstage (equal S.Key.t)) + end + + module KSet = Set.Make (K) + module KHashtbl = Hashtbl.Make (K) + + let read_parents t commit = + S.find t commit >|= function + | None -> KSet.empty + | Some c -> KSet.of_list (S.Val.parents c) + + let equal_keys = Type.(unstage (equal S.Key.t)) + let str_key k = String.sub (Type.to_string S.Key.t k) 0 4 + let pp_key = Fmt.of_to_string str_key + + let pp_keys ppf keys = + let keys = KSet.elements keys in + Fmt.pf ppf "[%a]" Fmt.(list ~sep:(any " ") pp_key) keys + + let str_keys = Fmt.to_to_string pp_keys + let lca_calls = ref 0 + + let rec unqueue todo seen = + if Queue.is_empty todo then None + else + let ((_, commit) as pop) = Queue.pop todo in + if KSet.mem commit seen then unqueue todo seen else Some pop + + (* Traverse the graph of commits using a breadth first search + strategy. Start by visiting the commits in [init] and stops + either when [check] returns [`Stop] or when all the ancestors of + [init] have been visited. *) + let traverse_bfs t ~f ~pp:_ ~check ~init ~return = + let todo = Queue.create () in + let add_todo d x = Queue.add (d, x) todo in + KSet.iter (add_todo 0) init; + let rec aux seen = + match check () with + | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) + | `Stop -> return () + | `Continue -> ( + match unqueue todo seen with + | None -> return () + | Some (depth, commit) -> + (* Log.debug "lca %d: %s.%d %a" + !lca_calls (pp_key commit) depth force (pp ()); *) + let seen = KSet.add commit seen in + let* parents = read_parents t commit in + let () = f depth commit parents in + let parents = KSet.diff parents seen in + KSet.iter (add_todo (depth + 1)) parents; + aux seen) + in + aux KSet.empty + + (* Initially the first node is marked as [Seen1] and the second as [Seen2]. + Marks are updated as the search progresses, and may change. *) + type mark = + | Seen1 (* reachable from the first commit *) + | Seen2 (* reachable from the second commit *) + | SeenBoth (* reachable from both, but below an LCA *) + | LCA + + (* reachable from both; candidate for the answer set *) + + let _pp_mark = function + | Seen1 -> "seen1" + | Seen2 -> "seen2" + | SeenBoth -> "seenBoth" + | LCA -> "LCA" + + (* Exploration state *) + type state = { + marks : mark KHashtbl.t; + (* marks of commits already explored *) + parents : KSet.t KHashtbl.t; + (* parents of commits already explored *) + layers : (int, KSet.t) Hashtbl.t; + (* layers of commit, sorted by depth *) + c1 : S.key; + (* initial state 1 *) + c2 : S.key; + (* initial state 2 *) + mutable depth : int; + (* the current exploration depth *) + mutable lcas : int; + (* number of commit marked with LCA *) + mutable complete : bool; (* is the exploration complete? *) + } + + let pp_state t = + lazy + (let pp m = + KHashtbl.fold + (fun k v acc -> if v = m then str_key k :: acc else acc) + t.marks [] + |> String.concat " " + in + Fmt.str "d: %d, seen1: %s, seen2: %s, seenboth: %s, lcas: %s (%d) %s" + t.depth (pp Seen1) (pp Seen2) (pp SeenBoth) (pp LCA) t.lcas + (String.concat " | " + (Hashtbl.fold + (fun d ks acc -> Fmt.str "(%d: %s)" d (str_keys ks) :: acc) + t.layers []))) + + let get_mark_exn t elt = KHashtbl.find t.marks elt + let get_mark t elt = try Some (get_mark_exn t elt) with Not_found -> None + let set_mark t elt mark = KHashtbl.replace t.marks elt mark + let get_layer t d = try Hashtbl.find t.layers d with Not_found -> KSet.empty + + let add_to_layer t d k = + Hashtbl.replace t.layers d (KSet.add k (get_layer t d)) + + let add_parent t c p = KHashtbl.add t.parents c p + + let get_parent t c = + try KHashtbl.find t.parents c with Not_found -> KSet.empty + + let incr_lcas t = t.lcas <- t.lcas + 1 + let decr_lcas t = t.lcas <- t.lcas - 1 + + let both_seen t k = + match get_mark t k with + | None | Some Seen1 | Some Seen2 -> false + | _ -> true + + let empty_state c1 c2 = + let t = + { + marks = KHashtbl.create 10; + parents = KHashtbl.create 10; + layers = Hashtbl.create 10; + c1; + c2; + depth = 0; + lcas = 0; + complete = false; + } + in + set_mark t c1 Seen1; + set_mark t c2 Seen2; + t + + (* update the parent mark and keep the number of lcas up-to-date. *) + let update_mark t mark commit = + let new_mark = + match (mark, get_mark t commit) with + | Seen1, Some Seen1 | Seen1, None -> Seen1 + | Seen2, Some Seen2 | Seen2, None -> Seen2 + | SeenBoth, Some LCA -> + decr_lcas t; + SeenBoth + | SeenBoth, _ -> SeenBoth + | Seen1, Some Seen2 | Seen2, Some Seen1 -> + incr_lcas t; + LCA + | _, Some LCA -> LCA + | _ -> SeenBoth + in + (* check for fast-forwards *) + let is_init () = equal_keys commit t.c1 || equal_keys commit t.c2 in + let is_shared () = new_mark = SeenBoth || new_mark = LCA in + if is_shared () && is_init () then ( + Log.debug (fun f -> f "fast-forward"); + t.complete <- true); + set_mark t commit new_mark; + new_mark + + (* update the ancestors which have already been visisted. *) + let update_ancestors_marks t mark commit = + let todo = Queue.create () in + Queue.add commit todo; + let rec loop mark = + if Queue.is_empty todo then () + else + let a = Queue.pop todo in + let old_mark = get_mark t a in + let mark = update_mark t mark a in + let () = + match old_mark with + | Some (SeenBoth | LCA) -> () (* Can't be an LCA lower down *) + | Some old when old = mark -> () (* No change *) + | _ -> KSet.iter (fun x -> Queue.push x todo) (get_parent t a) + in + loop (if mark = LCA then SeenBoth else mark) + in + loop mark + + (* We are looking for LCAs, doing a breadth-first-search from the two starting commits. + This is called each time we visit a new commit. *) + let update_parents t depth commit parents = + add_parent t commit parents; + add_to_layer t depth commit; + if depth <> t.depth then ( + assert (depth = t.depth + 1); + + (* before starting to explore a new layer, check if we really + have some work to do, ie. do we still have a commit seen only + by one node? *) + let layer = get_layer t t.depth in + let complete = KSet.for_all (both_seen t) layer in + if complete then t.complete <- true else t.depth <- depth); + let mark = get_mark_exn t commit in + KSet.iter (update_ancestors_marks t mark) parents + + let lcas t = + KHashtbl.fold (fun k v acc -> if v = LCA then k :: acc else acc) t.marks [] + + let check ~max_depth ~n t = + if t.depth > max_depth then `Max_depth_reached + else if t.lcas > n then `Too_many_lcas + else if t.lcas = n || t.complete then `Stop + else `Continue + + let lcas t ?(max_depth = max_int) ?(n = max_int) c1 c2 = + incr lca_calls; + if max_depth < 0 then Lwt.return (Error `Max_depth_reached) + else if n <= 0 then Lwt.return (Error `Too_many_lcas) + else if equal_keys c1 c2 then Lwt.return (Ok [ c1 ]) + else + let init = KSet.of_list [ c1; c2 ] in + let s = empty_state c1 c2 in + let check () = check ~max_depth ~n s in + let pp () = pp_state s in + let return () = Lwt.return (Ok (lcas s)) in + let t0 = Sys.time () in + Lwt.finalize + (fun () -> + traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return) + (fun () -> + let t1 = Sys.time () -. t0 in + Log.debug (fun f -> + f "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1); + Lwt.return_unit) + + let rec three_way_merge t ~info ?max_depth ?n c1 c2 = + Log.debug (fun f -> f "3-way merge between %a and %a" pp_key c1 pp_key c2); + if equal_keys c1 c2 then Merge.ok c1 + else + let* lcas = lcas t ?max_depth ?n c1 c2 in + let old () = + match lcas with + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok (old :: olds) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | old :: olds -> + three_way_merge t ~info acc old >>=* fun acc -> aux acc olds + in + aux old olds + in + let merge = + merge t ~info + |> Merge.with_conflict (fun msg -> + Fmt.str "Recursive merging of common ancestors: %s" msg) + |> Merge.f + in + merge ~old c1 c2 + + let lca_aux t ~info ?max_depth ?n c1 c2 = + if equal_keys c1 c2 then Merge.ok (Some c1) + else + lcas t ?max_depth ?n c1 c2 >>= function + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok [ x ] -> Merge.ok (Some x) + | Ok (c :: cs) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | c :: cs -> ( + three_way_merge t ~info ?max_depth ?n acc c >>= function + | Error (`Conflict _) -> Merge.ok None + | Ok acc -> aux acc cs) + in + aux c cs + + let rec lca t ~info ?max_depth ?n = function + | [] -> Merge.conflict "History.lca: empty" + | [ c ] -> Merge.ok (Some c) + | c1 :: c2 :: cs -> ( + lca_aux t ~info ?max_depth ?n c1 c2 >>=* function + | None -> Merge.ok None + | Some c -> lca t ~info ?max_depth ?n (c :: cs)) +end + +module V1 (C : S) = struct + module K = struct + let h = Type.string_of `Int64 + let hash_to_bin_string = Type.(unstage (to_bin_string C.hash_t)) + let hash_of_bin_string = Type.(unstage (of_bin_string C.hash_t)) + let size_of = Type.Size.using hash_to_bin_string (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.(unstage (encode_bin h)) in + fun e k -> encode_bin (hash_to_bin_string e) k + + let decode_bin = + let decode_bin = Type.(unstage (decode_bin h)) in + fun buf off -> + let n, v = decode_bin buf off in + ( n, + match hash_of_bin_string v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e ) + + let t = Type.like C.hash_t ~bin:(encode_bin, decode_bin, size_of) + end + + type hash = C.hash [@@deriving irmin] + type t = { parents : hash list; c : C.t } + + let import c = { c; parents = C.parents c } + let export t = t.c + let node t = C.node t.c + let parents t = t.parents + let info t = C.info t.c + let v ~info ~node ~parents = { parents; c = C.v ~node ~parents ~info } + let make = v + + let info_t : Info.t Type.t = + let open Type in + record "info" (fun date author message -> Info.v ~date ~author message) + |+ field "date" int64 (fun t -> Info.date t) + |+ field "author" (string_of `Int64) (fun t -> Info.author t) + |+ field "message" (string_of `Int64) (fun t -> Info.message t) + |> sealr + + let t : t Type.t = + let open Type in + record "commit" (fun node parents info -> make ~info ~node ~parents) + |+ field "node" K.t node + |+ field "parents" (list ~len:`Int64 K.t) parents + |+ field "info" info_t info + |> sealr +end diff --git a/vendors/irmin/irmin/commit.mli b/vendors/irmin/irmin/commit.mli new file mode 100644 index 000000000000..dc01dbfbc5d9 --- /dev/null +++ b/vendors/irmin/irmin/commit.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Commit values represent the store history. + + Every commit contains a list of predecessor commits, and the collection of + commits form an acyclic directed graph. + + Every commit also can contain an optional key, pointing to a + {{!Private.Commit.STORE} node} value. See the {{!Private.Node.STORE} Node} + signature for more details on node values. *) + +include Commit_intf.Commit +(** @inline *) diff --git a/vendors/irmin/irmin/commit_intf.ml b/vendors/irmin/irmin/commit_intf.ml new file mode 100644 index 000000000000..8e9d5a9c844a --- /dev/null +++ b/vendors/irmin/irmin/commit_intf.ml @@ -0,0 +1,210 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open S +open! Import + +module type S = sig + (** {1 Commit values} *) + + type t + (** The type for commit values. *) + + type hash + (** Type for keys. *) + + val v : info:Info.t -> node:hash -> parents:hash list -> t + (** Create a commit. *) + + val node : t -> hash + (** The underlying node. *) + + val parents : t -> hash list + (** The commit parents. *) + + val info : t -> Info.t + (** The commit info. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val hash_t : hash Type.t + (** [hash_t] is the value type for {!hash}. *) +end + +module type Maker = functor (H : Type.S) -> S with type hash = H.t + +module type STORE = sig + (** {1 Commit Store} *) + + include CONTENT_ADDRESSABLE_STORE + + val merge : [> read_write ] t -> info:Info.f -> key option Merge.t + (** [merge] is the 3-way merge function for commit keys. *) + + (** [Key] provides base functions for commit keys. *) + module Key : Hash.TYPED with type t = key and type value = value + + (** [Val] provides functions for commit values. *) + module Val : S with type t = value and type hash = key + + module Node : Node.STORE with type key = Val.hash + (** [Node] is the underlying node store. *) +end + +module type HISTORY = sig + (** {1 Commit History} *) + + type 'a t + (** The type for store handles. *) + + type node + (** The type for node values. *) + + type commit + (** The type for commit values. *) + + type v + (** The type for commit objects. *) + + val v : + [> write ] t -> + node:node -> + parents:commit list -> + info:Info.t -> + (commit * v) Lwt.t + (** Create a new commit. *) + + val parents : [> read ] t -> commit -> commit list Lwt.t + (** Get the commit parents. + + Commits form a append-only, fully functional, partial-order + data-structure: every commit carries the list of its immediate + predecessors. *) + + val merge : [> read_write ] t -> info:Info.f -> commit Merge.t + (** [merge t] is the 3-way merge function for commit. *) + + val lcas : + [> read ] t -> + ?max_depth:int -> + ?n:int -> + commit -> + commit -> + (commit list, [ `Max_depth_reached | `Too_many_lcas ]) result Lwt.t + (** Find the lowest common ancestors + {{:http://en.wikipedia.org/wiki/Lowest_common_ancestor} lca} between two + commits. *) + + val lca : + [> read_write ] t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit list -> + (commit option, Merge.conflict) result Lwt.t + (** Compute the lowest common ancestors ancestor of a list of commits by + recursively calling {!lcas} and merging the results. + + If one of the merges results in a conflict, or if a call to {!lcas} + returns either [Error `Max_depth_reached] or [Error `Too_many_lcas] then + the function returns the same error. *) + + val three_way_merge : + [> read_write ] t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + commit -> + (commit, Merge.conflict) result Lwt.t + (** Compute the {!lcas} of the two commit and 3-way merge the result. *) + + val closure : + [> read ] t -> min:commit list -> max:commit list -> commit list Lwt.t + (** Same as {{!NODE_GRAPH.closure} NODE_GRAPH.closure} but for the history + graph. *) + + val iter : + [> read ] t -> + min:node list -> + max:node list -> + ?commit:(commit -> unit Lwt.t) -> + ?edge:(node -> node -> unit Lwt.t) -> + ?skip:(node -> bool Lwt.t) -> + ?rev:bool -> + unit -> + unit Lwt.t + (** Same as {{!NODE_GRAPH.iter} NODE_GRAPH.iter} but for traversing the + history graph. *) + + (** {1 Value Types} *) + + val commit_t : commit Type.t + (** [commit_t] is the value type for {!commit}. *) +end + +module type Commit = sig + module type S = S + module type Maker = Maker + + module Make : Maker + (** [Make] provides a simple implementation of commit values, parameterized by + the commit and node keys [K]. *) + + (** V1 serialisation. *) + module V1 (C : S) : sig + include S with type hash = C.hash + + val import : C.t -> t + val export : t -> C.t + end + + module type STORE = STORE + (** [STORE] specifies the signature for commit stores. *) + + (** [Store] creates a new commit store. *) + module Store + (N : Node.STORE) (C : sig + include CONTENT_ADDRESSABLE_STORE with type key = N.key + module Key : Hash.S with type t = key + module Val : S with type t = value and type hash = key + end) : + STORE + with type 'a t = 'a N.t * 'a C.t + and type key = C.key + and type value = C.value + and type Key.t = C.Key.t + and module Val = C.Val + + module type HISTORY = HISTORY + (** [History] specifies the signature for commit history. The history is + represented as a partial-order of commits and basic functions to search + through that history are provided. + + Every commit can point to an entry point in a node graph, where + user-defined contents are stored. *) + + (** Build a commit history. *) + module History (C : STORE) : + HISTORY + with type 'a t = 'a C.t + and type v = C.Val.t + and type node = C.Node.key + and type commit = C.key +end diff --git a/vendors/irmin/irmin/conf.ml b/vendors/irmin/irmin/conf.ml new file mode 100644 index 000000000000..005a6c0ef446 --- /dev/null +++ b/vendors/irmin/irmin/conf.ml @@ -0,0 +1,128 @@ +(* + * Copyright (c) 2017 Daniel C. Bünzli + * Copyright (c) 2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type 'a parser = string -> ('a, [ `Msg of string ]) result +type 'a printer = 'a Fmt.t +type 'a converter = 'a parser * 'a printer + +let parser (p, _) = p +let printer (_, p) = p +let str = Printf.sprintf +let quote s = str "`%s'" s + +module Err = struct + let alts = function + | [ a; b ] -> str "either %s or %s" a b + | alts -> str "one of: %s" (String.concat ", " alts) + + let invalid kind s exp = str "invalid %s %s, %s" kind (quote s) exp + let invalid_val = invalid "value" +end + +let bool = + ( (fun s -> + try Ok (bool_of_string s) + with Invalid_argument _ -> + Error (`Msg (Err.invalid_val s (Err.alts [ "true"; "false" ])))), + Fmt.bool ) + +let parse_with t_of_str exp s = + try Ok (t_of_str s) with Failure _ -> Error (`Msg (Err.invalid_val s exp)) + +let int = (parse_with int_of_string "expected an integer", Fmt.int) +let string = ((fun s -> Ok s), Fmt.string) + +let some (parse, print) = + let none = "" in + ( (fun s -> match parse s with Ok v -> Ok (Some v) | Error _ as e -> e), + fun ppf v -> + match v with None -> Fmt.string ppf none | Some v -> print ppf v ) + +let uri = + let parse s = Ok (Uri.of_string s) in + let print pp u = Fmt.string pp (Uri.to_string u) in + (parse, print) + +module Univ = struct + type t = exn + + let create (type s) () = + let module M = struct + exception E of s option + end in + ((fun x -> M.E (Some x)), function M.E x -> x | _ -> None) +end + +type 'a key = { + id : int; + to_univ : 'a -> Univ.t; + of_univ : Univ.t -> 'a option; + name : string; + doc : string option; + docv : string option; + docs : string option; + conv : 'a converter; + default : 'a; +} + +let name t = t.name +let doc t = t.doc +let docv t = t.docv +let docs t = t.docs +let conv t = t.conv +let default t = t.default + +let key ?docs ?docv ?doc name conv default = + let () = + String.iter + (function + | '-' | '_' | 'a' .. 'z' | '0' .. '9' -> () + | _ -> raise @@ Invalid_argument name) + name + in + let to_univ, of_univ = Univ.create () in + let id = Oo.id (object end) in + { id; to_univ; of_univ; name; docs; docv; doc; conv; default } + +module Id = struct + type t = int + + let compare (x : int) (y : int) = compare x y +end + +module M = Map.Make (Id) + +type t = Univ.t M.t + +let empty = M.empty +let singleton k v = M.singleton k.id (k.to_univ v) +let is_empty = M.is_empty +let mem d k = M.mem k.id d +let add d k v = M.add k.id (k.to_univ v) d +let union r s = M.fold M.add r s +let rem d k = M.remove k.id d +let find d k = try k.of_univ (M.find k.id d) with Not_found -> None + +let get d k = + try + match k.of_univ (M.find k.id d) with Some v -> v | None -> raise Not_found + with Not_found -> k.default + +(* ~root *) +let root = + key ~docv:"ROOT" ~doc:"The location of the Git repository root." + ~docs:"COMMON OPTIONS" "root" (some string) None diff --git a/vendors/irmin/irmin/conf.mli b/vendors/irmin/irmin/conf.mli new file mode 100644 index 000000000000..f6ae2763e642 --- /dev/null +++ b/vendors/irmin/irmin/conf.mli @@ -0,0 +1,138 @@ +(* + * Copyright (c) 2017 Daniel C. Bünzli + * Copyright (c) 2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Configuration converters} + + A configuration converter transforms a string value to an OCaml value and + vice-versa. There are a few {{!builtin_converters} built-in converters}. *) + +type 'a parser = string -> ('a, [ `Msg of string ]) result +(** The type for configuration converter parsers. *) + +type 'a printer = 'a Fmt.t +(** The type for configuration converter printers. *) + +type 'a converter = 'a parser * 'a printer +(** The type for configuration converters. *) + +val parser : 'a converter -> 'a parser +(** [parser c] is [c]'s parser. *) + +val printer : 'a converter -> 'a printer +(** [converter c] is [c]'s printer. *) + +(** {1:keys Keys} *) + +type 'a key +(** The type for configuration keys whose lookup value is ['a]. *) + +val key : + ?docs:string -> + ?docv:string -> + ?doc:string -> + string -> + 'a converter -> + 'a -> + 'a key +(** [key ~docs ~docv ~doc name conv default] is a configuration key named [name] + that maps to value [default] by default. [conv] is used to convert key + values provided by end users. + + [docs] is the title of a documentation section under which the key is + documented. [doc] is a short documentation string for the key, this should + be a single sentence or paragraph starting with a capital letter and ending + with a dot. [docv] is a meta-variable for representing the values of the key + (e.g. ["BOOL"] for a boolean). + + @raise Invalid_argument + if the key name is not made of a sequence of ASCII lowercase letter, + digit, dash or underscore. + + {b Warning.} No two keys should share the same [name] as this may lead to + difficulties in the UI. *) + +val name : 'a key -> string +(** The key name. *) + +val conv : 'a key -> 'a converter +(** [tc k] is [k]'s converter. *) + +val default : 'a key -> 'a +(** [default k] is [k]'s default value. *) + +val doc : 'a key -> string option +(** [doc k] is [k]'s documentation string (if any). *) + +val docv : 'a key -> string option +(** [docv k] is [k]'s value documentation meta-variable (if any). *) + +val docs : 'a key -> string option +(** [docs k] is [k]'s documentation section (if any). *) + +val root : string option key +(** Default [--root=ROOT] argument. *) + +(** {1:conf Configurations} *) + +type t +(** The type for configurations. *) + +val empty : t +(** [empty] is the empty configuration. *) + +val singleton : 'a key -> 'a -> t +(** [singleton k v] is the configuration where [k] maps to [v]. *) + +val is_empty : t -> bool +(** [is_empty c] is [true] iff [c] is empty. *) + +val mem : t -> 'a key -> bool +(** [mem c k] is [true] iff [k] has a mapping in [c]. *) + +val add : t -> 'a key -> 'a -> t +(** [add c k v] is [c] with [k] mapping to [v]. *) + +val rem : t -> 'a key -> t +(** [rem c k] is [c] with [k] unbound. *) + +val union : t -> t -> t +(** [union r s] is the union of the configurations [r] and [s]. *) + +val find : t -> 'a key -> 'a option +(** [find c k] is [k]'s mapping in [c], if any. *) + +val get : t -> 'a key -> 'a +(** [get c k] is [k]'s mapping in [c]. + + {b Raises.} [Not_found] if [k] is not bound in [d]. *) + +(** {1:builtin_converters Built-in value converters} *) + +val bool : bool converter +(** [bool] converts values with [bool_of_string]. *) + +val int : int converter +(** [int] converts values with [int_of_string]. *) + +val string : string converter +(** [string] converts values with the identity function. *) + +val uri : Uri.t converter +(** [uri] converts values with {!Uri.of_string}. *) + +val some : 'a converter -> 'a option converter +(** [string] converts values with the identity function. *) diff --git a/vendors/irmin/irmin/contents.ml b/vendors/irmin/irmin/contents.ml new file mode 100644 index 000000000000..8e1826d563b7 --- /dev/null +++ b/vendors/irmin/irmin/contents.ml @@ -0,0 +1,238 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Contents_intf + +let lexeme e x = ignore (Jsonm.encode e (`Lexeme x)) + +let rec encode_json e = function + | `Null -> lexeme e `Null + | `Bool b -> lexeme e (`Bool b) + | `String s -> lexeme e (`String s) + | `Float f -> lexeme e (`Float f) + | `A a -> + lexeme e `As; + List.iter (encode_json e) a; + lexeme e `Ae + | `O o -> + lexeme e `Os; + List.iter + (fun (k, v) -> + lexeme e (`Name k); + encode_json e v) + o; + lexeme e `Oe + +let decode_json d = + let decode d = + match Jsonm.decode d with + | `Lexeme l -> l + | `Error e -> failwith (Fmt.str "%a" Jsonm.pp_error e) + | _ -> failwith "invalid JSON encoding" + in + let rec unwrap v d = + match v with + | `Os -> obj [] d + | `As -> arr [] d + | (`Null | `Bool _ | `String _ | `Float _) as v -> v + | _ -> failwith "invalid JSON value" + and arr vs d = + match decode d with + | `Ae -> `A (List.rev vs) + | v -> + let v = unwrap v d in + arr (v :: vs) d + and obj ms d = + match decode d with + | `Oe -> `O (List.rev ms) + | `Name k -> + let v = unwrap (decode d) d in + obj ((k, v) :: ms) d + | _ -> failwith "invalid JSON object" + in + try Ok (unwrap (decode d) d) with Failure msg -> Error (`Msg msg) + +type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] +[@@deriving irmin] + +module Json_value = struct + type t = json [@@deriving irmin] + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder x; + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with Ok obj -> Ok obj | Error _ as err -> err + + let equal_bool = Type.(unstage (equal bool)) + let equal_float = Type.(unstage (equal float)) + + let rec equal a b = + match (a, b) with + | `Null, `Null -> true + | `Bool a, `Bool b -> equal_bool a b + | `String a, `String b -> String.equal a b + | `Float a, `Float b -> equal_float a b + | `A a, `A b -> ( + try List.for_all2 (fun a' b' -> equal a' b') a b + with Invalid_argument _ -> false) + | `O a, `O b -> ( + let compare_fst (a, _) (b, _) = compare a b in + try + List.for_all2 + (fun (k, v) (k', v') -> k = k' && equal v v') + (List.sort compare_fst a) (List.sort compare_fst b) + with Invalid_argument _ -> false) + | _, _ -> false + + let t = Type.like ~equal ~pp ~of_string t + + let rec merge_object ~old x y = + let open Merge.Infix in + let m = + Merge.(alist Type.string t (fun _key -> option (v t merge_value))) + in + Merge.(f m ~old x y) >>=* fun x -> Merge.ok (`O x) + + and merge_float ~old x y = + let open Merge.Infix in + Merge.(f float ~old x y) >>=* fun f -> Merge.ok (`Float f) + + and merge_string ~old x y = + let open Merge.Infix in + Merge.(f string ~old x y) >>=* fun s -> Merge.ok (`String s) + + and merge_bool ~old x y = + let open Merge.Infix in + Merge.(f bool ~old x y) >>=* fun b -> Merge.ok (`Bool b) + + and merge_array ~old x y = + let open Merge.Infix in + Merge.(f (Merge.idempotent (Type.list t)) ~old x y) >>=* fun x -> + Merge.ok (`A x) + + and merge_value ~old x y = + let open Merge.Infix in + old () >>=* fun old -> + match (old, x, y) with + | Some `Null, _, _ -> merge_value ~old:(fun () -> Merge.ok None) x y + | None, `Null, `Null -> Merge.ok `Null + | Some (`Float old), `Float a, `Float b -> + merge_float ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Float a, `Float b -> merge_float ~old:(fun () -> Merge.ok None) a b + | Some (`String old), `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok (Some old)) a b + | None, `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok None) a b + | Some (`Bool old), `Bool a, `Bool b -> + merge_bool ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Bool a, `Bool b -> merge_bool ~old:(fun () -> Merge.ok None) a b + | Some (`A old), `A a, `A b -> + merge_array ~old:(fun () -> Merge.ok (Some old)) a b + | None, `A a, `A b -> merge_array ~old:(fun () -> Merge.ok None) a b + | Some (`O old), `O a, `O b -> + merge_object ~old:(fun () -> Merge.ok (Some old)) a b + | None, `O a, `O b -> merge_object ~old:(fun () -> Merge.ok None) a b + | _, _, _ -> Merge.conflict "Conflicting JSON datatypes" + + let merge_json = Merge.(v t merge_value) + let merge = Merge.(option merge_json) +end + +module Json = struct + type t = (string * json) list [@@deriving irmin] + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder (`O x); + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with + | Ok (`O obj) -> Ok obj + | Ok _ -> Error (`Msg "Irmin JSON values must be objects") + | Error _ as err -> err + + let equal a b = Json_value.equal (`O a) (`O b) + let t = Type.like ~equal ~pp ~of_string t + + let merge = + Merge.(option (alist Type.string Json_value.t (fun _ -> Json_value.merge))) +end + +module String = struct + type t = string [@@deriving irmin] + + let merge = Merge.idempotent Type.(option string) +end + +module Store (S : sig + include S.CONTENT_ADDRESSABLE_STORE + module Key : Hash.S with type t = key + module Val : S with type t = value +end) = +struct + module Key = Hash.Typed (S.Key) (S.Val) + module Val = S.Val + + type 'a t = 'a S.t + type key = S.key + type value = S.value + + let find = S.find + let add = S.add + let unsafe_add = S.unsafe_add + let mem = S.mem + let clear = S.clear + let read_opt t = function None -> Lwt.return_none | Some k -> find t k + + let add_opt t = function + | None -> Lwt.return_none + | Some v -> add t v >>= Lwt.return_some + + let merge t = + Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t) +end + +module V1 = struct + module String = struct + include String + + let t = Type.(boxed (string_of `Int64)) + + type nonrec t = t [@@deriving irmin ~encode_bin ~decode_bin ~pre_hash] + + let size_of = Type.Size.t t + let t = Type.like t ~bin:(encode_bin, decode_bin, size_of) ~pre_hash + end +end diff --git a/vendors/irmin/irmin/contents.mli b/vendors/irmin/irmin/contents.mli new file mode 100644 index 000000000000..55484004f2ab --- /dev/null +++ b/vendors/irmin/irmin/contents.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Values. *) + +include Contents_intf.Contents +(** @inline *) diff --git a/vendors/irmin/irmin/contents_intf.ml b/vendors/irmin/irmin/contents_intf.ml new file mode 100644 index 000000000000..0037ce34e947 --- /dev/null +++ b/vendors/irmin/irmin/contents_intf.ml @@ -0,0 +1,92 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open S + +module type S = sig + (** {1 Signature for store contents} *) + + type t [@@deriving irmin] + (** The type for user-defined contents. *) + + val merge : t option Merge.t + (** Merge function. Evaluates to [`Conflict msg] if the values cannot be + merged properly. The arguments of the merge function can take [None] to + mean that the key does not exists for either the least-common ancestor or + one of the two merging points. The merge function returns [None] when the + key's value should be deleted. *) +end + +module type STORE = sig + include CONTENT_ADDRESSABLE_STORE + + val merge : [> read_write ] t -> key option Merge.t + (** [merge t] lifts the merge functions defined on contents values to contents + key. The merge function will: {e (i)} read the values associated with the + given keys, {e (ii)} use the merge function defined on values and + {e (iii)} write the resulting values into the store to get the resulting + key. See {!Contents.S.merge}. + + If any of these operations fail, return [`Conflict]. *) + + (** [Key] provides base functions for user-defined contents keys. *) + module Key : Hash.TYPED with type t = key and type value = value + + module Val : S with type t = value + (** [Val] provides base functions for user-defined contents values. *) +end + +module type Contents = sig + module type S = S + + module String : S with type t = string + (** Contents of type [string], with the {{!Irmin.Merge.default} default} 3-way + merge strategy: assume that update operations are idempotent and conflict + iff values are modified concurrently. *) + + type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] + + module Json : S with type t = (string * json) list + (** [Json] contents are associations from strings to [json] values stored as + JSON encoded strings. If the same JSON key has been modified concurrently + with different values then the [merge] function conflicts. *) + + module Json_value : S with type t = json + (** [Json_value] allows any kind of json value to be stored, not only objects. *) + + module V1 : sig + module String : S with type t = string + (** Same as {!String} but use v1 serialisation format. *) + end + + module type STORE = STORE + (** Contents store. *) + + (** [Store] creates a contents store. *) + module Store (C : sig + include S.CONTENT_ADDRESSABLE_STORE + module Key : Hash.S with type t = key + module Val : S with type t = value + end) : + STORE with type 'a t = 'a C.t and type key = C.key and type value = C.value +end diff --git a/vendors/irmin/irmin/diff.ml b/vendors/irmin/irmin/diff.ml new file mode 100644 index 000000000000..792e02e7ece9 --- /dev/null +++ b/vendors/irmin/irmin/diff.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] +[@@deriving irmin] diff --git a/vendors/irmin/irmin/diff.mli b/vendors/irmin/irmin/diff.mli new file mode 100644 index 000000000000..51bfe8899ede --- /dev/null +++ b/vendors/irmin/irmin/diff.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] +[@@deriving irmin] +(** The type for representing differences betwen values. *) diff --git a/vendors/irmin/irmin/dot.ml b/vendors/irmin/irmin/dot.ml new file mode 100644 index 000000000000..ddedaaeb32bf --- /dev/null +++ b/vendors/irmin/irmin/dot.ml @@ -0,0 +1,212 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Printf +open Astring + +let src = Logs.Src.create "irmin.dot" ~doc:"Irmin dot graph output" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t +end + +exception Utf8_failure + +let is_valid_utf8 str = + try + Uutf.String.fold_utf_8 + (fun _ _ -> function `Malformed _ -> raise Utf8_failure | _ -> ()) + () str; + true + with Utf8_failure -> false + +module Make (S : Store.S) = struct + type db = S.t + + module Branch = S.Private.Branch + module Contents = S.Private.Contents + module Node = S.Private.Node + module Commit = S.Private.Commit + module Slice = S.Private.Slice + module Graph = Object_graph.Make (S.Hash) (Branch.Key) + + let fprintf (t : db) ?depth ?(html = false) ?full ~date name = + Log.debug (fun f -> + f "fprintf depth=%s html=%b full=%s" + (match depth with None -> "" | Some d -> string_of_int d) + html + (match full with None -> "" | Some b -> string_of_bool b)); + let* slice = S.Repo.export ?full ?depth (S.repo t) in + let vertex = Hashtbl.create 102 in + let add_vertex v l = Hashtbl.add vertex v l in + let mem_vertex v = Hashtbl.mem vertex v in + let edges = ref [] in + let add_edge v1 l v2 = + if mem_vertex v1 && mem_vertex v2 then edges := (v1, l, v2) :: !edges + in + let string_of_key t k = + let s = Type.to_string t k in + if String.length s <= 8 then s else String.with_range s ~len:8 + in + let string_of_contents s = + let s = + if String.length s <= 10 then s else String.with_range s ~len:10 + in + let s = if is_valid_utf8 s then s else "" in + s + in + let label_of_node k _ = + let s = + (if html then + sprintf "
%s
" + else fun x -> x) + (string_of_key Node.Key.t k) + in + `Label s + in + let label_of_step l = + let l = Type.to_string S.Key.step_t l in + let s = + (if html then sprintf "
%s
" else fun x -> x) + (string_of_contents l) + in + `Label s + in + let label_of_commit k c = + let k = string_of_key Commit.Key.t k in + let o = Commit.Val.info c in + let s = + if html then + sprintf + "
\n\ + \
%s
\n\ + \
%s
\n\ + \
%s
\n\ + \ 
%s
\n\ + \
 
\n\ +
" + k (Info.author o) + (date (Info.date o)) + (String.Ascii.escape (Info.message o)) + else sprintf "%s" k + in + `Label s + in + let label_of_contents k v = + let k = string_of_key Contents.Key.t k in + let s = + if html then + sprintf + "
\n\ + \
%s
\n\ + \
 
\n\ +
" + k + else + let v = string_of_contents (Type.to_string Contents.Val.t v) in + sprintf "%s (%s)" k (String.Ascii.escape_string v) + in + `Label s + in + let label_of_tag t = + let s = + if html then + sprintf "
%s
" (Type.to_string Branch.Key.t t) + else Type.to_string Branch.Key.t t + in + `Label s + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + let* () = + Slice.iter slice (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit) + in + List.iter + (fun (k, c) -> + add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ]) + !contents; + List.iter + (fun (k, t) -> + add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ]) + !nodes; + List.iter + (fun (k, r) -> + add_vertex (`Commit k) + [ `Shape `Box; `Style `Bold; label_of_commit k r ]) + !commits; + List.iter + (fun (k, t) -> + List.iter + (fun (l, v) -> + match v with + | `Contents (v, _meta) -> + add_edge (`Node k) + [ `Style `Dotted; label_of_step l ] + (`Contents v) + | `Node n -> + add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n)) + (Node.Val.list t)) + !nodes; + List.iter + (fun (k, r) -> + List.iter + (fun c -> add_edge (`Commit k) [ `Style `Bold ] (`Commit c)) + (Commit.Val.parents r); + add_edge (`Commit k) [ `Style `Dashed ] (`Node (Commit.Val.node r))) + !commits; + let branch_t = S.Private.Repo.branch_t (S.repo t) in + let* bs = Branch.list branch_t in + let+ () = + Lwt_list.iter_s + (fun r -> + Branch.find branch_t r >|= function + | None -> () + | Some k -> + add_vertex (`Branch r) + [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; + add_edge (`Branch r) [ `Style `Bold ] (`Commit k)) + bs + in + let vertex = Hashtbl.fold (fun k v acc -> (k, v) :: acc) vertex [] in + fun ppf -> Graph.output ppf vertex !edges name + + let output_buffer t ?html ?depth ?full ~date buf = + let+ fprintf = fprintf t ?depth ?full ?html ~date "graph" in + let ppf = Format.formatter_of_buffer buf in + fprintf ppf +end diff --git a/vendors/irmin/irmin/dot.mli b/vendors/irmin/irmin/dot.mli new file mode 100644 index 000000000000..42300cc6ce83 --- /dev/null +++ b/vendors/irmin/irmin/dot.mli @@ -0,0 +1,45 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store dumps. *) + +module type S = sig + (** {1 Dot Export} *) + + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t + (** [output_buffer t ?html ?depth ?full buf] outputs the Graphviz + representation of [t] in the buffer [buf]. + + [html] (default is false) enables HTML labels. + + [depth] is used to limit the depth of the commit history. [None] here + means no limitation. + + If [full] is set (default is not) the full graph, including the commits, + nodes and contents, is exported, otherwise it is the commit history graph + only. *) +end + +module Make (S : Store.S) : S with type db = S.t diff --git a/vendors/irmin/irmin/dune b/vendors/irmin/irmin/dune new file mode 100644 index 000000000000..ed5f49a0018b --- /dev/null +++ b/vendors/irmin/irmin/dune @@ -0,0 +1,7 @@ +(library + (name irmin) + (public_name irmin) + (libraries astring bheap digestif fmt jsonm logs lwt ocamlgraph uri uutf + repr) + (preprocess + (pps ppx_irmin -- --lib "Type"))) diff --git a/vendors/irmin/irmin/export_for_backends.ml b/vendors/irmin/irmin/export_for_backends.ml new file mode 100644 index 000000000000..cba4c4ba7cb4 --- /dev/null +++ b/vendors/irmin/irmin/export_for_backends.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Store_properties = S.Store_properties +include Import diff --git a/vendors/irmin/irmin/hash.ml b/vendors/irmin/irmin/hash.ml new file mode 100644 index 000000000000..b4355f384542 --- /dev/null +++ b/vendors/irmin/irmin/hash.ml @@ -0,0 +1,99 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Hash_intf + +module Make (H : Digestif.S) = struct + type t = H.t + + external get_64 : string -> int -> int64 = "%caml_string_get64u" + external swap64 : int64 -> int64 = "%bswap_int64" + + let get_64_little_endian str idx = + if Sys.big_endian then swap64 (get_64 str idx) else get_64 str idx + + let short_hash c = Int64.to_int (get_64_little_endian (H.to_raw_string c) 0) + let hash_size = H.digest_size + + let of_hex s = + match H.consistent_of_hex s with + | x -> Ok x + | exception Invalid_argument e -> Error (`Msg e) + + let pp_hex ppf x = Fmt.string ppf (H.to_hex x) + + let t = + Type.map ~pp:pp_hex ~of_string:of_hex + Type.(string_of (`Fixed hash_size)) + H.of_raw_string H.to_raw_string + + let hash s = H.digesti_string s +end + +module Make_BLAKE2B (D : sig + val digest_size : int +end) = + Make (Digestif.Make_BLAKE2B (D)) + +module Make_BLAKE2S (D : sig + val digest_size : int +end) = + Make (Digestif.Make_BLAKE2S (D)) + +module SHA1 = Make (Digestif.SHA1) +module RMD160 = Make (Digestif.RMD160) +module SHA224 = Make (Digestif.SHA224) +module SHA256 = Make (Digestif.SHA256) +module SHA384 = Make (Digestif.SHA384) +module SHA512 = Make (Digestif.SHA512) +module BLAKE2B = Make (Digestif.BLAKE2B) +module BLAKE2S = Make (Digestif.BLAKE2S) + +module Typed (K : S) (V : Type.S) = struct + include K + + type value = V.t + + let pre_hash = Type.unstage (Type.pre_hash V.t) + let hash v = K.hash (pre_hash v) +end + +module V1 (K : S) : S with type t = K.t = struct + type t = K.t + + let hash = K.hash + let short_hash = K.short_hash + let hash_size = K.hash_size + let h = Type.string_of `Int64 + let to_bin_key = Type.unstage (Type.to_bin_string K.t) + let of_bin_key = Type.unstage (Type.of_bin_string K.t) + let size_of = Type.Size.using to_bin_key (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.unstage (Type.encode_bin h) in + fun e -> encode_bin (to_bin_key e) + + let decode_bin = + let decode_bin = Type.unstage (Type.decode_bin h) in + fun buf off -> + let n, v = decode_bin buf off in + ( n, + match of_bin_key v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e ) + + let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) +end diff --git a/vendors/irmin/irmin/hash.mli b/vendors/irmin/irmin/hash.mli new file mode 100644 index 000000000000..ef79463395e0 --- /dev/null +++ b/vendors/irmin/irmin/hash.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Hash_intf.Hash diff --git a/vendors/irmin/irmin/hash_intf.ml b/vendors/irmin/irmin/hash_intf.ml new file mode 100644 index 000000000000..7835851f43a3 --- /dev/null +++ b/vendors/irmin/irmin/hash_intf.ml @@ -0,0 +1,93 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** Signature for digest hashes, inspired by Digestif. *) + + type t + (** The type for digest hashes. *) + + val hash : ((string -> unit) -> unit) -> t + (** Compute a deterministic store key from a sequence of strings. *) + + val short_hash : t -> int + (** [short_hash h] is a small hash of [h], to be used for instance as the + `hash` function of an OCaml [Hashtbl]. *) + + val hash_size : int + (** [hash_size] is the size of hash results, in bytes. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) +end + +module type TYPED = sig + type t + type value + + val hash : value -> t + (** Compute a deterministic store key from a string. *) + + val short_hash : t -> int + (** [short_hash h] is a small hash of [h], to be used for instance as the + `hash` function of an OCaml [Hashtbl]. *) + + val hash_size : int + (** [hash_size] is the size of hash results, in bytes. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) +end + +module type Hash = sig + module type S = S + (** Signature for hash values. *) + + module type TYPED = TYPED + (** Signature for typed hashes, where [hash] directly takes a value as + argument and incremental hashing is not possible. *) + + (** Digestif hashes. *) + module Make (H : Digestif.S) : S with type t = H.t + + module Make_BLAKE2B (D : sig + val digest_size : int + end) : S + + module Make_BLAKE2S (D : sig + val digest_size : int + end) : S + + module SHA1 : S + module RMD160 : S + module SHA224 : S + module SHA256 : S + module SHA384 : S + module SHA512 : S + module BLAKE2B : S + module BLAKE2S : S + + (** v1 serialisation *) + module V1 (H : S) : S with type t = H.t + + (** Typed hashes. *) + module Typed (K : S) (V : Type.S) : + TYPED with type t = K.t and type value = V.t +end diff --git a/vendors/irmin/irmin/import.ml b/vendors/irmin/irmin/import.ml new file mode 100644 index 000000000000..37f76cd8b9ee --- /dev/null +++ b/vendors/irmin/irmin/import.ml @@ -0,0 +1,123 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Extensions to the default namespace, opened throughout the Irmin codebase. *) + +type read = Perms.read +type write = Perms.write +type read_write = Perms.read_write + +(** {2 Lwt syntax} *) + +let ( >>= ) = Lwt.Infix.( >>= ) +let ( >|= ) = Lwt.Infix.( >|= ) +let ( let* ) = ( >>= ) +let ( let+ ) = ( >|= ) + +(** {2 Dependency extensions} *) + +module Option = struct + include Option + (** @closed *) + + let of_result = function Ok x -> Some x | Error _ -> None +end + +module List = struct + include List + (** @closed *) + + let rec is_longer_than : type a. int -> a list -> bool = + fun len l -> + if len < 0 then true + else match l with [] -> false | _ :: tl -> is_longer_than (len - 1) tl + + let map f l = + let rec aux acc = function + | [] -> acc [] + | h :: t -> (aux [@tailcall]) (fun t' -> acc (f h :: t')) t + in + aux (fun x -> x) l + + let concat l = + let rec aux acc curr l = + match (curr, l) with + | [], [] -> List.rev acc + | [], [ l ] -> List.rev_append acc l + | [], h :: t -> (aux [@tailcall]) acc h t + | h :: t, l -> (aux [@tailcall]) (h :: acc) t l + in + aux [] [] l + + let concat_map f l = + let rec aux f acc = function + | [] -> rev acc + | x :: l -> + let xs = f x in + aux f (rev_append xs acc) l + in + aux f [] l +end + +module Seq = struct + include Seq + (** @closed *) + + let rec drop : type a. int -> a t -> a t = + fun n l () -> + match l () with + | l' when n = 0 -> l' + | Nil -> Nil + | Cons (_, l') -> drop (n - 1) l' () + + let exists : type a. (a -> bool) -> a Seq.t -> bool = + fun f s -> + let rec aux s = + match s () with Seq.Nil -> false | Seq.Cons (v, s) -> f v || aux s + in + aux s + + let rec take : type a. int -> a t -> a t = + fun n l () -> + if n = 0 then Nil + else match l () with Nil -> Nil | Cons (x, l') -> Cons (x, take (n - 1) l') + + let for_all : type a. (a -> bool) -> a Seq.t -> bool = + fun f s -> + let rec aux s = + match s () with Seq.Nil -> true | Seq.Cons (v, s) -> f v && aux s + in + aux s + + (* For compatibility with versions older than ocaml.4.11.0 *) + let rec append seq1 seq2 () = + match seq1 () with + | Nil -> seq2 () + | Cons (x, next) -> Cons (x, append next seq2) +end + +let shuffle state arr = + let rec aux n = + if n > 1 then ( + let k = Random.State.int state (n + 1) in + let temp = arr.(n) in + arr.(n) <- arr.(k); + arr.(k) <- temp; + aux (n - 1)) + in + let len = Array.length arr in + aux (len - 1); + () diff --git a/vendors/irmin/irmin/info.ml b/vendors/irmin/irmin/info.ml new file mode 100644 index 000000000000..14ddf2800408 --- /dev/null +++ b/vendors/irmin/irmin/info.ml @@ -0,0 +1,30 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = { date : int64; author : string; message : string } [@@deriving irmin] +type f = unit -> t + +let create ~date ~author message = { date; message; author } +let empty = { date = 0L; author = ""; message = "" } + +let v ~date ~author message = + if date = 0L && author = "" && message = "" then empty + else create ~date ~author message + +let date t = t.date +let author t = t.author +let message t = t.message +let none () = empty diff --git a/vendors/irmin/irmin/info.mli b/vendors/irmin/irmin/info.mli new file mode 100644 index 000000000000..ba3fbca57ab5 --- /dev/null +++ b/vendors/irmin/irmin/info.mli @@ -0,0 +1,59 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Commit Info} *) + +type t +(** The type for commit info. *) + +val v : date:int64 -> author:string -> string -> t +(** Create a new commit info. *) + +val date : t -> int64 +(** [date t] is [t]'s commit date. + + The date provided by the user when calling the {{!Info.v} create} function. + Rounding [Unix.gettimeofday ()] (when available) is a good value for such + date. On more esoteric platforms, any monotonic counter is a fine value as + well. On the Git backend, the date is translated into the commit {e Date} + field and is expected to be the number of POSIX seconds (thus not counting + leap seconds) since the Epoch. *) + +val author : t -> string +(** [author t] is [t]'s commit author. + + The author identifies the entity (human, unikernel, process, thread, etc) + performing an operation. For the Git backend, this will be directly + translated into the {e Author} field. *) + +val message : t -> string +(** [message t] is [t]'s commit message. *) + +val empty : t +(** The empty commit info. *) + +(** {1 Info Functions} *) + +type f = unit -> t +(** Alias for functions which can build commit info. *) + +val none : f +(** The empty info function. [none ()] is [empty] *) + +(** {1 Value Types} *) + +val t : t Type.t +(** [t] is the value type for {!t}. *) diff --git a/vendors/irmin/irmin/irmin.ml b/vendors/irmin/irmin/irmin.ml new file mode 100644 index 000000000000..61301d410da5 --- /dev/null +++ b/vendors/irmin/irmin/irmin.ml @@ -0,0 +1,424 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Type = Repr +module Diff = Diff +module Content_addressable = Store.Content_addressable +module Contents = Contents +module Merge = Merge +module Branch = Branch +module Proof = Proof +module Info = Info +module Dot = Dot.Make +module Hash = Hash +module Path = Path +module Perms = Perms + +exception Closed + +module CA_check_closed (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) : + S.CONTENT_ADDRESSABLE_STORE_MAKER = +functor + (K : Hash.S) + (V : Type.S) + -> + struct + module S = CA (K) (V) + + type 'a t = { closed : bool ref; t : 'a S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let v conf = + let+ t = S.v conf in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let clear t = + check_not_closed t; + S.clear t.t + end + +module AW_check_closed (AW : S.ATOMIC_WRITE_STORE_MAKER) : + S.ATOMIC_WRITE_STORE_MAKER = +functor + (K : Type.S) + (V : Type.S) + -> + struct + module S = AW (K) (V) + + type t = { closed : bool ref; t : S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let set t k v = + check_not_closed t; + S.set t.t k v + + let test_and_set t k ~test ~set = + check_not_closed t; + S.test_and_set t.t k ~test ~set + + let remove t k = + check_not_closed t; + S.remove t.t k + + let list t = + check_not_closed t; + S.list t.t + + type watch = S.watch + + let watch t ?init f = + check_not_closed t; + S.watch t.t ?init f + + let watch_key t k ?init f = + check_not_closed t; + S.watch_key t.t k ?init f + + let unwatch t w = + check_not_closed t; + S.unwatch t.t w + + let v conf = + let+ t = S.v conf in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let clear t = + check_not_closed t; + S.clear t.t + end + +module Maker_ext + (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : S.ATOMIC_WRITE_STORE_MAKER) + (N : Node.Maker) + (CT : Commit.Maker) = +struct + type endpoint = unit + + module Make + (M : S.METADATA) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) = + struct + module CA = CA_check_closed (CA) + module AW = AW_check_closed (AW) + + module X = struct + module Hash = H + + module Contents = struct + module CA = struct + module Key = Hash + module Val = C + include CA (Key) (Val) + end + + include Contents.Store (CA) + end + + module Node = struct + module CA = struct + module Key = Hash + module Val = N (H) (P) (M) + include CA (Key) (Val) + end + + include Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module CA = struct + module Key = Hash + module Val = CT (H) + include CA (Key) (Val) + end + + include Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + include AW (Key) (Val) + end + + module Slice = Slice.Make (Contents) (Node) (Commit) + module Sync = Sync.None (H) (B) + + module Repo = struct + type t = { + config : Conf.t; + contents : read Contents.t; + nodes : read Node.t; + commits : read Commit.t; + branch : Branch.t; + } + + let contents_t t = t.contents + let node_t t = t.nodes + let commit_t t = t.commits + let branch_t t = t.branch + + let batch t f = + Contents.CA.batch t.contents @@ fun c -> + Node.CA.batch (snd t.nodes) @@ fun n -> + Commit.CA.batch (snd t.commits) @@ fun ct -> + let contents_t = c in + let node_t = (contents_t, n) in + let commit_t = (node_t, ct) in + f contents_t node_t commit_t + + let v config = + let* contents = Contents.CA.v config in + let* nodes = Node.CA.v config in + let* commits = Commit.CA.v config in + let nodes = (contents, nodes) in + let commits = (nodes, commits) in + let+ branch = Branch.v config in + { contents; nodes; commits; branch; config } + + let close t = + Contents.CA.close t.contents >>= fun () -> + Node.CA.close (snd t.nodes) >>= fun () -> + Commit.CA.close (snd t.commits) >>= fun () -> Branch.close t.branch + end + end + + include Store.Make (X) + end +end + +module Make_ext + (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : S.ATOMIC_WRITE_STORE_MAKER) + (M : S.METADATA) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) + (N : Node.S + with type metadata = M.t + and type hash = H.t + and type step = P.step) + (CT : Commit.S with type hash = H.t) = +struct + module CA = CA_check_closed (CA) + module AW = AW_check_closed (AW) + + module X = struct + module Hash = H + + module Contents = struct + module CA = struct + module Key = Hash + module Val = C + include CA (Key) (Val) + end + + include Contents.Store (CA) + end + + module Node = struct + module CA = struct + module Key = Hash + module Val = N + include CA (Key) (Val) + end + + include Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module CA = struct + module Key = Hash + module Val = CT + include CA (Key) (Val) + end + + include Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + include AW (Key) (Val) + end + + module Slice = Slice.Make (Contents) (Node) (Commit) + module Sync = Sync.None (H) (B) + + module Repo = struct + type t = { + config : Conf.t; + contents : read Contents.t; + nodes : read Node.t; + commits : read Commit.t; + branch : Branch.t; + } + + let contents_t t = t.contents + let node_t t = t.nodes + let commit_t t = t.commits + let branch_t t = t.branch + + let batch t f = + Contents.CA.batch t.contents @@ fun c -> + Node.CA.batch (snd t.nodes) @@ fun n -> + Commit.CA.batch (snd t.commits) @@ fun ct -> + let contents_t = c in + let node_t = (contents_t, n) in + let commit_t = (node_t, ct) in + f contents_t node_t commit_t + + let v config = + let* contents = Contents.CA.v config in + let* nodes = Node.CA.v config in + let* commits = Commit.CA.v config in + let nodes = (contents, nodes) in + let commits = (nodes, commits) in + let+ branch = Branch.v config in + { contents; nodes; commits; branch; config } + + let close t = + Contents.CA.close t.contents >>= fun () -> + Node.CA.close (snd t.nodes) >>= fun () -> + Commit.CA.close (snd t.commits) >>= fun () -> Branch.close t.branch + end + end + + include Store.Make (X) +end + +module Make + (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : S.ATOMIC_WRITE_STORE_MAKER) + (M : S.METADATA) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) = +struct + module N = Node.Make (H) (P) (M) + module CT = Commit.Make (H) + include Make_ext (CA) (AW) (M) (C) (P) (B) (H) (N) (CT) +end + +module Of_private = Store.Make + +module type CONTENT_ADDRESSABLE_STORE = S.CONTENT_ADDRESSABLE_STORE +module type APPEND_ONLY_STORE = S.APPEND_ONLY_STORE +module type ATOMIC_WRITE_STORE = S.ATOMIC_WRITE_STORE +module type TREE = Tree.S +module type S = Store.S + +type config = Conf.t +type 'a diff = 'a Diff.t + +module type CONTENT_ADDRESSABLE_STORE_MAKER = S.CONTENT_ADDRESSABLE_STORE_MAKER +module type APPEND_ONLY_STORE_MAKER = S.APPEND_ONLY_STORE_MAKER +module type ATOMIC_WRITE_STORE_MAKER = S.ATOMIC_WRITE_STORE_MAKER +module type S_MAKER = Store.MAKER + +module type KV = + S with type key = string list and type step = string and type branch = string + +module type KV_MAKER = functor (C : Contents.S) -> KV with type contents = C.t + +module Private = struct + module Conf = Conf + module Node = Node + module Commit = Commit + module Slice = Slice + module Sync = Sync + module Sigs = S + + module type S = Private.S + + module Watch = Watch + module Lock = Lock + module Lru = Lru +end + +let version = Version.current + +module type SYNC = Sync_ext.SYNC_STORE + +module Sync = Sync_ext.Make + +type remote = S.remote = .. + +let remote_store (type t) (module M : S with type t = t) (t : t) = + let module X : Store.S with type t = t = M in + Sync_ext.remote_store (module X) t + +module Metadata = struct + module type S = S.METADATA + + module None = Node.No_metadata +end + +module Json_tree = Store.Json_tree +module Export_for_backends = Export_for_backends diff --git a/vendors/irmin/irmin/irmin.mli b/vendors/irmin/irmin/irmin.mli new file mode 100644 index 000000000000..6913935e6e3c --- /dev/null +++ b/vendors/irmin/irmin/irmin.mli @@ -0,0 +1,593 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Irmin public API. + + [Irmin] is a library to design and use persistent stores with built-in + snapshot, branching and reverting mechanisms. Irmin uses concepts similar to + {{:http://git-scm.com/} Git} but it exposes them as a high level library + instead of a complex command-line frontend. It features a {e bidirectional} + Git backend, where an application can read and persist its state using the + Git format, fully-compatible with the usual Git tools and workflows. + + Irmin is designed to use a large variety of backends. It is written in pure + OCaml and does not depend on external C stubs; it is thus very portable and + aims to run everywhere, from Linux to browser and MirageOS unikernels. + + Consult the {!basics} and {!examples} of use for a quick start. See also the + {{!Irmin_unix} documentation} for the unix backends. + + {e Release %%VERSION%% - %%HOMEPAGE%%} *) + +val version : string +(** The version of the library. *) + +(** {1 Preliminaries} *) + +module Type = Repr +(** Dynamic types for Irmin values. *) + +module Info = Info +(** Commit info are used to keep track of the origin of write operations in the + stores. [Info] models the metadata associated with commit objects in Git. *) + +module Merge = Merge +(** [Merge] provides functions to build custom 3-way merge operators for various + user-defined contents. *) + +module Diff = Diff +(** Differences between values. *) + +type 'a diff = 'a Diff.t +(** The type for representing differences betwen values. *) + +module Perms = Perms + +(** {1 Low-level Stores} *) + +(** An Irmin store is automatically built from a number of lower-level stores, + each implementing fewer operations, such as {{!CONTENT_ADDRESSABLE_STORE} + content-addressable} and {{!ATOMIC_WRITE_STORE} atomic-write} stores. These + low-level stores are provided by various backends. *) + +(** Content-addressable backend store. *) +module type CONTENT_ADDRESSABLE_STORE = sig + include S.CONTENT_ADDRESSABLE_STORE + (** @inline *) +end + +(** Append-only backend store. *) +module type APPEND_ONLY_STORE = sig + include S.APPEND_ONLY_STORE + (** @inline *) +end + +(** Atomic-write stores. *) +module type ATOMIC_WRITE_STORE = sig + include S.ATOMIC_WRITE_STORE + (** @inline *) +end + +(** {1 User-Defined Contents} *) + +module Path = Path +(** Store paths. + + An Irmin {{!Irmin.S} store} binds {{!Path.S.t} paths} to user-defined + {{!Contents.S} contents}. Paths are composed by basic elements, that we call + {{!Path.S.step} steps}. The following [Path] module provides functions to + manipulate steps and paths. *) + +module Hash = Hash +(** Hashing functions. + + [Hash] provides user-defined hash functions to digest serialized contents. + Some {{!backend} backends} might be parameterized by such hash functions, + others might work with a fixed one (for instance, the Git format uses only + {{!Hash.SHA1} SHA1}). + + A {{!Hash.SHA1} SHA1} implementation is available to pass to the backends. *) + +(** [Metadata] defines metadata that is attached to contents but stored in + nodes. The Git backend uses this to indicate the type of file (normal, + executable or symlink). *) +module Metadata : sig + module type S = sig + include S.METADATA + (** @inline *) + end + + module None : S with type t = unit + (** A metadata definition for systems that don't use metadata. *) +end + +module Contents = Contents +(** [Contents] specifies how user-defined contents need to be {e serializable} + and {e mergeable}. + + The user needs to provide: + + - a type [t] to be used as store contents. + - a value type for [t] (built using the {{!Irmin.Type} Irmin.Type} + combinators). + - a 3-way [merge] function, to handle conflicts between multiple versions of + the same contents. + + Default implementations for {{!Contents.String} idempotent string} and + {{!Contents.Json} JSON} contents are provided. *) + +module Branch = Branch +module Proof = Proof + +type remote = S.remote = .. +(** The type for remote stores. *) + +type config = S.config +(** The type for backend-specific configuration values. + + Every backend has different configuration options, which are kept abstract + to the user. *) + +(** [Private] defines functions only useful for creating new backends. If you + are just using the library (and not developing a new backend), you should + not use this module. *) +module Private : sig + module Conf : module type of Conf + (** Backend configuration. + + A backend configuration is a set of {{!keys} keys} mapping to typed + values. Backends define their own keys. *) + + module Watch = Watch + module Lock = Lock + module Lru = Lru + module Node = Node + module Commit = Commit + module Slice = Slice + module Sync = Sync + module Sigs = S + + module type S = Private.S + (** The complete collection of private implementations. *) +end + +(** {1 High-level Stores} + + An Irmin store is a branch-consistent store where keys are lists of steps. + + An example is a Git repository where keys are filenames, {e i.e.} lists of + ['/']-separated strings. More complex examples are structured values, where + steps might contain first-class field accessors and array offsets. + + Irmin provides the following features: + + - Support for fast clones, branches and merges, in a fashion very similar to + Git. + - Efficient staging areas for fast, transient, in-memory operations. + - Fast {{!Sync} synchronization} primitives between remote stores, using + native backend protocols (as the Git protocol) when available. *) + +exception Closed +(** The exception raised when any operation is attempted on a closed store, + except for {!S.close}, which is idempotent. *) + +(** Irmin stores. *) +module type S = sig + include Store.S + (** @inline *) +end + +module Json_tree : Store.JSON_TREE + +(** [S_MAKER] is the signature exposed by any backend providing {!S} + implementations. [M] is the implementation of user-defined metadata, [C] is + the one for user-defined contents, [B] is the implementation for branches + and [H] is the implementation for object (blobs, trees, commits) hashes. It + does not use any native synchronization primitives. *) +module type S_MAKER = functor + (M : Metadata.S) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) + -> + S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + and type Private.Sync.endpoint = unit + +(** [KV] is similar to {!S} but chooses sensible implementations for path and + branch. *) +module type KV = + S with type key = string list and type step = string and type branch = string + +(** [KV_MAKER] is like {!S_MAKER} but where everything except the contents is + replaced by sensible default implementations. *) +module type KV_MAKER = functor (C : Contents.S) -> KV with type contents = C.t + +(** {2 Synchronization} *) + +val remote_store : (module S with type t = 'a) -> 'a -> remote +(** [remote_store t] is the remote corresponding to the local store [t]. + Synchronization is done by importing and exporting store {{!BC.slice} + slices}, so this is usually much slower than native synchronization using + {!Store.remote} but it works for all backends. *) + +(** [SYNC] provides functions to synchronize an Irmin store with local and + remote Irmin stores. *) +module type SYNC = sig + include Sync_ext.SYNC_STORE + (** @inline *) +end + +(** The default [Sync] implementation. *) +module Sync (S : S) : SYNC with type db = S.t and type commit = S.commit + +(** {1:examples Examples} + + These examples are in the [examples] directory of the distribution. + + {3 Syncing with a remote} + + A simple synchronization example, using the {{!Irmin_unix.Git} Git} backend + and the {!Sync} helpers. The code clones a fresh repository if the + repository does not exist locally, otherwise it performs a fetch: in this + case, only the missing contents are downloaded. + + {[ + open Lwt.Infix + module S = Irmin_unix.Git.FS.KV (Irmin.Contents.String) + module Sync = Irmin.Sync (S) + + let config = Irmin_git.config "/tmp/test" + + let upstream = + if Array.length Sys.argv = 2 then + Uri.of_string (Store.remote Sys.argv.(1)) + else ( + Printf.eprintf "Usage: sync [uri]\n%!"; + exit 1) + + let test () = + S.Repo.v config >>= S.master >>= fun t -> + Sync.pull_exn t upstream `Set >>= fun () -> + S.get t [ "README.md" ] >|= fun r -> Printf.printf "%s\n%!" r + + let () = Lwt_main.run (test ()) + ]} + + {3 Mergeable logs} + + The complete code for the following can be found in + [examples/custom_merge.ml]. + + We will demonstrate the use of custom merge operators by defining mergeable + debug log files. We first define a log entry as a pair of a timestamp and a + message, using the combinator exposed by {!Irmin.Type}: + + {[ + open Lwt.Infix + open Astring + + let time = ref 0L + let failure fmt = Fmt.kstr failwith fmt + + (* A log entry *) + module Entry : sig + include Irmin.Type.S + + val v : string -> t + val timestamp : t -> int64 + end = struct + type t = { timestamp : int64; message : string } [@@deriving irmin] + + let compare x y = Int64.compare x.timestamp y.timestamp + + let v message = + time := Int64.add 1L !time; + { timestamp = !time; message } + + let timestamp t = t.timestamp + + let pp ppf { timestamp; message } = + Fmt.pf ppf "%04Ld: %s" timestamp message + + let of_string str = + match String.cut ~sep:": " str with + | None -> Error (`Msg ("invalid entry: " ^ str)) + | Some (x, message) -> ( + try Ok { timestamp = Int64.of_string x; message } + with Failure e -> Error (`Msg e)) + + let t = Irmin.Type.like ~pp ~of_string ~compare t + end + ]} + + A log file is a list of entries (one per line), ordered by decreasing order + of timestamps. The 3-way [merge] operator for log files concatenates and + sorts the new entries and prepend them to the common ancestor's ones. + + {[ + (* A log file *) + module Log : sig + include Irmin.Contents.S + + val add : t -> Entry.t -> t + val empty : t + end = struct + type t = Entry.t list [@@deriving irmin] + + let empty = [] + let pp_entry = Irmin.Type.pp Entry.t + let lines ppf l = List.iter (Fmt.pf ppf "%a\n" pp_entry) (List.rev l) + + let of_string str = + let lines = String.cuts ~empty:false ~sep:"\n" str in + try + List.fold_left + (fun acc l -> + match Irmin.Type.of_string Entry.t l with + | Ok x -> x :: acc + | Error (`Msg e) -> failwith e) + [] lines + |> fun l -> Ok l + with Failure e -> Error (`Msg e) + + let t = Irmin.Type.like ~pp:lines ~of_string t + let timestamp = function [] -> 0L | e :: _ -> Entry.timestamp e + + let newer_than timestamp file = + let rec aux acc = function + | [] -> List.rev acc + | h :: _ when Entry.timestamp h <= timestamp -> List.rev acc + | h :: t -> aux (h :: acc) t + in + aux [] file + + let merge ~old t1 t2 = + let open Irmin.Merge.Infix in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let ts = timestamp old in + let t1 = newer_than ts t1 in + let t2 = newer_than ts t2 in + let t3 = + List.sort (Irmin.Type.compare Entry.t) (List.rev_append t1 t2) + in + Irmin.Merge.ok (List.rev_append t3 old) + + let merge = Irmin.Merge.(option (v t merge)) + let add t e = e :: t + end + ]} + + {b Note:} The serialisation primitives used in that example are not very + efficient in this case as they parse the file every time. For real usage, + you would write buffered versions of [Log.pp] and [Log.of_string]. + + To persist the log file on disk, we need to choose a backend. We show here + how to use the on-disk [Git] backend on Unix. + + {[ + (* Build an Irmin store containing log files. *) + module Store = Irmin_unix.Git.FS.KV (Log) + + (* Set-up the local configuration of the Git repository. *) + let config = Irmin_git.config ~bare:true Config.root + + (* Convenient alias for the info function for commit messages *) + let info = Irmin_unix.info + ]} + + We can now define a toy example to use our mergeable log files. + + {[ + let log_file = [ "local"; "debug" ] + + let all_logs t = + Store.find t log_file >|= function None -> Log.empty | Some l -> l + + (** Persist a new entry in the log. Pretty inefficient as it reads/writes + the whole file every time. *) + let log t fmt = + Printf.ksprintf + (fun message -> + all_logs t >>= fun logs -> + let logs = Log.add logs (Entry.v message) in + Store.set_exn t ~info:(info "Adding a new entry") log_file logs) + fmt + + let print_logs name t = + all_logs t >|= fun logs -> + Fmt.pr "-----------\n%s:\n-----------\n%a%!" name (Irmin.Type.pp Log.t) + logs + + let main () = + Config.init (); + Store.Repo.v config >>= fun repo -> + Store.master repo >>= fun t -> + (* populate the log with some random messages *) + Lwt_list.iter_s + (fun msg -> log t "This is my %s " msg) + [ "first"; "second"; "third" ] + >>= fun () -> + Printf.printf "%s\n\n" what; + print_logs "lca" t >>= fun () -> + Store.clone ~src:t ~dst:"test" >>= fun x -> + log x "Adding new stuff to x" >>= fun () -> + log x "Adding more stuff to x" >>= fun () -> + log x "More. Stuff. To x." >>= fun () -> + print_logs "branch 1" x >>= fun () -> + log t "I can add stuff on t also" >>= fun () -> + log t "Yes. On t!" >>= fun () -> + print_logs "branch 2" t >>= fun () -> + Store.merge_into ~info:(info "Merging x into t") x ~into:t >>= function + | Ok () -> print_logs "merge" t + | Error _ -> failwith "conflict!" + + let () = Lwt_main.run (main ()) + ]} *) + +(** {1 Helpers} *) + +(** [Dot] provides functions to export a store to the Graphviz `dot` format. *) +module Dot (S : S) : Dot.S with type db = S.t + +(** {1:backend Backends} + + API to create new Irmin backends. A backend is an implementation exposing + either a concrete implementation of {!S} or a functor providing {!S} once + applied. + + There are two ways to create a concrete {!Irmin.S} implementation: + + - {!Make} creates a store where all the objects are stored in the same + store, using the same internal keys format and a custom binary format + based on {{:https://github.com/janestreet/bin_prot} bin_prot}, with no + native synchronization primitives: it is usually what is needed to quickly + create a new backend. + - {!Make_ext} creates a store with a {e deep} embedding of each of the + internal stores into separate store, with total control over the binary + format and using the native synchronization protocols when available. *) + +(** [APPEND_ONLY_STORE_MAKER] is the signature exposed by append-only store + backends. [K] is the implementation of keys and [V] is the implementation of + values. *) +module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include APPEND_ONLY_STORE with type key = K.t and type value = V.t + open Private.Sigs.Store_properties + + include BATCH with type 'a t := 'a t + (** @inline *) + + include OF_CONFIG with type 'a t := 'a t + (** @inline *) + + include CLOSEABLE with type 'a t := 'a t + (** @inline *) +end + +(** [CONTENT_ADDRESSABLE_STOREMAKER] is the signature exposed by + content-addressable store backends. [K] is the implementation of keys and + [V] is the implementation of values. *) +module type CONTENT_ADDRESSABLE_STORE_MAKER = functor + (K : Hash.S) + (V : Type.S) + -> sig + include CONTENT_ADDRESSABLE_STORE with type key = K.t and type value = V.t + open Private.Sigs.Store_properties + + include BATCH with type 'a t := 'a t + (** @inline *) + + include OF_CONFIG with type 'a t := 'a t + (** @inline *) + + include CLOSEABLE with type 'a t := 'a t + (** @inline *) +end + +module Content_addressable + (S : APPEND_ONLY_STORE_MAKER) + (K : Hash.S) + (V : Type.S) : sig + include + CONTENT_ADDRESSABLE_STORE + with type 'a t = 'a S(K)(V).t + and type key = K.t + and type value = V.t + + open Private.Sigs.Store_properties + + include BATCH with type 'a t := 'a t + (** @inline *) + + include OF_CONFIG with type 'a t := 'a t + (** @inline *) + + include CLOSEABLE with type 'a t := 'a t + (** @inline *) +end + +(** [ATOMIC_WRITE_STORE_MAKER] is the signature exposed by atomic-write store + backends. [K] is the implementation of keys and [V] is the implementation of + values.*) +module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include ATOMIC_WRITE_STORE with type key = K.t and type value = V.t + open Private.Sigs.Store_properties + + include OF_CONFIG with type _ t := t + (** @inline *) +end + +(** Simple store creator. Use the same type of all of the internal keys and + store all the values in the same store. *) +module Make + (CA : CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : ATOMIC_WRITE_STORE_MAKER) : S_MAKER + +module Make_ext + (CA : CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : ATOMIC_WRITE_STORE_MAKER) + (Metadata : Metadata.S) + (Contents : Contents.S) + (Path : Path.S) + (Branch : Branch.S) + (Hash : Hash.S) + (Node : Private.Node.S + with type metadata = Metadata.t + and type hash = Hash.t + and type step = Path.step) + (Commit : Private.Commit.S with type hash = Hash.t) : + S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step + and type Private.Sync.endpoint = unit + +(** Advanced store creator. *) +module Of_private (P : Private.S) : + S + with type key = P.Node.Path.t + and type contents = P.Contents.value + and type branch = P.Branch.key + and type hash = P.Hash.t + and type step = P.Node.Path.step + and type metadata = P.Node.Metadata.t + and type Key.step = P.Node.Path.step + and type repo = P.Repo.t + and type slice = P.Slice.t + and module Private = P + +(** Exported for compatibility with a future version of Irmin. *) +module Maker_ext + (CA : CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : ATOMIC_WRITE_STORE_MAKER) + (Node : Private.Node.Maker) + (Commit : Private.Commit.Maker) : + Store.Maker_future with type endpoint = unit + +module Export_for_backends = Export_for_backends +(** Helper module containing useful top-level types for defining Irmin backends. + This module is relatively unstable. *) diff --git a/vendors/irmin/irmin/lock.ml b/vendors/irmin/irmin/lock.ml new file mode 100644 index 000000000000..6c40c6185a49 --- /dev/null +++ b/vendors/irmin/irmin/lock.ml @@ -0,0 +1,66 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type key + type t + + val v : unit -> t + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + val stats : t -> int +end + +module Make (K : Type.S) = struct + module K = struct + type t = K.t + + let hash = Hashtbl.hash + let equal = Type.(unstage (equal K.t)) + end + + module KHashtbl = Hashtbl.Make (K) + + type key = K.t + type t = { global : Lwt_mutex.t; locks : Lwt_mutex.t KHashtbl.t } + + let v () = { global = Lwt_mutex.create (); locks = KHashtbl.create 1024 } + let stats t = KHashtbl.length t.locks + + let lock t key () = + let lock = + try KHashtbl.find t.locks key + with Not_found -> + let lock = Lwt_mutex.create () in + KHashtbl.add t.locks key lock; + lock + in + Lwt.return lock + + let unlock t key () = + let () = + if KHashtbl.mem t.locks key then + let lock = KHashtbl.find t.locks key in + if Lwt_mutex.is_empty lock then KHashtbl.remove t.locks key + in + Lwt.return_unit + + let with_lock t k fn = + let* lock = Lwt_mutex.with_lock t.global (lock t k) in + let* r = Lwt_mutex.with_lock lock fn in + Lwt_mutex.with_lock t.global (unlock t k) >>= fun () -> Lwt.return r +end diff --git a/vendors/irmin/irmin/lock.mli b/vendors/irmin/irmin/lock.mli new file mode 100644 index 000000000000..fd4a1f8b0bef --- /dev/null +++ b/vendors/irmin/irmin/lock.mli @@ -0,0 +1,37 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Process locking helpers} *) + +module type S = sig + type t + (** The type for lock manager. *) + + type key + (** The type for key to be locked. *) + + val v : unit -> t + (** Create a lock manager. *) + + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_lock t k f] executes [f ()] while holding the exclusive lock + associated to the key [k]. *) + + val stats : t -> int +end + +(** Create a lock manager implementation. *) +module Make (K : Type.S) : S with type key = K.t diff --git a/vendors/irmin/irmin/lru.ml b/vendors/irmin/irmin/lru.ml new file mode 100644 index 000000000000..4e163fa3071a --- /dev/null +++ b/vendors/irmin/irmin/lru.ml @@ -0,0 +1,124 @@ +(* Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(* Extracted from https://github.com/pqwy/lru + Copyright (c) 2016 David Kaloper Meršinjak *) + +module Make (H : Hashtbl.HashedType) = struct + module HT = Hashtbl.Make (H) + + module Q = struct + type 'a node = { + value : 'a; + mutable next : 'a node option; + mutable prev : 'a node option; + } + + type 'a t = { + mutable first : 'a node option; + mutable last : 'a node option; + } + + let detach t n = + let np = n.prev and nn = n.next in + (match np with + | None -> t.first <- nn + | Some x -> + x.next <- nn; + n.prev <- None); + match nn with + | None -> t.last <- np + | Some x -> + x.prev <- np; + n.next <- None + + let append t n = + let on = Some n in + match t.last with + | Some x as l -> + x.next <- on; + t.last <- on; + n.prev <- l + | None -> + t.first <- on; + t.last <- on + + let node x = { value = x; prev = None; next = None } + let create () = { first = None; last = None } + + let clear t = + t.first <- None; + t.last <- None + end + + type key = HT.key + + type 'a t = { + ht : (key * 'a) Q.node HT.t; + q : (key * 'a) Q.t; + mutable cap : int; + mutable w : int; + } + + let weight t = t.w + let create cap = { cap; w = 0; ht = HT.create cap; q = Q.create () } + + let drop_lru t = + match t.q.first with + | None -> () + | Some ({ Q.value = k, _; _ } as n) -> + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + + let remove t k = + try + let n = HT.find t.ht k in + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + with Not_found -> () + + let add t k v = + if t.cap = 0 then () + else ( + remove t k; + let n = Q.node (k, v) in + t.w <- t.w + 1; + if weight t > t.cap then drop_lru t; + HT.add t.ht k n; + Q.append t.q n) + + let promote t k = + try + let n = HT.find t.ht k in + Q.( + detach t.q n; + append t.q n) + with Not_found -> () + + let find t k = + let v = HT.find t.ht k in + promote t k; + snd v.value + + let mem t k = + match HT.mem t.ht k with + | false -> false + | true -> + promote t k; + true + + let clear t = + HT.clear t.ht; + Q.clear t.q +end diff --git a/vendors/irmin/irmin/lru.mli b/vendors/irmin/irmin/lru.mli new file mode 100644 index 000000000000..2c6aabbf2be0 --- /dev/null +++ b/vendors/irmin/irmin/lru.mli @@ -0,0 +1,24 @@ +(* Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(* Extracted from https://github.com/pqwy/lru + Copyright (c) 2016 David Kaloper Meršinjak *) + +module Make (H : Hashtbl.HashedType) : sig + type 'a t + + val create : int -> 'a t + val add : 'a t -> H.t -> 'a -> unit + val find : 'a t -> H.t -> 'a + val mem : 'a t -> H.t -> bool + val clear : 'a t -> unit +end diff --git a/vendors/irmin/irmin/mem/dune b/vendors/irmin/irmin/mem/dune new file mode 100644 index 000000000000..595ba0e0087f --- /dev/null +++ b/vendors/irmin/irmin/mem/dune @@ -0,0 +1,4 @@ +(library + (name irmin_mem) + (public_name irmin.mem) + (libraries irmin logs lwt)) diff --git a/vendors/irmin/irmin/mem/import.ml b/vendors/irmin/irmin/mem/import.ml new file mode 100644 index 000000000000..6f1b909c9f84 --- /dev/null +++ b/vendors/irmin/irmin/mem/import.ml @@ -0,0 +1 @@ +include Irmin.Export_for_backends diff --git a/vendors/irmin/irmin/mem/irmin_mem.ml b/vendors/irmin/irmin/mem/irmin_mem.ml new file mode 100644 index 000000000000..614d69f3f905 --- /dev/null +++ b/vendors/irmin/irmin/mem/irmin_mem.ml @@ -0,0 +1,146 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let src = Logs.Src.create "irmin.mem" ~doc:"Irmin in-memory store" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct + module KMap = Map.Make (struct + type t = K.t + + let compare = Irmin.Type.(unstage (compare K.t)) + end) + + type key = K.t + type value = V.t + type 'a t = { mutable t : value KMap.t } + + let map = { t = KMap.empty } + let v _config = Lwt.return map + + let clear t = + Log.debug (fun f -> f "clear"); + t.t <- KMap.empty; + Lwt.return_unit + + let close _ = + Log.debug (fun f -> f "close"); + Lwt.return_unit + + let cast t = (t :> read_write t) + let batch t f = f (cast t) + let pp_key = Irmin.Type.pp K.t + + let find { t; _ } key = + Log.debug (fun f -> f "find %a" pp_key key); + try Lwt.return_some (KMap.find key t) with Not_found -> Lwt.return_none + + let mem { t; _ } key = + Log.debug (fun f -> f "mem %a" pp_key key); + Lwt.return (KMap.mem key t) +end + +module Append_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct + include Read_only (K) (V) + + let add t key value = + Log.debug (fun f -> f "add -> %a" pp_key key); + t.t <- KMap.add key value t.t; + Lwt.return_unit +end + +module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct + module RO = Read_only (K) (V) + module W = Irmin.Private.Watch.Make (K) (V) + module L = Irmin.Private.Lock.Make (K) + + type t = { t : unit RO.t; w : W.t; lock : L.t } + type key = RO.key + type value = RO.value + type watch = W.watch + + let watches = W.v () + let lock = L.v () + + let v config = + let* t = RO.v config in + Lwt.return { t; w = watches; lock } + + let close t = W.clear t.w >>= fun () -> RO.close t.t + let find t = RO.find t.t + let mem t = RO.mem t.t + let watch_key t = W.watch_key t.w + let watch t = W.watch t.w + let unwatch t = W.unwatch t.w + + let list t = + Log.debug (fun f -> f "list"); + RO.KMap.fold (fun k _ acc -> k :: acc) t.t.RO.t [] |> Lwt.return + + let set t key value = + Log.debug (fun f -> f "update"); + let* () = + L.with_lock t.lock key (fun () -> + t.t.RO.t <- RO.KMap.add key value t.t.RO.t; + Lwt.return_unit) + in + W.notify t.w key (Some value) + + let remove t key = + Log.debug (fun f -> f "remove"); + let* () = + L.with_lock t.lock key (fun () -> + t.t.RO.t <- RO.KMap.remove key t.t.RO.t; + Lwt.return_unit) + in + W.notify t.w key None + + let equal_v_opt = Irmin.Type.(unstage (equal (option V.t))) + + let test_and_set t key ~test ~set = + Log.debug (fun f -> f "test_and_set"); + let* updated = + L.with_lock t.lock key (fun () -> + let+ v = find t key in + if equal_v_opt test v then + let () = + match set with + | None -> t.t.RO.t <- RO.KMap.remove key t.t.RO.t + | Some v -> t.t.RO.t <- RO.KMap.add key v t.t.RO.t + in + true + else false) + in + let+ () = if updated then W.notify t.w key set else Lwt.return_unit in + updated + + let clear t = W.clear t.w >>= fun () -> RO.clear t.t +end + +let config () = Irmin.Private.Conf.empty + +module Make = + Irmin.Make (Irmin.Content_addressable (Append_only)) (Atomic_write) + +module KV (C : Irmin.Contents.S) = + Make (Irmin.Metadata.None) (C) (Irmin.Path.String_list) (Irmin.Branch.String) + (Irmin.Hash.BLAKE2B) + +(* Enforce that {!KV} is a sub-type of {!Irmin.KV_MAKER}. *) +module KV_is_a_KV_MAKER : Irmin.KV_MAKER = KV diff --git a/vendors/irmin/irmin/mem/irmin_mem.mli b/vendors/irmin/irmin/mem/irmin_mem.mli new file mode 100644 index 000000000000..46a5365d3615 --- /dev/null +++ b/vendors/irmin/irmin/mem/irmin_mem.mli @@ -0,0 +1,40 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** In-memory store. + + A simple in-memory store, using hash tables. Once one of the functors below + is instantiated to a module [M], it has a unique shared hash-table: multiple + invocation of [M.create] will see and manipulate the same contents. *) + +val config : unit -> Irmin.config +(** Configuration values. *) + +module Append_only : Irmin.APPEND_ONLY_STORE_MAKER +(** An in-memory store for append-only values. *) + +module Atomic_write : Irmin.ATOMIC_WRITE_STORE_MAKER +(** An in-memory store with atomic-write guarantees. *) + +module Make : Irmin.S_MAKER +(** Constructor for in-memory Irmin store. *) + +(** Constructor for in-memory KV stores. Subtype of {!Irmin.KV_MAKER}. *) +module KV (C : Irmin.Contents.S) : + Irmin.KV + with type contents = C.t + and type metadata = unit + and type Private.Sync.endpoint = unit diff --git a/vendors/irmin/irmin/merge.ml b/vendors/irmin/irmin/merge.ml new file mode 100644 index 000000000000..d0e59ab8176a --- /dev/null +++ b/vendors/irmin/irmin/merge.ml @@ -0,0 +1,421 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Printf + +let src = Logs.Src.create "irmin.merge" ~doc:"Irmin merging" + +module Log = (val Logs.src_log src : Logs.LOG) + +type conflict = [ `Conflict of string ] +type 'a promise = unit -> ('a option, conflict) result Lwt.t + +let promise t : 'a promise = fun () -> Lwt.return (Ok (Some t)) + +let memo fn = + let r = ref None in + fun () -> + match !r with + | Some x -> x + | None -> + let* x = fn () in + r := Some (Lwt.return x); + Lwt.return x + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +type 'a t = 'a Type.t * 'a f + +let v t f = (t, f) +let f (x : 'a t) = snd x + +let conflict fmt = + ksprintf + (fun msg -> + Log.debug (fun f -> f "conflict: %s" msg); + Lwt.return (Error (`Conflict msg))) + fmt + +let bind x f = x >>= function Error e -> Lwt.return (Error e) | Ok x -> f x +let map f x = x >|= function Error _ as x -> x | Ok x -> Ok (f x) + +let map_promise f t () = + t () >|= function + | Error _ as x -> x + | Ok None -> Ok None + | Ok (Some a) -> Ok (Some (f a)) + +let bind_promise t f () = + t () >>= function + | Error e -> Lwt.return (Error e) + | Ok None -> Lwt.return (Ok None) + | Ok (Some a) -> f a () + +let ok x = Lwt.return (Ok x) + +module Infix = struct + let ( >>=* ) = bind + let ( >|=* ) x f = map f x + let ( >>=? ) = bind_promise + let ( >|=? ) x f = map_promise f x +end + +open Infix + +let default (type a) (t : a Type.t) : a t = + let pp = Type.pp t and equal = Type.(unstage (equal t)) in + ( t, + fun ~old t1 t2 -> + let open Infix in + Log.debug (fun f -> f "default %a | %a" pp t1 pp t2); + old () >>=* function + | None -> conflict "default: add/add and no common ancestor" + | Some old -> + Log.debug (fun f -> f "default old=%a" pp t1); + if equal old t1 && equal t1 t2 then ok t1 + else if equal old t1 then ok t2 + else if equal old t2 then ok t1 + else conflict "default" ) + +let idempotent dt = + let equal = Type.(unstage (equal dt)) in + let default = default dt in + let f ~old x y = if equal x y then ok x else f default ~old x y in + v dt f + +let seq = function + | [] -> invalid_arg "nothing to merge" + | (t, _) :: _ as ts -> + ( t, + fun ~old v1 v2 -> + Lwt_list.fold_left_s + (fun acc (_, merge) -> + match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2) + (Error (`Conflict "nothing to merge")) + ts ) + +let option (type a) ((a, t) : a t) : a option t = + let pp_a = Type.pp a and equal = Type.(unstage (equal a)) in + let dt = Type.option a in + let pp = Type.pp dt in + ( dt, + fun ~old t1 t2 -> + Log.debug (fun f -> f "some %a | %a" pp t1 pp t2); + f (default Type.(option a)) ~old t1 t2 >>= function + | Ok x -> ok x + | Error _ -> ( + match (t1, t2) with + | None, None -> ok None + | Some v1, Some v2 -> + let open Infix in + let old () = + old () >>=* function + | None -> ok None + | Some o -> + Log.debug (fun f -> f "option old=%a" pp o); + ok o + in + t ~old v1 v2 >|=* fun x -> Some x + | Some x, None | None, Some x -> ( + let open Infix in + old () >>=* function + | None | Some None -> ok (Some x) + | Some (Some o) -> + Log.debug (fun f -> f "option old=%a" pp_a o); + if equal x o then ok (Some x) else conflict "option: add/del") + ) ) + +let pair (da, a) (db, b) = + let dt = Type.pair da db in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + Log.debug (fun f -> f "pair %a | %a" pp x pp y); + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1), (a2, b2) = (x, y) in + let o1 = map_promise fst old in + let o2 = map_promise snd old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >|=* fun b3 -> (a3, b3) ) + +let triple (da, a) (db, b) (dc, c) = + let dt = Type.triple da db dc in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + Log.debug (fun f -> f "triple %a | %a" pp x pp y); + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1, c1), (a2, b2, c2) = (x, y) in + let o1 = map_promise (fun (x, _, _) -> x) old in + let o2 = map_promise (fun (_, x, _) -> x) old in + let o3 = map_promise (fun (_, _, x) -> x) old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >>=* fun b3 -> + c ~old:o3 c1 c2 >|=* fun c3 -> (a3, b3, c3) ) + +exception C of string + +let merge_elt merge_v old key vs = + let v1, v2 = + match vs with + | `Left v -> (Some v, None) + | `Right v -> (None, Some v) + | `Both (v1, v2) -> (Some v1, Some v2) + in + let old () = old key in + merge_v key ~old v1 v2 >>= function + | Error (`Conflict msg) -> Lwt.fail (C msg) + | Ok x -> Lwt.return x + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = + match (l1, l2) with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1, v1) :: t1, (k2, v2) :: t2 -> ( + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + aux t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + aux t1 l2) + else ( + f k2 (`Right v2); + aux l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_p Fun.id (List.rev !l3) + +(* DO NOT assume l1 and l2 are key-sorted *) +let alist_merge_lwt compare_k f l1 l2 = + let open Lwt in + let l3 = ref [] in + let sort l = List.sort (fun (x, _) (y, _) -> compare_k x y) l in + let l1 = sort l1 in + let l2 = sort l2 in + let f key data = + f key data >>= function + | None -> return_unit + | Some v -> + l3 := (key, v) :: !l3; + return_unit + in + alist_iter2_lwt compare_k f l1 l2 >>= fun () -> return !l3 + +let alist dx dy merge_v = + let pair = Type.pair dx dy in + let compare_pair = Type.unstage (Type.compare pair) in + let compare_dx = Type.(unstage (compare dx)) in + let dt = Type.list pair in + ( dt, + fun ~old x y -> + let pp = Type.pp dt in + Log.debug (fun l -> l "alist %a | %a" pp x pp y); + let sort = List.sort compare_pair in + let x = sort x in + let y = sort y in + let old k = + let open Infix in + old () >|=* function + | None -> Some None (* no parent = parent with empty value *) + | Some old -> + let old = try Some (List.assoc k old) with Not_found -> None in + Some old + in + let merge_v k = f (merge_v k) in + Lwt.catch + (fun () -> + alist_merge_lwt compare_dx (merge_elt merge_v old) x y >>= ok) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) + +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + let t = Type.map Type.(list (pair K.t int64)) of_alist M.bindings + + let merge ~old m1 m2 = + let get k m = try M.find k m with Not_found -> 0L in + let set k v m = match v with 0L -> M.remove k m | _ -> M.add k v m in + let add k v m = set k (Int64.add v @@ get k m) m in + let keys = ref M.empty in + old () >|=* fun old -> + let old = + match old with + | None -> M.empty (* no parent = parent with empty value *) + | Some o -> o + in + M.iter (fun k v -> keys := add k (Int64.neg v) !keys) old; + M.iter (fun k v -> keys := add k v !keys) m1; + M.iter (fun k v -> keys := add k v !keys) m2; + !keys + + let merge = (t, merge) +end + +module Set (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module S = Set.Make (K) + + let of_list l = List.fold_left (fun set elt -> S.add elt set) S.empty l + let t = Type.(map @@ list K.t) of_list S.elements + let pp = Type.pp t + + let merge ~old x y = + Log.debug (fun l -> l "merge %a %a" pp x pp y); + old () >|=* fun old -> + let old = match old with None -> S.empty | Some o -> o in + let ( ++ ) = S.union and ( -- ) = S.diff in + let to_add = x -- old ++ (y -- old) in + let to_del = old -- x ++ (old -- y) in + old -- to_del ++ to_add + + let merge = (t, merge) +end + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + let t x = Type.map Type.(list @@ pair K.t x) of_alist M.bindings + let iter2 f t1 t2 = alist_iter2 K.compare f (M.bindings t1) (M.bindings t2) + + let iter2 f m1 m2 = + let m3 = ref [] in + iter2 (fun key data -> m3 := f key data :: !m3) m1 m2; + Lwt_list.iter_p (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !m3) + + let merge_maps f m1 m2 = + let l3 = ref [] in + let f key data = + f key data >|= function None -> () | Some v -> l3 := (key, v) :: !l3 + in + iter2 f m1 m2 >>= fun () -> + let m3 = of_alist !l3 in + Lwt.return m3 + + let merge dv (merge_v : K.t -> 'a option t) = + let pp ppf m = Type.(pp (list (pair K.t dv))) ppf @@ M.bindings m in + let merge_v k = f (merge_v k) in + ( t dv, + fun ~old m1 m2 -> + Log.debug (fun f -> f "assoc %a | %a" pp m1 pp m2); + Lwt.catch + (fun () -> + let old key = + old () >>=* function + | None -> ok None + | Some old -> + Log.debug (fun f -> f "assoc old=%a" pp old); + let old = + try Some (M.find key old) with Not_found -> None + in + ok (Some old) + in + merge_maps (merge_elt merge_v old) m1 m2 >>= ok) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) +end + +let like da t a_to_b b_to_a = + let pp = Type.pp da in + let merge ~old a1 a2 = + Log.debug (fun f -> f "biject %a | %a" pp a1 pp a2); + try + let b1 = a_to_b a1 in + let b2 = a_to_b a2 in + let old = memo (map_promise a_to_b old) in + (f t) ~old b1 b2 >|=* b_to_a + with Not_found -> conflict "biject" + in + seq [ default da; (da, merge) ] + +let like_lwt (type a b) da (t : b t) (a_to_b : a -> b Lwt.t) + (b_to_a : b -> a Lwt.t) : a t = + let pp = Type.pp da in + let merge ~old a1 a2 = + Log.debug (fun f -> f "biject' %a | %a" pp a1 pp a2); + try + let* b1 = a_to_b a1 in + let* b2 = a_to_b a2 in + let old = + memo (fun () -> + bind (old ()) @@ function + | None -> ok None + | Some a -> + let+ b = a_to_b a in + Ok (Some b)) + in + bind ((f t) ~old b1 b2) @@ fun b3 -> b_to_a b3 >>= ok + with Not_found -> conflict "biject'" + in + seq [ default da; (da, merge) ] + +let unit = default Type.unit +let bool = default Type.bool +let char = default Type.char +let int32 = default Type.int32 +let int64 = default Type.int64 +let float = default Type.float +let string = default Type.string + +type counter = int64 + +let counter = + ( Type.int64, + fun ~old x y -> + old () >|=* fun old -> + let old = match old with None -> 0L | Some o -> o in + let ( + ) = Int64.add and ( - ) = Int64.sub in + x + y - old ) + +let with_conflict rewrite (d, f) = + let f ~old x y = + f ~old x y >>= function + | Error (`Conflict msg) -> conflict "%s" (rewrite msg) + | Ok x -> ok x + in + (d, f) + +let conflict_t = + Type.(map string) (fun x -> `Conflict x) (function `Conflict x -> x) + +type nonrec 'a result = ('a, conflict) result [@@deriving irmin] diff --git a/vendors/irmin/irmin/merge.mli b/vendors/irmin/irmin/merge.mli new file mode 100644 index 000000000000..09f2e5a218b1 --- /dev/null +++ b/vendors/irmin/irmin/merge.mli @@ -0,0 +1,235 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Merge operators. *) + +type conflict = [ `Conflict of string ] +(** The type for merge errors. *) + +val ok : 'a -> ('a, conflict) result Lwt.t +(** Return [Ok x]. *) + +val conflict : ('a, unit, string, ('b, conflict) result Lwt.t) format4 -> 'a +(** Return [Error (Conflict str)]. *) + +val bind : + ('a, 'b) result Lwt.t -> + ('a -> ('c, 'b) result Lwt.t) -> + ('c, 'b) result Lwt.t +(** [bind r f] is the merge result which behaves as of the application of the + function [f] to the return value of [r]. If [r] fails, [bind r f] also + fails, with the same conflict. *) + +val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t +(** [map f m] maps the result of a merge. This is the same as + [bind m (fun x -> ok (f x))]. *) + +(** {1 Merge Combinators} *) + +type 'a promise = unit -> ('a option, conflict) result Lwt.t +(** An ['a] promise is a function which, when called, will eventually return a + value type of ['a]. A promise is an optional, lazy and non-blocking value. *) + +val promise : 'a -> 'a promise +(** [promise a] is the promise containing [a]. *) + +val map_promise : ('a -> 'b) -> 'a promise -> 'b promise +(** [map_promise f a] is the promise containing [f] applied to what is promised + by [a]. *) + +val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise +(** [bind_promise a f] is the promise returned by [f] applied to what is + promised by [a]. *) + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +(** Signature of a merge function. [old] is the value of the least-common + ancestor. + + {v + /----> t1 ----\ + ----> old |--> result + \----> t2 ----/ + v} *) + +type 'a t +(** The type for merge combinators. *) + +val v : 'a Type.t -> 'a f -> 'a t +(** [v dt f] create a merge combinator. *) + +val f : 'a t -> 'a f +(** [f m] is [m]'s merge function. *) + +val seq : 'a t list -> 'a t +(** Call the merge functions in sequence. Stop as soon as one is {e not} + returning a conflict. *) + +val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t +(** Use the merge function defined in another domain. If the converting + functions raise any exception the merge is a conflict. *) + +val with_conflict : (string -> string) -> 'a t -> 'a t +(** [with_conflict f m] is [m] with the conflict error message modified by [f]. *) + +val like_lwt : 'a Type.t -> 'b t -> ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t +(** Same as {{!Merge.biject} biject} but with blocking domain converting + functions. *) + +(** {1 Basic Merges} *) + +val default : 'a Type.t -> 'a t +(** [default t] is the default merge function for values of type [t]. This is a + simple merge function which supports changes in one branch at a time: + + - if [t1=old] then the result of the merge is [OK t2]; + - if [t2=old] then return [OK t1]; + - otherwise the result is [Conflict]. *) + +val idempotent : 'a Type.t -> 'a t +(** [idempotent t] is the default merge function for values of type [t] using + idempotent operations. It follows the same rules as the {!default} merge + function but also adds: + + - if [t1=t2] then the result of the merge is [OK t1]. *) + +val unit : unit t +(** [unit] is the default merge function for unit values. *) + +val bool : bool t +(** [bool] is the default merge function for booleans. *) + +val char : char t +(** [char] is the default merge function for characters. *) + +val int32 : int32 t +(** [int32] is the default merge function for 32-bits integers. *) + +val int64 : int64 t +(** [int64] the default merge function for 64-bit integers. *) + +val float : float t +(** [float] is the default merge function for floating point numbers. *) + +val string : string t +(** The default string merge function. Do not do anything clever, just compare + the strings using the [default] merge function. *) + +val option : 'a t -> 'a option t +(** Lift a merge function to optional values of the same type. If all the + provided values are inhabited, then call the provided merge function, + otherwise use the same behavior as {!default}. *) + +val pair : 'a t -> 'b t -> ('a * 'b) t +(** Lift merge functions to pairs of elements. *) + +val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t +(** Lift merge functions to triples of elements. *) + +(** {1 Counters and Multisets} *) + +type counter = int64 +(** The type for counter values. It is expected that the only valid operations + on counters are {e increment} and {e decrement}. The following merge + functions ensure that the counter semantics are preserved: {e i.e.} it + ensures that the number of increments and decrements is preserved. *) + +val counter : counter t +(** The merge function for mergeable counters. *) + +(** Multi-sets. *) +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : counter Map.Make(K).t t +end + +(** {1 Maps and Association Lists} *) + +(** We consider the only valid operations for maps and association lists to be: + + - Adding a new bindings to the map. + - Removing a binding from the map. + - Replacing an existing binding with a different value. + - {e Trying to add an already existing binding is a no-op}. + + We thus assume that no operation on maps is modifying the {e key} names. So + the following merge functions ensures that {e (i)} new bindings are + preserved {e (ii)} removed bindings stay removed and {e (iii)} modified + bindings are merged using the merge function of values. + + {b Note:} We only consider sets of bindings, instead of multisets. + Application developers should take care of concurrent addition and removal + of similar bindings themselves, by using the appropriate {{!Merge.MSet} + multi-sets}. *) + +(** Lift merge functions to sets. *) +module Set (E : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : Set.Make(E).t t +end + +val alist : 'a Type.t -> 'b Type.t -> ('a -> 'b option t) -> ('a * 'b) list t +(** Lift the merge functions to association lists. *) + +(** Lift the merge functions to maps. *) + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) : sig + val merge : 'a Type.t -> (K.t -> 'a option t) -> 'a Map.Make(K).t t +end + +(** Infix operators for manipulating merge results and {!promise}s. + + [open Irmin.Merge.Infix] at the top of your file to use them. *) +module Infix : sig + (** {1 Merge Result Combinators} *) + + val ( >>=* ) : + ('a, conflict) result Lwt.t -> + ('a -> ('b, conflict) result Lwt.t) -> + ('b, conflict) result Lwt.t + (** [>>=*] is {!bind}. *) + + val ( >|=* ) : + ('a, conflict) result Lwt.t -> ('a -> 'b) -> ('b, conflict) result Lwt.t + (** [>|=*] is {!map}. *) + + (** {1 Promise Combinators} + + This is useful to manipulate lca results. *) + + val ( >>=? ) : 'a promise -> ('a -> 'b promise) -> 'b promise + (** [>>=?] is {!bind_promise}. *) + + val ( >|=? ) : 'a promise -> ('a -> 'b) -> 'b promise + (** [>|=?] is {!map_promise}. *) +end + +(** {1 Value Types} *) + +val conflict_t : conflict Type.t +(** [conflict_t] is the value type for {!conflict}. *) + +val result_t : 'a Type.t -> ('a, conflict) result Type.t +(** [result_t] is the value type for merge results. *) diff --git a/vendors/irmin/irmin/node.ml b/vendors/irmin/irmin/node.ml new file mode 100644 index 000000000000..c36a90f6cf56 --- /dev/null +++ b/vendors/irmin/irmin/node.ml @@ -0,0 +1,496 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open S +include Node_intf + +let src = Logs.Src.create "irmin.node" ~doc:"Irmin trees/nodes" + +module Log = (val Logs.src_log src : Logs.LOG) + +module No_metadata = struct + type t = unit [@@deriving irmin] + + let default = () + let merge = Merge.v t (fun ~old:_ () () -> Merge.ok ()) +end + +module Make + (K : Type.S) (P : sig + type step [@@deriving irmin] + end) + (M : METADATA) = +struct + type hash = K.t [@@deriving irmin ~pp] + type step = P.step [@@deriving irmin] + type metadata = M.t [@@deriving irmin ~equal] + type kind = [ `Node | `Contents of M.t ] + + let kind_t = + let open Type in + variant "Tree.kind" (fun node contents contents_m -> function + | `Node -> node + | `Contents m -> + if equal_metadata m M.default then contents else contents_m m) + |~ case0 "node" `Node + |~ case0 "contents" (`Contents M.default) + |~ case1 "contents" M.t (fun m -> `Contents m) + |> sealv + + type entry = { kind : kind; name : P.step; node : K.t } [@@deriving irmin] + + let equal_entry_opt = Type.(unstage (equal [%typ: entry option])) + + let to_entry (k, v) = + match v with + | `Node h -> { name = k; kind = `Node; node = h } + | `Contents (h, m) -> { name = k; kind = `Contents m; node = h } + + let of_entry n = + ( n.name, + match n.kind with + | `Node -> `Node n.node + | `Contents m -> `Contents (n.node, m) ) + + module StepMap = Map.Make (struct + type t = P.step + + let compare = Type.(unstage (compare P.step_t)) + end) + + type value = [ `Contents of hash * metadata | `Node of hash ] + type t = entry StepMap.t + + let of_seq l = + Seq.fold_left + (fun acc x -> StepMap.add (fst x) (to_entry x) acc) + StepMap.empty l + + let of_list l = of_seq (List.to_seq l) + + let seq ?(offset = 0) ?length ?cache:_ (t : t) = + let take seq = match length with None -> seq | Some n -> Seq.take n seq in + StepMap.to_seq t + |> Seq.drop offset + |> take + |> Seq.map (fun (_, e) -> of_entry e) + + let list ?offset ?length ?cache:_ t = List.of_seq (seq ?offset ?length t) + + let find ?cache:_ t s = + try + let _, v = of_entry (StepMap.find s t) in + Some v + with Not_found -> None + + let empty = StepMap.empty + let is_empty e = StepMap.is_empty e + let length e = StepMap.cardinal e + let clear _ = () + + let add t k v = + let e = to_entry (k, v) in + StepMap.update k + (fun e' -> if equal_entry_opt (Some e) e' then e' else Some e) + t + + let remove t k = StepMap.remove k t + let default = M.default + + let value_t = + let open Type in + variant "value" (fun n c x -> function + | `Node h -> n h + | `Contents (h, m) -> if equal_metadata m M.default then c h else x (h, m)) + |~ case1 "node" K.t (fun k -> `Node k) + |~ case1 "contents" K.t (fun h -> `Contents (h, M.default)) + |~ case1 "contents-x" (pair K.t M.t) (fun (h, m) -> `Contents (h, m)) + |> sealv + + let of_entries e = of_list (List.rev_map of_entry e) + let entries e = List.rev_map (fun (_, e) -> e) (StepMap.bindings e) + let t = Type.map Type.(list entry_t) of_entries entries + + type proof = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int list * proof) list ] + [@@deriving irmin] + + let to_proof (t : t) : proof = + let e = List.map of_entry (entries t) in + `Values e + + let of_proof (t : proof) = + match t with + | `Blinded _ | `Inode _ -> None + | `Values e -> + let e = List.map to_entry e in + Some (of_entries e) + + let with_handler _ t = t + + exception Dangling_hash of { context : string; hash : hash } + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some + (Fmt.str "Irmin.Node.%s: encountered dangling hash %a" context + pp_hash hash) + | _ -> None) +end + +module Store + (C : Contents.STORE) + (P : Path.S) + (M : METADATA) (S : sig + include CONTENT_ADDRESSABLE_STORE with type key = C.key + module Key : Hash.S with type t = key + + module Val : + S + with type t = value + and type hash = key + and type metadata = M.t + and type step = P.step + end) = +struct + module Contents = C + module Key = Hash.Typed (S.Key) (S.Val) + module Path = P + module Metadata = M + + type 'a t = 'a C.t * 'a S.t + type key = S.key + type value = S.value + + let mem (_, t) = S.mem t + let find (_, t) = S.find t + let clear (_, t) = S.clear t + let add (_, t) = S.add t + let unsafe_add (_, t) = S.unsafe_add t + + let all_contents t = + let kvs = S.Val.list t in + List.fold_left + (fun acc -> function k, `Contents c -> (k, c) :: acc | _ -> acc) + [] kvs + + let all_succ t = + let kvs = S.Val.list t in + List.fold_left + (fun acc -> function k, `Node n -> (k, n) :: acc | _ -> acc) + [] kvs + + let contents_t = C.Key.t + let metadata_t = M.t + let step_t = Path.step_t + + (* [Merge.alist] expects us to return an option. [C.merge] does + that, but we need to consider the metadata too... *) + let merge_contents_meta c = + (* This gets us [C.t option, S.Val.Metadata.t]. We want [(C.t * + S.Val.Metadata.t) option]. *) + let explode = function + | None -> (None, M.default) + | Some (c, m) -> (Some c, m) + in + let implode = function None, _ -> None | Some c, m -> Some (c, m) in + Merge.like [%typ: (contents * metadata) option] + (Merge.pair (C.merge c) M.merge) + explode implode + + let merge_contents_meta c = + Merge.alist step_t [%typ: contents * metadata] (fun _step -> + merge_contents_meta c) + + let merge_parents merge_key = + Merge.alist step_t S.Key.t (fun _step -> merge_key) + + let merge_value (c, _) merge_key = + let explode t = (all_contents t, all_succ t) in + let implode (contents, succ) = + let xs = List.rev_map (fun (s, c) -> (s, `Contents c)) contents in + let ys = List.rev_map (fun (s, n) -> (s, `Node n)) succ in + S.Val.of_list (xs @ ys) + in + let merge = Merge.pair (merge_contents_meta c) (merge_parents merge_key) in + Merge.like S.Val.t merge explode implode + + let rec merge t = + let merge_key = + Merge.v [%typ: S.Key.t option] (fun ~old x y -> + Merge.(f (merge t)) ~old x y) + in + let merge = merge_value t merge_key in + let read = function + | None -> Lwt.return S.Val.empty + | Some k -> ( find t k >|= function None -> S.Val.empty | Some v -> v) + in + let add v = + if S.Val.is_empty v then Lwt.return_none else add t v >>= Lwt.return_some + in + Merge.like_lwt [%typ: S.Key.t option] merge read add + + module Val = S.Val +end + +module Graph (S : STORE) = struct + module Path = S.Path + module Contents = S.Contents.Key + module Metadata = S.Metadata + + type step = Path.step [@@deriving irmin] + type metadata = Metadata.t [@@deriving irmin] + type contents = Contents.t [@@deriving irmin] + type node = S.Key.t [@@deriving irmin] + type path = Path.t [@@deriving irmin] + type 'a t = 'a S.t + type value = [ `Contents of contents * metadata | `Node of node ] + + let empty t = S.add t S.Val.empty + + let list t n = + Log.debug (fun f -> f "steps"); + S.find t n >|= function None -> [] | Some n -> S.Val.list n + + module U = struct + type t = unit [@@deriving irmin] + end + + module Graph = Object_graph.Make (S.Key) (U) + + let edges t = + List.rev_map + (function _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (S.Val.list t) + + let pp_key = Type.pp S.Key.t + let pp_keys = Fmt.(Dump.list pp_key) + let pp_path = Type.pp S.Path.t + let equal_val = Type.(unstage (equal S.Val.t)) + + let pred t = function + | `Node k -> ( S.find t k >|= function None -> [] | Some v -> edges v) + | _ -> Lwt.return_nil + + let closure t ~min ~max = + Log.debug (fun f -> f "closure min=%a max=%a" pp_keys min pp_keys max); + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + let+ g = Graph.closure ~pred:(pred t) ~min ~max () in + List.fold_left + (fun acc -> function `Node x -> x :: acc | _ -> acc) + [] (Graph.vertex g) + + let ignore_lwt _ = Lwt.return_unit + + let iter t ~min ~max ?(node = ignore_lwt) ?(contents = ignore_lwt) ?edge + ?(skip_node = fun _ -> Lwt.return_false) + ?(skip_contents = fun _ -> Lwt.return_false) ?(rev = true) () = + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + let node = function + | `Node x -> node x + | `Contents c -> contents c + | `Branch _ | `Commit _ -> Lwt.return_unit + in + let edge = + Option.map + (fun edge n pred -> + match (n, pred) with + | `Node src, `Node dst -> edge src dst + | _ -> Lwt.return_unit) + edge + in + let skip = function + | `Node x -> skip_node x + | `Contents c -> skip_contents c + | _ -> Lwt.return_false + in + Graph.iter ~pred:(pred t) ~min ~max ~node ?edge ~skip ~rev () + + let v t xs = S.add t (S.Val.of_list xs) + + let find_step t node step = + Log.debug (fun f -> f "contents %a" pp_key node); + S.find t node >|= function None -> None | Some n -> S.Val.find n step + + let find t node path = + Log.debug (fun f -> f "read_node_exn %a %a" pp_key node pp_path path); + let rec aux node path = + match Path.decons path with + | None -> Lwt.return_some (`Node node) + | Some (h, tl) -> ( + find_step t node h >>= function + | (None | Some (`Contents _)) as x -> Lwt.return x + | Some (`Node node) -> aux node tl) + in + aux node path + + let err_empty_path () = invalid_arg "Irmin.node: empty path" + + let map_one t node f label = + Log.debug (fun f -> f "map_one %a" Type.(pp Path.step_t) label); + let old_key = S.Val.find node label in + let* old_node = + match old_key with + | None | Some (`Contents _) -> Lwt.return S.Val.empty + | Some (`Node k) -> ( + S.find t k >|= function None -> S.Val.empty | Some v -> v) + in + let* new_node = f old_node in + if equal_val old_node new_node then Lwt.return node + else if S.Val.is_empty new_node then + let node = S.Val.remove node label in + if S.Val.is_empty node then Lwt.return S.Val.empty else Lwt.return node + else + let+ k = S.add t new_node in + S.Val.add node label (`Node k) + + let map t node path f = + Log.debug (fun f -> f "map %a %a" pp_key node pp_path path); + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (f node) + | Some (h, tl) -> map_one t node (fun node -> aux node tl) h + in + let* node = + S.find t node >|= function None -> S.Val.empty | Some n -> n + in + aux node path >>= S.add t + + let add t node path n = + Log.debug (fun f -> f "add %a %a" pp_key node pp_path path); + match Path.rdecons path with + | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) + | None -> ( + match n with + | `Node n -> Lwt.return n + | `Contents _ -> failwith "TODO: Node.add") + + let rdecons_exn path = + match Path.rdecons path with + | Some (l, t) -> (l, t) + | None -> err_empty_path () + + let remove t node path = + let path, file = rdecons_exn path in + map t node path (fun node -> S.Val.remove node file) + + let value_t = S.Val.value_t +end + +module V1 (N : S with type step = string) = struct + module K = struct + let h = Type.string_of `Int64 + let to_bin_string = Type.(unstage (to_bin_string N.hash_t)) + let of_bin_string = Type.(unstage (of_bin_string N.hash_t)) + let size_of = Type.Size.using to_bin_string (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.(unstage (encode_bin h)) in + fun e k -> encode_bin (to_bin_string e) k + + let decode_bin = + let decode_bin = Type.(unstage (decode_bin h)) in + fun buf off -> + let n, v = decode_bin buf off in + ( n, + match of_bin_string v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e ) + + let t = Type.like N.hash_t ~bin:(encode_bin, decode_bin, size_of) + end + + include N + + type t = { n : N.t; entries : (step * value) list } + + let import n = { n; entries = N.list n } + let export t = t.n + let to_proof t = N.to_proof t.n + let of_proof p = Option.map import (N.of_proof p) + let with_handler _ t = t + + let of_seq entries = + let n = N.of_seq entries in + let entries = List.of_seq entries in + { n; entries } + + let of_list entries = + let n = N.of_list entries in + { n; entries } + + let seq ?(offset = 0) ?length ?cache:_ t = + let take seq = match length with None -> seq | Some n -> Seq.take n seq in + List.to_seq t.entries |> Seq.drop offset |> take + + let list ?offset ?length ?cache t = List.of_seq (seq ?offset ?length ?cache t) + let empty = { n = N.empty; entries = [] } + let is_empty t = t.entries = [] + let length e = N.length e.n + let clear _ = () + let default = N.default + let find ?cache t k = N.find ?cache t.n k + + let add t k v = + let n = N.add t.n k v in + if t.n == n then t else { n; entries = N.list n } + + let remove t k = + let n = N.remove t.n k in + if t.n == n then t else { n; entries = N.list n } + + let v1_step = Type.string_of `Int64 + let step_to_bin_string = Type.(unstage (to_bin_string v1_step)) + let step_of_bin_string = Type.(unstage (of_bin_string v1_step)) + + let step_t : step Type.t = + let to_string p = step_to_bin_string p in + let of_string s = + step_of_bin_string s |> function + | Ok x -> x + | Error (`Msg e) -> Fmt.failwith "Step.of_string: %s" e + in + Type.(map (string_of `Int64)) of_string to_string + + let is_default = Type.(unstage (equal N.metadata_t)) N.default + + let value_t = + let open Type in + record "node" (fun contents metadata node -> + match (contents, metadata, node) with + | Some c, None, None -> `Contents (c, N.default) + | Some c, Some m, None -> `Contents (c, m) + | None, None, Some n -> `Node n + | _ -> failwith "invalid node") + |+ field "contents" (option K.t) (function + | `Contents (x, _) -> Some x + | _ -> None) + |+ field "metadata" (option N.metadata_t) (function + | `Contents (_, x) when not (is_default x) -> Some x + | _ -> None) + |+ field "node" (option K.t) (function `Node n -> Some n | _ -> None) + |> sealr + + let t : t Type.t = + Type.map Type.(list ~len:`Int64 (pair step_t value_t)) of_list list +end diff --git a/vendors/irmin/irmin/node.mli b/vendors/irmin/irmin/node.mli new file mode 100644 index 000000000000..a10dda7e9468 --- /dev/null +++ b/vendors/irmin/irmin/node.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Node] provides functions to describe the graph-like structured values. + + The node blocks form a labeled directed acyclic graph, labeled by + {{!Path.S.step} steps}: a list of steps defines a unique path from one node + to an other. + + Each node can point to user-defined {{!Contents.S} contents} values. *) + +include Node_intf.Node +(** @inline *) diff --git a/vendors/irmin/irmin/node_intf.ml b/vendors/irmin/irmin/node_intf.ml new file mode 100644 index 000000000000..d237061c44d6 --- /dev/null +++ b/vendors/irmin/irmin/node_intf.ml @@ -0,0 +1,327 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open S + +module type S = sig + (** {1 Node values} *) + + type t [@@deriving irmin] + (** The type for node values. *) + + type metadata [@@deriving irmin] + (** The type for node metadata. *) + + type hash [@@deriving irmin] + (** The type for keys. *) + + type step [@@deriving irmin] + (** The type for steps between nodes. *) + + type value = [ `Node of hash | `Contents of hash * metadata ] + [@@deriving irmin] + (** The type for either (node) keys or (contents) keys combined with their + metadata. *) + + val of_list : (step * value) list -> t + (** [of_list l] is the node [n] such that [list n = l]. *) + + val list : + ?offset:int -> ?length:int -> ?cache:bool -> t -> (step * value) list + (** [list t] is the contents of [t]. [offset] and [length] are used to + paginate results. + + {2 caching} + + [cache] regulates the caching behaviour regarding the node's internal data + which may be lazily loaded from the backend, depending on the node + implementation. + + [cache] defaults to [true] which may greatly reduce the IOs and the + runtime but may also increase the memory consumption. + + [cache = false] doesn't replace a call to [clear], it only prevents the + storing of new data, it doesn't discard the existing one. *) + + val of_seq : (step * value) Seq.t -> t + (** [of_seq s] is the node [n] such that [seq n = s]. *) + + val seq : + ?offset:int -> ?length:int -> ?cache:bool -> t -> (step * value) Seq.t + (** [seq t] is the contents of [t]. [offset] and [length] are used to paginate + results. + + See {!caching} for an explanation of the [cache] parameter *) + + val empty : t + (** [empty] is the empty node. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty}. *) + + val length : t -> int + (** [length t] is the number of entries in [t]. *) + + val clear : t -> unit + (** Cleanup internal caches. *) + + val find : ?cache:bool -> t -> step -> value option + (** [find t s] is the value associated with [s] in [t]. + + A node can point to user-defined {{!Node.S.contents} contents}. The edge + between the node and the contents is labeled by a {{!Node.S.step} step}. + + See {!caching} for an explanation of the [cache] parameter *) + + val add : t -> step -> value -> t + (** [add t s v] is the node where [find t v] is [Some s] but is similar to [t] + otherwise. *) + + val remove : t -> step -> t + (** [remove t s] is the node where [find t s] is [None] but is similar to [t] + otherwise. *) + + val default : metadata + (** [default] is the default metadata value. *) + + (** {1 Proofs} *) + + type proof = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int list * proof) list ] + [@@deriving irmin] + (** The type for proof trees. *) + + val to_proof : t -> proof + val of_proof : proof -> t option + + exception Dangling_hash of { context : string; hash : hash } + + (** {1 Recursive Nodes} *) + + (** Some [Node] implementations (like [irmin-pack]'s inodes) can represent a + node as a set of nodes. One operation on such "high-level" node + corresponds to a sequence of recursive calls to the underlying + "lower-level" nodes. Note: theses [effects] are not in the Lwt monad on + purpose (so [Tree.hash] and [Tree.equal] are not in the Lwt monad as + well). *) + + type effect := expected_depth:int -> hash -> t option + (** The type for read effects. *) + + val with_handler : (effect -> effect) -> t -> t + (** [with_handler f] replace the current effect handler [h] by [f h]. [f h] + will be called for all the recursive read effects that are required by + recursive operations on nodes. .*) +end + +module type Maker = functor + (H : Hash.S) + (P : sig + type step [@@deriving irmin] + end) + (M : METADATA) + -> S with type metadata = M.t and type hash = H.t and type step = P.step + +module type STORE = sig + include CONTENT_ADDRESSABLE_STORE + + module Path : Path.S + (** [Path] provides base functions on node paths. *) + + val merge : [> read_write ] t -> key option Merge.t + (** [merge] is the 3-way merge function for nodes keys. *) + + (** [Key] provides base functions for node keys. *) + module Key : Hash.TYPED with type t = key and type value = value + + module Metadata : METADATA + (** [Metadata] provides base functions for node metadata. *) + + (** [Val] provides base functions for node values. *) + module Val : + S + with type t = value + and type hash = key + and type metadata = Metadata.t + and type step = Path.step + + module Contents : Contents.STORE with type key = Val.hash + (** [Contents] is the underlying contents store. *) +end + +module type GRAPH = sig + (** {1 Node Graphs} *) + + type 'a t + (** The type for store handles. *) + + type metadata + (** The type for node metadata. *) + + type contents + (** The type of user-defined contents. *) + + type node + (** The type for node values. *) + + type step + (** The type of steps. A step is used to pass from one node to another. *) + + type path + (** The type of store paths. A path is composed of {{!step} steps}. *) + + type value = [ `Node of node | `Contents of contents * metadata ] + (** The type for store values. *) + + val empty : [> write ] t -> node Lwt.t + (** The empty node. *) + + val v : [> write ] t -> (step * value) list -> node Lwt.t + (** [v t n] is a new node containing [n]. *) + + val list : [> read ] t -> node -> (step * value) list Lwt.t + (** [list t n] is the contents of the node [n]. *) + + val find : [> read ] t -> node -> path -> value option Lwt.t + (** [find t n p] is the contents of the path [p] starting form [n]. *) + + val add : [> read_write ] t -> node -> path -> value -> node Lwt.t + (** [add t n p v] is the node [x] such that [find t x p] is [Some v] and it + behaves the same [n] for other operations. *) + + val remove : [> read_write ] t -> node -> path -> node Lwt.t + (** [remove t n path] is the node [x] such that [find t x] is [None] and it + behhaves then same as [n] for other operations. *) + + val closure : [> read ] t -> min:node list -> max:node list -> node list Lwt.t + (** [closure t min max] is the unordered list of nodes [n] reachable from a + node of [max] along a path which: (i) either contains no [min] or (ii) it + ends with a [min]. + + {b Note:} Both [min] and [max] are subsets of [n]. *) + + val iter : + [> read ] t -> + min:node list -> + max:node list -> + ?node:(node -> unit Lwt.t) -> + ?contents:(contents -> unit Lwt.t) -> + ?edge:(node -> node -> unit Lwt.t) -> + ?skip_node:(node -> bool Lwt.t) -> + ?skip_contents:(contents -> bool Lwt.t) -> + ?rev:bool -> + unit -> + unit Lwt.t + (** [iter t min max node edge skip rev ()] iterates in topological order over + the closure of [t]. + + It applies the following functions while traversing the graph: [node] on + the nodes; [edge n predecessor_of_n] on the directed edges; [skip_node n] + to not include a node [n], its predecessors and the outgoing edges of [n] + and [skip_contents c] to not include content [c]. + + If [rev] is true (the default) then the graph is traversed in the reverse + order: [node n] is applied only after it was applied on all its + predecessors; [edge n p] is applied after [node n]. Note that [edge n p] + is applied even if [p] is skipped. *) + + (** {1 Value Types} *) + + val metadata_t : metadata Type.t + (** [metadat_t] is the value type for {!metadata}. *) + + val contents_t : contents Type.t + (** [contents_t] is the value type for {!contents}. *) + + val node_t : node Type.t + (** [node_t] is the value type for {!node}. *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) + + val path_t : path Type.t + (** [path_t] is the value type for {!path}. *) + + val value_t : value Type.t + (** [value_t] is the value type for {!value}. *) +end + +module type Node = sig + module type S = S + module type Maker = Maker + + module Make : Maker + (** [Make] provides a simple node implementation, parameterized by the + contents and notes keys [K], paths [P] and metadata [M]. *) + + (** v1 serialisation *) + module V1 (N : S with type step = string) : sig + include + S + with type hash = N.hash + and type step = N.step + and type metadata = N.metadata + + val import : N.t -> t + val export : t -> N.t + end + + module type STORE = STORE + (** [STORE] specifies the signature for node stores. *) + + (** [Store] creates node stores. *) + module Store + (C : Contents.STORE) + (P : Path.S) + (M : METADATA) (N : sig + include CONTENT_ADDRESSABLE_STORE with type key = C.key + module Key : Hash.S with type t = key + + module Val : + S + with type t = value + and type hash = key + and type metadata = M.t + and type step = P.step + end) : + STORE + with type 'a t = 'a C.t * 'a N.t + and type key = N.key + and type value = N.value + and module Path = P + and module Metadata = M + and type Key.t = N.key + and module Val = N.Val + + module type GRAPH = GRAPH + (** [Graph] specifies the signature for node graphs. A node graph is a + deterministic DAG, labeled by steps. *) + + module Graph (N : STORE) : + GRAPH + with type 'a t = 'a N.t + and type contents = N.Contents.key + and type metadata = N.Metadata.t + and type node = N.key + and type step = N.Path.step + and type path = N.Path.t + + module No_metadata : METADATA with type t = unit +end diff --git a/vendors/irmin/irmin/object_graph.ml b/vendors/irmin/irmin/object_graph.ml new file mode 100644 index 000000000000..aef597408a16 --- /dev/null +++ b/vendors/irmin/irmin/object_graph.ml @@ -0,0 +1,253 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Object_graph_intf + +let src = Logs.Src.create "irmin.graph" ~doc:"Irmin graph support" + +module Log = (val Logs.src_log src : Logs.LOG) + +let list_partition_map f t = + let rec aux fst snd = function + | [] -> (List.rev fst, List.rev snd) + | h :: t -> ( + match f h with + | `Fst x -> aux (x :: fst) snd t + | `Snd x -> aux fst (x :: snd) t) + in + aux [] [] t + +module Make (Hash : HASH) (Branch : Type.S) = struct + module X = struct + type t = + [ `Contents of Hash.t + | `Node of Hash.t + | `Commit of Hash.t + | `Branch of Branch.t ] + [@@deriving irmin] + + let equal = Type.(unstage (equal t)) + let compare = Type.(unstage (compare t)) + let hash_branch = Type.(unstage (short_hash Branch.t)) + + (* we are using cryptographic hashes here, so the first bytes + are good enough to be used as short hashes. *) + let hash (t : t) : int = + match t with + | `Contents c -> Hash.short_hash c + | `Node n -> Hash.short_hash n + | `Commit c -> Hash.short_hash c + | `Branch b -> hash_branch b + end + + module G = Graph.Imperative.Digraph.ConcreteBidirectional (X) + module GO = Graph.Oper.I (G) + module Topological = Graph.Topological.Make (G) + + module Table : sig + type t + + val create : int option -> t + val add : t -> X.t -> int -> unit + val mem : t -> X.t -> bool + end = struct + module Lru = Lru.Make (X) + module Tbl = Hashtbl.Make (X) + + type t = L of int Lru.t | T of int Tbl.t + + let create = function + | None -> T (Tbl.create 1024) + | Some n -> L (Lru.create n) + + let add t k v = match t with L t -> Lru.add t k v | T t -> Tbl.add t k v + let mem t k = match t with L t -> Lru.mem t k | T t -> Tbl.mem t k + end + + module Set = Set.Make (X) + include G + include GO + + type dump = vertex list * (vertex * vertex) list + + (* XXX: for the binary format, we can use offsets in the vertex list + to save space. *) + module Dump = struct + type t = X.t list * (X.t * X.t) list [@@deriving irmin] + end + + let vertex g = G.fold_vertex (fun k set -> k :: set) g [] + let edges g = G.fold_edges (fun k1 k2 list -> (k1, k2) :: list) g [] + let pp_vertices = Fmt.Dump.list (Type.pp X.t) + let pp_depth ppf d = if d <> max_int then Fmt.pf ppf "depth=%d,@ " d + + type action = Visit of (X.t * int) | Treat of X.t + + let iter ?cache_size ?(depth = max_int) ~pred ~min ~max ~node ?edge ~skip ~rev + () = + Log.debug (fun f -> + f "@[<2>iter:@ %arev=%b,@ min=%a,@ max=%a@, cache=%a@]" pp_depth depth + rev pp_vertices min pp_vertices max + Fmt.(Dump.option int) + cache_size); + let marks = Table.create cache_size in + let mark key level = Table.add marks key level in + let todo = Stack.create () in + (* if a branch is in [min], add the commit it is pointing to too. *) + let* min = + Lwt_list.fold_left_s + (fun acc -> function + | `Branch _ as x -> pred x >|= fun c -> (x :: c) @ acc + | x -> Lwt.return (x :: acc)) + [] min + in + let min = Set.of_list min in + let has_mark key = Table.mem marks key in + List.iter (fun k -> Stack.push (Visit (k, 0)) todo) max; + let treat key = + Log.debug (fun f -> f "TREAT %a" Type.(pp X.t) key); + node key >>= fun () -> + if not (Set.mem key min) then + (* the edge function is optional to prevent an unnecessary computation + of the preds .*) + match edge with + | None -> Lwt.return_unit + | Some edge -> + let* keys = pred key in + Lwt_list.iter_p (fun k -> edge key k) keys + else Lwt.return_unit + in + let visit_predecessors ~filter_history key level = + let+ keys = pred key in + (*if a commit is in [min] cut the history but still visit + its nodes. *) + List.iter + (function + | `Commit _ when filter_history -> () + | k -> Stack.push (Visit (k, level + 1)) todo) + keys + in + let visit key level = + if level >= depth then Lwt.return_unit + else if has_mark key then Lwt.return_unit + else + skip key >>= function + | true -> Lwt.return_unit + | false -> + let+ () = + Log.debug (fun f -> f "VISIT %a %d" Type.(pp X.t) key level); + mark key level; + if rev then Stack.push (Treat key) todo; + match key with + | `Commit _ -> + visit_predecessors ~filter_history:(Set.mem key min) key level + | _ -> + if Set.mem key min then Lwt.return_unit + else visit_predecessors ~filter_history:false key level + in + if not rev then Stack.push (Treat key) todo + in + let rec pop () = + match Stack.pop todo with + | exception Stack.Empty -> Lwt.return_unit + | Treat key -> treat key >>= pop + | Visit (key, level) -> visit key level >>= pop + in + pop () + + let closure ?(depth = max_int) ~pred ~min ~max () = + let g = G.create ~size:1024 () in + List.iter (G.add_vertex g) max; + let node key = + if not (G.mem_vertex g key) then G.add_vertex g key else (); + Lwt.return_unit + in + let edge node pred = + G.add_edge g pred node; + Lwt.return_unit + in + let skip _ = Lwt.return_false in + iter ~depth ~pred ~min ~max ~node ~edge ~skip ~rev:false () >|= fun () -> g + + let min g = + G.fold_vertex + (fun v acc -> if G.in_degree g v = 0 then v :: acc else acc) + g [] + + let max g = + G.fold_vertex + (fun v acc -> if G.out_degree g v = 0 then v :: acc else acc) + g [] + + let vertex_attributes = ref (fun _ -> []) + let edge_attributes = ref (fun _ -> []) + let graph_name = ref None + + module Dot = Graph.Graphviz.Dot (struct + include G + + let edge_attributes k = !edge_attributes k + let default_edge_attributes _ = [] + + let vertex_name k = + let str t v = "\"" ^ Type.to_string t v ^ "\"" in + match k with + | `Node n -> str Hash.t n + | `Commit c -> str Hash.t c + | `Contents c -> str Hash.t c + | `Branch b -> str Branch.t b + + let vertex_attributes k = !vertex_attributes k + let default_vertex_attributes _ = [] + let get_subgraph _ = None + + let graph_attributes _ = + match !graph_name with None -> [] | Some n -> [ `Label n ] + end) + + let export t = (vertex t, edges t) + + let import (vs, es) = + let g = G.create ~size:(List.length vs) () in + List.iter (G.add_vertex g) vs; + List.iter (fun (v1, v2) -> G.add_edge g v1 v2) es; + g + + let output ppf vertex edges name = + Log.debug (fun f -> f "output %s" name); + let g = G.create ~size:(List.length vertex) () in + List.iter (fun (v, _) -> G.add_vertex g v) vertex; + List.iter (fun (v1, _, v2) -> G.add_edge g v1 v2) edges; + let eattrs (v1, v2) = + try + let l = List.filter (fun (x, _, y) -> x = v1 && y = v2) edges in + let l = List.fold_left (fun acc (_, l, _) -> l @ acc) [] l in + let labels, others = + list_partition_map (function `Label l -> `Fst l | x -> `Snd x) l + in + match labels with + | [] -> others + | [ l ] -> `Label l :: others + | _ -> `Label (String.concat "," labels) :: others + with Not_found -> [] + in + let vattrs v = try List.assoc v vertex with Not_found -> [] in + vertex_attributes := vattrs; + edge_attributes := eattrs; + graph_name := Some name; + Dot.fprint_graph ppf g +end diff --git a/vendors/irmin/irmin/object_graph.mli b/vendors/irmin/irmin/object_graph.mli new file mode 100644 index 000000000000..cf87816ad9e0 --- /dev/null +++ b/vendors/irmin/irmin/object_graph.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Graphs. *) + +include Object_graph_intf.Object_graph diff --git a/vendors/irmin/irmin/object_graph_intf.ml b/vendors/irmin/irmin/object_graph_intf.ml new file mode 100644 index 000000000000..b7bc944703ac --- /dev/null +++ b/vendors/irmin/irmin/object_graph_intf.ml @@ -0,0 +1,124 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Graph.Sig.I + (** Directed graph *) + + include Graph.Oper.S with type g := t + (** Basic operations. *) + + (** Topological traversal *) + module Topological : sig + val fold : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + end + + val vertex : t -> vertex list + (** Get all the vertices. *) + + val edges : t -> (vertex * vertex) list + (** Get all the relations. *) + + val closure : + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + unit -> + t Lwt.t + (** [closure depth pred min max ()] creates the transitive closure graph of + [max] using the predecessor relation [pred]. The graph is bounded by the + [min] nodes and by [depth]. + + {b Note:} Both [min] and [max] are subsets of [n]. *) + + val iter : + ?cache_size:int -> + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + node:(vertex -> unit Lwt.t) -> + ?edge:(vertex -> vertex -> unit Lwt.t) -> + skip:(vertex -> bool Lwt.t) -> + rev:bool -> + unit -> + unit Lwt.t + (** [iter depth min max node edge skip rev ()] iterates in topological order + over the closure graph starting with the [max] nodes and bounded by the + [min] nodes and by [depth]. + + It applies three functions while traversing the graph: [node] on the + nodes; [edge n predecessor_of_n] on the directed edges and [skip n] to not + include a node [n], its predecessors and the outgoing edges of [n]. + + If [rev] is true (the default) then the graph is traversed in the reverse + order: [node n] is applied only after it was applied on all its + predecessors; [edge n p] is applied after [node n]. Note that [edge n p] + is applied even if [p] is skipped. + + [cache_size] is the size of the LRU cache used to store nodes already + seen. If [None] (by default) every traversed nodes is stored (and thus no + entries are never removed from the LRU). *) + + val output : + Format.formatter -> + (vertex * Graph.Graphviz.DotAttributes.vertex list) list -> + (vertex * Graph.Graphviz.DotAttributes.edge list * vertex) list -> + string -> + unit + (** [output ppf vertex edges name] create aand dumps the graph contents on + [ppf]. The graph is defined by its [vertex] and [edges]. [name] is the + name of the output graph.*) + + val min : t -> vertex list + (** Compute the minimum vertex. *) + + val max : t -> vertex list + (** Compute the maximun vertex. *) + + type dump = vertex list * (vertex * vertex) list + (** Expose the graph internals. *) + + val export : t -> dump + (** Expose the graph as a pair of vertices and edges. *) + + val import : dump -> t + (** Import a graph. *) + + module Dump : Type.S with type t = dump + (** The base functions over graph internals. *) +end + +module type HASH = sig + include Type.S + + val short_hash : t -> int +end + +module type Object_graph = sig + module type S = S + module type HASH = HASH + + (** Build a graph. *) + module Make (Hash : HASH) (Branch : Type.S) : + S + with type V.t = + [ `Contents of Hash.t + | `Node of Hash.t + | `Commit of Hash.t + | `Branch of Branch.t ] +end diff --git a/vendors/irmin/irmin/path.ml b/vendors/irmin/irmin/path.ml new file mode 100644 index 000000000000..c1c8c61e7b7f --- /dev/null +++ b/vendors/irmin/irmin/path.ml @@ -0,0 +1,48 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Astring +include Path_intf + +module String_list = struct + type step = string [@@deriving irmin] + type t = step list + + let empty = [] + let is_empty l = l = [] + let cons s t = s :: t + let rcons t s = t @ [ s ] + let decons = function [] -> None | h :: t -> Some (h, t) + + let rdecons l = + match List.rev l with [] -> None | h :: t -> Some (List.rev t, h) + + let map l f = List.map f l + let v x = x + + let pp ppf t = + let len = List.fold_left (fun acc s -> 1 + acc + String.length s) 1 t in + let buf = Buffer.create len in + List.iter + (fun s -> + Buffer.add_char buf '/'; + Buffer.add_string buf s) + t; + Fmt.string ppf (Buffer.contents buf) + + let of_string s = Ok (List.filter (( <> ) "") (String.cuts s ~sep:"/")) + let t = Type.like ~pp ~of_string Type.(list step_t) +end diff --git a/vendors/irmin/irmin/path.mli b/vendors/irmin/irmin/path.mli new file mode 100644 index 000000000000..834fefed7335 --- /dev/null +++ b/vendors/irmin/irmin/path.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Tree path handling. *) + +include Path_intf.Path +(** @inline *) diff --git a/vendors/irmin/irmin/path_intf.ml b/vendors/irmin/irmin/path_intf.ml new file mode 100644 index 000000000000..045d191a2dab --- /dev/null +++ b/vendors/irmin/irmin/path_intf.ml @@ -0,0 +1,67 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Path} *) + + type t + (** The type for path values. *) + + type step + (** Type type for path's steps. *) + + val empty : t + (** The empty path. *) + + val v : step list -> t + (** Create a path from a list of steps. *) + + val is_empty : t -> bool + (** Check if the path is empty. *) + + val cons : step -> t -> t + (** Prepend a step to the path. *) + + val rcons : t -> step -> t + (** Append a step to the path. *) + + val decons : t -> (step * t) option + (** Deconstruct the first element of the path. Return [None] if the path is + empty. *) + + val rdecons : t -> (t * step) option + (** Deconstruct the last element of the path. Return [None] if the path is + empty. *) + + val map : t -> (step -> 'a) -> 'a list + (** [map t f] maps [f] over all steps of [t]. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) +end + +module type Path = sig + module type S = S + (** Signature for path implementations.*) + + (** An implementation of paths as string lists. *) + module String_list : S with type step = string and type t = string list +end diff --git a/vendors/irmin/irmin/perms.ml b/vendors/irmin/irmin/perms.ml new file mode 100644 index 000000000000..de4ddb4911dc --- /dev/null +++ b/vendors/irmin/irmin/perms.ml @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Types representing {i permissions} ['perms] for performing operations on a + certain type ['perms t]. + + They are intended to be used as phantom parameters of the types that they + control access to. As an example, consider the following type of references + with permissions: + + {[ + module Ref : sig + type (+'a, -'perms) t + + val create : 'a -> ('a, read_write) t + val get : ('a, [> read ]) t -> 'a + val set : ('a, [> write ]) t -> 'a -> unit + end + ]} + + This type allows references to be created with arbitrary read-write access. + One can then create weaker views onto the reference – with access to fewer + operations – by upcasting: + + {[ + let read_only t = (t :> (_, read) Ref.t) + let write_only t = (t :> (_, write) Ref.t) + ]} + + Note that the ['perms] phantom type parameter should be contravariant: it's + safe to discard permissions, but not to gain new ones. *) + +module Read = struct + type t = [ `Read ] +end + +module Write = struct + type t = [ `Write ] +end + +module Read_write = struct + type t = [ Read.t | Write.t ] +end + +type read = Read.t +(** The type parameter of a handle with [read] permissions. *) + +type write = Write.t +(** The type parameter of a handle with [write] permissions. *) + +type read_write = Read_write.t +(** The type parameter of a handle with both {!read} and {!write} permissions. *) diff --git a/vendors/irmin/irmin/private.ml b/vendors/irmin/irmin/private.ml new file mode 100644 index 000000000000..77ff65cb868a --- /dev/null +++ b/vendors/irmin/irmin/private.ml @@ -0,0 +1,73 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open S.Store_properties + +module type S = sig + module Hash : Hash.S + (** Internal hashes. *) + + module Contents : Contents.STORE with type key = Hash.t + (** Private content store. *) + + module Node : Node.STORE with type key = Hash.t + (** Private node store. *) + + module Commit : Commit.STORE with type key = Hash.t + (** Private commit store. *) + + module Branch : Branch.STORE with type value = Hash.t + (** Private branch store. *) + + (** Private slices. *) + module Slice : + Slice.S + with type contents = Contents.key * Contents.value + and type node = Node.key * Node.value + and type commit = Commit.key * Commit.value + + (** Private repositories. *) + module Repo : sig + type t + + include OF_CONFIG with type _ t := t + (** @inline *) + + include CLOSEABLE with type _ t := t + (** @inline *) + + val contents_t : t -> read Contents.t + val node_t : t -> read Node.t + val commit_t : t -> read Commit.t + val branch_t : t -> Branch.t + + val batch : + t -> + (read_write Contents.t -> + read_write Node.t -> + read_write Commit.t -> + 'a Lwt.t) -> + 'a Lwt.t + end + + (** URI-based low-level sync. *) + module Sync : sig + include Sync.S with type commit = Commit.key and type branch = Branch.key + + val v : Repo.t -> t Lwt.t + end +end diff --git a/vendors/irmin/irmin/proof.ml b/vendors/irmin/irmin/proof.ml new file mode 100644 index 000000000000..19c6c83d83e8 --- /dev/null +++ b/vendors/irmin/irmin/proof.ml @@ -0,0 +1,209 @@ +(* + * Copyright (c) 2013-2021 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Proof_intf + +module Make + (C : Type.S) + (H : Type.S) (S : sig + type step [@@deriving irmin] + end) + (M : Type.S) = +struct + type contents = C.t [@@deriving irmin] + type hash = H.t [@@deriving irmin] + type step = S.step [@@deriving irmin] + type metadata = M.t [@@deriving irmin] + + type 'a inode = { length : int; proofs : (int list * 'a) list } + [@@deriving irmin] + + type kinded_hash = [ `Node of hash | `Contents of hash * metadata ] + [@@deriving irmin] + + type tree = + | Blinded_node of hash + | Node of (step * tree) list + | Inode of tree inode + | Blinded_contents of hash * metadata + | Contents of contents * metadata + [@@deriving irmin] + + type t = { before : kinded_hash; after : kinded_hash; state : tree } + [@@deriving irmin] + + let before t = t.before + let after t = t.after + let state t = t.state + let v ~before ~after state = { after; before; state } +end + +exception Bad_proof of { context : string } + +let bad_proof_exn context = raise (Bad_proof { context }) + +module Env (H : Hash.S) (C : Contents.S) (N : Node.S with type hash = H.t) = +struct + module Hashes = struct + include Hashtbl.Make (struct + type t = H.t + + let hash = H.short_hash + let equal = Type.(unstage (equal H.t)) + end) + + let of_list l = of_seq (List.to_seq l) + let to_list t = List.of_seq (to_seq t) + let t elt_t = Type.map [%typ: (H.t * elt) list] of_list to_list + end + + (* Keep track of read effects happening during a computation using + sets. This does not keep track of the ordering of the reads. *) + type read_set = { nodes : N.t Hashes.t; contents : C.t Hashes.t } + [@@deriving irmin] + + type mode = Produce | Serialise | Deserialise | Consume [@@deriving irmin] + type set_effects = { mode : mode; set : read_set } [@@deriving irmin] + type v = Empty | Set of set_effects [@@deriving irmin] + type t = v ref + + let t = Type.map v_t ref ( ! ) + let empty () : t = ref Empty + let is_empty t = !t = Empty + let empty_set () = { contents = Hashes.create 13; nodes = Hashes.create 13 } + let copy ~into t = into := !t + let mode t = match !t with Empty -> None | Set { mode; _ } -> Some mode + + let to_mode t mode = + match (!t, mode) with + | Empty, Produce | Empty, Deserialise -> + let set = empty_set () in + t := Set { mode; set } + | Set { mode = Produce; set }, Serialise + | Set { mode = Deserialise; set }, Consume -> + t := Set { mode; set } + | _ -> assert false + + let with_mode t mode f = + let before = !t in + to_mode t mode; + let+ res = f () in + t := before; + res + + let find_contents t h = + match !t with + | Empty -> None + | Set { mode = Produce; set } -> + (* Sharing of contents is not strictly needed during this phase. It + could be disabled. *) + Hashes.find_opt set.contents h + | Set { mode = Serialise; set } -> + (* This is needed in order to differenciate between blinded contents + from others. *) + Hashes.find_opt set.contents h + | Set { mode = Deserialise; _ } -> + (* This phase only fills the env, it should search for anything *) + assert false + | Set { mode = Consume; set } -> + (* This is needed in order to read non-blinded contents. *) + Hashes.find_opt set.contents h + + let add_contents_from_store t h v = + match !t with + | Empty -> () + | Set { mode = Produce; set } -> + (* Registering in [set] for traversal during [Serialise]. *) + assert (not (Hashes.mem set.contents h)); + Hashes.add set.contents h v + | Set { mode = Serialise; _ } -> + (* There shouldn't be new contents during this phase *) + assert false + | Set { mode = Deserialise; _ } -> + (* This phase has no repo pointer *) + assert false + | Set { mode = Consume; _ } -> + (* This phase has no repo pointer *) + assert false + + let find_node t h = + match !t with + | Empty -> None + | Set { mode = Produce; set } -> + (* This is needed in order to achieve sharing on inode's pointers. In + other words, each node present in the [before] tree should have a + single [P.Node.Val.t] representative that will witness all the lazy + inode loadings. *) + Hashes.find_opt set.nodes h + | Set { mode = Serialise; set } -> + (* This is needed in order to follow loaded paths in the [before] + tree. *) + Hashes.find_opt set.nodes h + | Set { mode = Deserialise; _ } -> + (* This phase only fills the env, it should search for anything *) + assert false + | Set { mode = Consume; set } -> + (* This is needed in order to read non-blinded nodes. *) + Hashes.find_opt set.nodes h + + let add_contents_from_proof t h v = + match !t with + | Set { mode = Deserialise; set } -> + (* Using [replace] because there could be several instances of this + contents in the proof, we will not share as this is not strictly + needed. *) + Hashes.replace set.contents h v + | _ -> assert false + + let add_node_from_store t h v = + match !t with + | Empty -> () + | Set { mode = Produce; set } -> + (* Registering in [set] for sharing during [Produce] and traversal + during [Serialise]. *) + assert (not (Hashes.mem set.nodes h)); + Hashes.add set.nodes h v + | Set { mode = Serialise; _ } -> + (* There shouldn't be new nodes during this phase *) + assert false + | Set { mode = Deserialise; _ } -> + (* This phase has no repo pointer *) + assert false + | Set { mode = Consume; _ } -> + (* This phase has no repo pointer *) + assert false + + let add_node_from_proof t h v = + match !t with + | Set { mode = Deserialise; set } -> + (* Using [replace] because there could be several instances of this + node in the proof, we will not share as this is not strictly + needed. + All the occurences of this node in the proof are expected to have + the same blinded/visible coverage (i.e. the same node proof). *) + Hashes.replace set.nodes h v + | _ -> assert false + + (* x' = y' <- x union y *) + let merge (x : t) (y : t) = + match (!x, !y) with + | Empty, Empty -> () + | Empty, y -> x := y + | x, Empty -> y := x + | Set _, Set _ -> + failwith "Merging two non-empty [Proof.Env.t] is forbidden" +end diff --git a/vendors/irmin/irmin/proof.mli b/vendors/irmin/irmin/proof.mli new file mode 100644 index 000000000000..c2b397ac478d --- /dev/null +++ b/vendors/irmin/irmin/proof.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2021 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Proof_intf.Proof diff --git a/vendors/irmin/irmin/proof_intf.ml b/vendors/irmin/irmin/proof_intf.ml new file mode 100644 index 000000000000..61767e866414 --- /dev/null +++ b/vendors/irmin/irmin/proof_intf.ml @@ -0,0 +1,220 @@ +(* + * Copyright (c) 2013-2021 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + type contents + type hash + type step + type metadata + + (** Proofs are compact representations of Irmin [trees] which can be shared + between an Irmin node and a client. + + The protocol is the following: + + - The Irmin node runs a function [f] over a tree [t]. While performing + this computation, the node records: the hash of [t] (called [before] + below), the hash of [f t] (called [after] below) and a subset of [t] + which is needed to replay [f] without any access to the node's storage. + Once done, the node packs this into a proof [p] and sends this to the + client. + + - The client generates an initial tree [t'] from [p] and computes [f t']. + Once done, it compares [t']'s hash and [f t']'s hash to [before] and + [after]. If they match, they know that the result state [f t'] is a + valid state of Irmin, without having to have access to the full node's + storage. *) + + type 'a inode = { length : int; proofs : (int list * 'a) list } + [@@deriving irmin] + (** The type for (internal) inode proofs. + + These proofs encode large directories into a more efficient tree-like + structure. + + Invariant are dependent on the backend. + + [length] is the total number of entries in the chidren of the inode. E.g. + the size of the "flattened" version of that inode. This is used by some + backend (like [irmin-pack]) to efficiently implements paginated lists. + + Paths of singleton inodes are compacted into a single inode addressed by + that path (hence the [int list] indexing). + + {e For [irmin-pack]}: [proofs] have a length of at most [Conf.entries] + entries. This list can be sparse so every proof is indexed by their + position between [0 ... (Conf.entries-1)]. For binary trees, this boolean + index is a step of the left-right sequence / decision proof corresponding + to the path in that binary tree. *) + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proofs. + + [Blinded_node h] is a shallow pointer to a node having hash [h]. + + [Node ls] is a "flat" node containing the list of files [ls]. The length + of [ls] depends on the backend. For instance, it can be unbounded for most + of the backends, while it is at most [Conf.stable_hash] entries for + [irmin-pack]. + + [Inode i] is an optimized representation of a node as a tree. Pointers in + that trees would refer to blinded nodes, nodes or to other inodes. E.g. + Blinded content is not expected to appear directly in an inodes. + + [Blinded_contents (h, m)] is a shallow pointer to contents having hash [h] + and metadata [m]. + + [Contents c] is the contents [c]. *) + type tree = + | Blinded_node of hash + | Node of (step * tree) list + | Inode of tree inode + | Blinded_contents of hash * metadata + | Contents of contents * metadata + [@@deriving irmin] + + type t [@@deriving irmin] + (** The type for proofs. *) + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + (** The type for kinded hashes. *) + + val v : before:kinded_hash -> after:kinded_hash -> tree -> t + (** [v ~before ~after p] proves that the state advanced from [before] to + [after]. [p]'s hash is [before], and [p] contains the minimal information + for the computation to reach [after]. *) + + val before : t -> kinded_hash + (** [before t] it the state's hash at the beginning of the computation. *) + + val after : t -> kinded_hash + (** [after t] is the state's hash at the end of the computation. *) + + val state : t -> tree + (** [proof t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) +end + +(** Environment that tracks side effects during the production/consumption of + proofs. + + {1 The merkle proof construction algorithm} + + This description assumes that the large nodes are represented by the backend + as a tree structure (i.e. inodes). There are 4 distinct phases when working + with Irmin's merkle proofs: [Produce | Serialise | Deserialise | Consume]. + + {2 [Produce]} + + In this phase the Irmin user builds an [after] tree from a [before] tree + that has been setup with an [Env] that records every backend reads into two + hash tables. + + During the next phase (i.e. [Serialise]) the cleared [before] tree will be + traversed from root to stems only following the paths that are referenced in + [Env]. + + In practice [Env] doesn't exactly records the reads, it keeps track of all + the [hash -> backend node] and [hash -> backend contents] mappings that are + directly output of the backend stores through [P.Node.find] and + [P.Contents.find]. This is obviously enough to remember the contents, the + nodes and the inodes tips, but the inner inodes are not directly referenced + in the hash tables. + + The inner inodes are in fact referenced in their inode tip which is itself + referenced in [Env]'s hash tables. Since an inode shares its lazy pointers + with the inodes derived from it, even the inner inodes that are loaded from + the derived tips will be available from the original inode tip. + + {2 [Serialise]} + + In this phase the [Env] contains everything necessary for the computation of + a merkle proof from a cleared [before]. The [Env] now affects + [Node.cached_value] and [Contents.cached_value] allowing for the discovery + of the cached closure. + + {2 [Deserialise]} + + In this phase the [Env] is filled by recursively destructing the proof and + filling it before the [Consume] phase. + + {2 [Consume]} + + In this last phase the [Env] is again made accessible through + [Node.cached_value] and [Contents.cached_value], making it possible for the + user to reference by [hash] everything that was contained in the proof. *) +module type Env = sig + type mode = Produce | Serialise | Deserialise | Consume + type v + type t + type hash + type node + type contents + + val t : t Type.ty + val is_empty : t -> bool + val merge : t -> t -> unit + + (** {2 Construction of envs} *) + + val empty : unit -> t + val copy : into:t -> t -> unit + + (** {2 Modes} *) + + val mode : t -> mode option + val to_mode : t -> mode -> unit + val with_mode : t -> mode -> (unit -> 'a Lwt.t) -> 'a Lwt.t + + (** {2 In/out backend objects with [Tree]} *) + + val add_contents_from_store : t -> hash -> contents -> unit + val add_node_from_store : t -> hash -> node -> unit + val add_contents_from_proof : t -> hash -> contents -> unit + val add_node_from_proof : t -> hash -> node -> unit + val find_contents : t -> hash -> contents option + val find_node : t -> hash -> node option +end + +module type Proof = sig + module type S = S + module type Env = Env + + exception Bad_proof of { context : string } + + val bad_proof_exn : string -> 'a + + module Make + (C : Type.S) + (H : Hash.S) (P : sig + type step [@@deriving irmin] + end) + (M : Type.S) : sig + include + S + with type contents := C.t + and type hash := H.t + and type step := P.step + and type metadata := M.t + end + + module Env (H : Hash.S) (C : Contents.S) (N : Node.S with type hash = H.t) : + Env with type hash := H.t and type contents := C.t and type node := N.t +end diff --git a/vendors/irmin/irmin/s.ml b/vendors/irmin/irmin/s.ml new file mode 100644 index 000000000000..d36777b103ee --- /dev/null +++ b/vendors/irmin/irmin/s.ml @@ -0,0 +1,226 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Irmin signatures *) + +open! Import + +type config = Conf.t + +module Store_properties = struct + module type BATCH = sig + type 'a t + + val batch : read t -> ([ read | write ] t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the writes in [f] in a separate batch. The exact + guarantees depend on the implementation. *) + end + + module type CLOSEABLE = sig + type 'a t + + val close : 'a t -> unit Lwt.t + (** [close t] frees up all the resources associated with [t]. Any operations + run on a closed handle will raise {!Closed}. *) + end + + module type OF_CONFIG = sig + type 'a t + + val v : config -> read t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) + end + + module type CLEARABLE = sig + type 'a t + + val clear : 'a t -> unit Lwt.t + (** Clear the store. This operation is expected to be slow. *) + end +end + +open Store_properties + +module type CONTENT_ADDRESSABLE_STORE = sig + (** {1 Content-addressable stores} + + Content-addressable stores are store where it is possible to read and add + new values. Keys are derived from the values raw contents and hence are + deterministic. *) + + type -'a t + (** The type for content-addressable backend stores. The ['a] phantom type + carries information about the store mutability. *) + + type key + (** The type for keys. *) + + type value + (** The type for raw values. *) + + val mem : [> read ] t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : [> read ] t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is + [k] is not present in [t]. *) + + val add : [> write ] t -> value -> key Lwt.t + (** Write the contents of a value to the store. It's the responsibility of the + content-addressable store to generate a consistent key. *) + + val unsafe_add : [> write ] t -> key -> value -> unit Lwt.t + (** Same as {!add} but allows to specify the key directly. The backend might + choose to discared that key and/or can be corrupt if the key scheme is not + consistent. *) + + include CLEARABLE with type 'a t := 'a t +end + +module type CONTENT_ADDRESSABLE_STORE_MAKER = functor + (K : Hash.S) + (V : Type.S) + -> sig + include CONTENT_ADDRESSABLE_STORE with type key = K.t and type value = V.t + include BATCH with type 'a t := 'a t + include OF_CONFIG with type 'a t := 'a t + include CLOSEABLE with type 'a t := 'a t +end + +module type APPEND_ONLY_STORE = sig + (** {1 Append-only stores} + + Append-onlye stores are store where it is possible to read and add new + values. *) + + type -'a t + (** The type for append-only backend stores. The ['a] phantom type carries + information about the store mutability. *) + + type key + (** The type for keys. *) + + type value + (** The type for raw values. *) + + val mem : [> read ] t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : [> read ] t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is + [k] is not present in [t]. *) + + val add : [> write ] t -> key -> value -> unit Lwt.t + (** Write the contents of a value to the store. *) + + include CLEARABLE with type 'a t := 'a t +end + +module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include APPEND_ONLY_STORE with type key = K.t and type value = V.t + include BATCH with type 'a t := 'a t + include OF_CONFIG with type 'a t := 'a t + include CLOSEABLE with type 'a t := 'a t +end + +module type METADATA = sig + type t [@@deriving irmin] + (** The type for metadata. *) + + val merge : t Merge.t + (** [merge] is the merge function for metadata. *) + + val default : t + (** The default metadata to attach, for APIs that don't care about metadata. *) +end + +type 'a diff = 'a Diff.t + +module type ATOMIC_WRITE_STORE = sig + (** {1 Atomic write stores} + + Atomic-write stores are stores where it is possible to read, update and + remove elements, with atomically guarantees. *) + + type t + (** The type for atomic-write backend stores. *) + + type key + (** The type for keys. *) + + type value + (** The type for raw values. *) + + val mem : t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is + [k] is not present in [t]. *) + + val set : t -> key -> value -> unit Lwt.t + (** [set t k v] replaces the contents of [k] by [v] in [t]. If [k] is not + already defined in [t], create a fresh binding. Raise [Invalid_argument] + if [k] is the {{!Path.empty} empty path}. *) + + val test_and_set : + t -> key -> test:value option -> set:value option -> bool Lwt.t + (** [test_and_set t key ~test ~set] sets [key] to [set] only if the current + value of [key] is [test] and in that case returns [true]. If the current + value of [key] is different, it returns [false]. [None] means that the + value does not have to exist or is removed. + + {b Note:} The operation is guaranteed to be atomic. *) + + val remove : t -> key -> unit Lwt.t + (** [remove t k] remove the key [k] in [t]. *) + + val list : t -> key list Lwt.t + (** [list t] it the list of keys in [t]. *) + + type watch + (** The type of watch handlers. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch t ?init f] adds [f] to the list of [t]'s watch handlers and returns + the watch handler to be used with {!unwatch}. [init] is the optional + initial values. It is more efficient to use {!watch_key} to watch only a + single given key.*) + + val watch_key : + t -> key -> ?init:value -> (value diff -> unit Lwt.t) -> watch Lwt.t + (** [watch_key t k ?init f] adds [f] to the list of [t]'s watch handlers for + the key [k] and returns the watch handler to be used with {!unwatch}. + [init] is the optional initial value of the key. *) + + val unwatch : t -> watch -> unit Lwt.t + (** [unwatch t w] removes [w] from [t]'s watch handlers. *) + + include CLOSEABLE with type _ t := t + include CLEARABLE with type _ t := t +end + +module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include ATOMIC_WRITE_STORE with type key = K.t and type value = V.t + include OF_CONFIG with type _ t := t +end + +type remote = .. diff --git a/vendors/irmin/irmin/slice.ml b/vendors/irmin/irmin/slice.ml new file mode 100644 index 000000000000..337ebfe7469c --- /dev/null +++ b/vendors/irmin/irmin/slice.ml @@ -0,0 +1,58 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Slice_intf + +module Make + (Contents : Contents.STORE) + (Node : Node.STORE) + (Commit : Commit.STORE) = +struct + type contents = Contents.Key.t * Contents.Val.t [@@deriving irmin] + type node = Node.Key.t * Node.Val.t [@@deriving irmin] + type commit = Commit.Key.t * Commit.Val.t [@@deriving irmin] + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + [@@deriving irmin] + + type t = { + mutable contents : contents list; + mutable nodes : node list; + mutable commits : commit list; + } + [@@deriving irmin] + + let empty () = Lwt.return { contents = []; nodes = []; commits = [] } + + let add t = function + | `Contents c -> + t.contents <- c :: t.contents; + Lwt.return_unit + | `Node n -> + t.nodes <- n :: t.nodes; + Lwt.return_unit + | `Commit c -> + t.commits <- c :: t.commits; + Lwt.return_unit + + let iter t f = + Lwt.join + [ + Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; + Lwt_list.iter_p (fun n -> f (`Node n)) t.nodes; + Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits; + ] +end diff --git a/vendors/irmin/irmin/slice.mli b/vendors/irmin/irmin/slice.mli new file mode 100644 index 000000000000..84637dcb691d --- /dev/null +++ b/vendors/irmin/irmin/slice.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Slice_intf.Slice +(** @inline *) diff --git a/vendors/irmin/irmin/slice_intf.ml b/vendors/irmin/irmin/slice_intf.ml new file mode 100644 index 000000000000..23e50c1254e3 --- /dev/null +++ b/vendors/irmin/irmin/slice_intf.ml @@ -0,0 +1,72 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Slices} *) + + type t + (** The type for slices. *) + + type contents + (** The type for exported contents. *) + + type node + (** The type for exported nodes. *) + + type commit + (** The type for exported commits. *) + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + (** The type for exported values. *) + + val empty : unit -> t Lwt.t + (** Create a new empty slice. *) + + val add : t -> value -> unit Lwt.t + (** [add t v] adds [v] to [t]. *) + + val iter : t -> (value -> unit Lwt.t) -> unit Lwt.t + (** [iter t f] calls [f] on all values of [t]. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val contents_t : contents Type.t + (** [content_t] is the value type for {!contents}. *) + + val node_t : node Type.t + (** [node_t] is the value type for {!node}. *) + + val commit_t : commit Type.t + (** [commit_t] is the value type for {!commit}. *) + + val value_t : value Type.t + (** [value_t] is the value type for {!value}. *) +end + +module type Slice = sig + module type S = S + (** The signature for slices. *) + + (** Build simple slices. *) + module Make (C : Contents.STORE) (N : Node.STORE) (H : Commit.STORE) : + S + with type contents = C.key * C.value + and type node = N.key * N.value + and type commit = H.key * H.value +end diff --git a/vendors/irmin/irmin/store.ml b/vendors/irmin/irmin/store.ml new file mode 100644 index 000000000000..a0b8fdc37ac4 --- /dev/null +++ b/vendors/irmin/irmin/store.ml @@ -0,0 +1,1202 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Store_intf +open Merge.Infix + +let src = Logs.Src.create "irmin" ~doc:"Irmin branch-consistent store" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Content_addressable + (AO : S.APPEND_ONLY_STORE_MAKER) + (K : Hash.S) + (V : Type.S) = +struct + include AO (K) (V) + open Lwt.Infix + module H = Hash.Typed (K) (V) + + let hash = H.hash + let pp_key = Type.pp K.t + let equal_hash = Type.(unstage (equal K.t)) + + let find t k = + find t k >>= function + | None -> Lwt.return_none + | Some v as r -> + let k' = hash v in + if equal_hash k k' then Lwt.return r + else + Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + pp_key k' pp_key k + + let unsafe_add t k v = add t k v + + let add t v = + let k = hash v in + add t k v >|= fun () -> k +end + +module Make (P : Private.S) = struct + module Branch_store = P.Branch + + type branch = Branch_store.key + + module Hash = P.Hash + + type hash = Hash.t + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] [@@deriving irmin] + type ff_error = [ `No_change | `Rejected | lca_error ] + + module Key = P.Node.Path + + type key = Key.t [@@deriving irmin] + + module Metadata = P.Node.Metadata + module H = Commit.History (P.Commit) + + type S.remote += E of P.Sync.endpoint + + module Contents = struct + include P.Contents.Val + + let of_hash r h = P.Contents.find (P.Repo.contents_t r) h + let hash c = P.Contents.Key.hash c + end + + module Tree = struct + include Tree.Make (P) + + let of_hash r h = import r h + let shallow r h = import_no_check r h + let kinded_hash = hash + + let hash : ?cache:bool -> t -> hash = + fun ?cache tr -> + match hash ?cache tr with `Node h -> h | `Contents (h, _) -> h + end + + let save_contents b c = P.Contents.add b c + + let save_tree ?(clear = true) r x y (tr : Tree.t) = + match Tree.destruct tr with + | `Contents (c, _) -> + let* c = Tree.Contents.force_exn c in + save_contents x c + | `Node n -> Tree.export ~clear r x y n + + type node = Tree.node [@@deriving irmin] + type contents = Contents.t [@@deriving irmin] + type metadata = Metadata.t [@@deriving irmin] + type tree = Tree.t + type repo = P.Repo.t + + let equal_hash = Type.(unstage (equal Hash.t)) + let equal_contents = Type.(unstage (equal Contents.t)) + let equal_branch = Type.(unstage (equal Branch_store.Key.t)) + let pp_key = Type.pp Key.t + let pp_hash = Type.pp Hash.t + let pp_branch = Type.pp Branch_store.Key.t + let pp_option = Type.pp (Type.option Type.int) + + module Commit = struct + type t = { r : repo; h : Hash.t; v : P.Commit.value } + + let t r = + let open Type in + record "commit" (fun h v -> { r; h; v }) + |+ field "hash" Hash.t (fun t -> t.h) + |+ field "value" P.Commit.Val.t (fun t -> t.v) + |> sealr + + let v r ~info ~parents tree = + P.Repo.batch r @@ fun contents_t node_t commit_t -> + let* node = + match Tree.destruct tree with + | `Node t -> Tree.export r contents_t node_t t + | `Contents _ -> Lwt.fail_invalid_arg "cannot add contents at the root" + in + let v = P.Commit.Val.v ~info ~node ~parents in + let+ h = P.Commit.add commit_t v in + { r; h; v } + + let node t = P.Commit.Val.node t.v + let tree t = Tree.import_no_check t.r (`Node (node t)) + let equal x y = equal_hash x.h y.h + let hash t = t.h + let info t = P.Commit.Val.info t.v + let parents t = P.Commit.Val.parents t.v + let pp_hash ppf t = Type.pp Hash.t ppf t.h + + let of_hash r h = + P.Commit.find (P.Repo.commit_t r) h >|= function + | None -> None + | Some v -> Some { r; h; v } + + let to_private_commit t = t.v + + let of_private_commit r v = + let h = P.Commit.Key.hash v in + { r; h; v } + + let equal_opt x y = + match (x, y) with + | None, None -> true + | Some x, Some y -> equal x y + | _ -> false + end + + type commit = Commit.t + + let to_private_node = Tree.to_private_node + let of_private_node = Tree.of_private_node + let to_private_commit = Commit.to_private_commit + let of_private_commit = Commit.of_private_commit + + type head_ref = [ `Branch of branch | `Head of commit option ref ] + + module OCamlGraph = Graph + module Graph = Node.Graph (P.Node) + module KGraph = Object_graph.Make (Hash) (Branch_store.Key) + + type slice = P.Slice.t [@@deriving irmin] + type watch = unit -> unit Lwt.t + + let unwatch w = w () + + module Repo = struct + type t = repo + + let v = P.Repo.v + let close = P.Repo.close + let graph_t t = P.Repo.node_t t + let history_t t = P.Repo.commit_t t + let branch_t t = P.Repo.branch_t t + let commit_t t = P.Repo.commit_t t + let node_t t = P.Repo.node_t t + let contents_t t = P.Repo.contents_t t + let branches t = P.Branch.list (branch_t t) + + let heads repo = + let t = branch_t repo in + let* bs = Branch_store.list t in + Lwt_list.fold_left_s + (fun acc r -> + Branch_store.find t r >>= function + | None -> Lwt.return acc + | Some h -> ( + Commit.of_hash repo h >|= function + | None -> acc + | Some h -> h :: acc)) + [] bs + + let export ?(full = true) ?depth ?(min = []) ?(max = `Head) t = + Log.debug (fun f -> + f "export depth=%s full=%b min=%d max=%s" + (match depth with None -> "" | Some d -> string_of_int d) + full (List.length min) + (match max with + | `Head -> "heads" + | `Max m -> string_of_int (List.length m))); + let* max = match max with `Head -> heads t | `Max m -> Lwt.return m in + let* slice = P.Slice.empty () in + let max = List.map (fun x -> `Commit x.Commit.h) max in + let min = List.map (fun x -> `Commit x.Commit.h) min in + let pred = function + | `Commit k -> + let+ parents = H.parents (history_t t) k in + List.map (fun x -> `Commit x) parents + | _ -> Lwt.return_nil + in + let* g = KGraph.closure ?depth ~pred ~min ~max () in + let keys = + List.fold_left + (fun acc -> function `Commit c -> c :: acc | _ -> acc) + [] (KGraph.vertex g) + in + let root_nodes = ref [] in + let* () = + Lwt_list.iter_p + (fun k -> + P.Commit.find (commit_t t) k >>= function + | None -> Lwt.return_unit + | Some c -> + root_nodes := P.Commit.Val.node c :: !root_nodes; + P.Slice.add slice (`Commit (k, c))) + keys + in + if not full then Lwt.return slice + else + (* XXX: we can compute a [min] if needed *) + let* nodes = Graph.closure (graph_t t) ~min:[] ~max:!root_nodes in + let module KSet = Set.Make (struct + type t = P.Contents.key + + let compare = Type.(unstage (compare P.Contents.Key.t)) + end) in + let contents = ref KSet.empty in + let* () = + Lwt_list.iter_p + (fun k -> + P.Node.find (node_t t) k >>= function + | None -> Lwt.return_unit + | Some v -> + List.iter + (function + | _, `Contents (c, _) -> contents := KSet.add c !contents + | _ -> ()) + (P.Node.Val.list v); + P.Slice.add slice (`Node (k, v))) + nodes + in + let+ () = + Lwt_list.iter_p + (fun k -> + P.Contents.find (contents_t t) k >>= function + | None -> Lwt.return_unit + | Some m -> P.Slice.add slice (`Contents (k, m))) + (KSet.elements !contents) + in + slice + + exception Import_error of string + + let import_error fmt = Fmt.kstr (fun x -> Lwt.fail (Import_error x)) fmt + + let import t s = + let aux name add (k, v) = + let* k' = add v in + if not (equal_hash k k') then + import_error "%s import error: expected %a, got %a" name pp_hash k + pp_hash k' + else Lwt.return_unit + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + let* () = + P.Slice.iter s (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit) + in + P.Repo.batch t @@ fun contents_t node_t commit_t -> + Lwt.catch + (fun () -> + let* () = + Lwt_list.iter_p + (aux "Contents" (P.Contents.add contents_t)) + !contents + in + Lwt_list.iter_p (aux "Node" (P.Node.add node_t)) !nodes >>= fun () -> + let+ () = + Lwt_list.iter_p (aux "Commit" (P.Commit.add commit_t)) !commits + in + Ok ()) + (function + | Import_error e -> Lwt.return (Error (`Msg e)) + | e -> Fmt.kstr Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) + + type elt = + [ `Commit of Hash.t + | `Node of Hash.t + | `Contents of Hash.t + | `Branch of P.Branch.Key.t ] + [@@deriving irmin] + + let ignore_lwt _ = Lwt.return_unit + let return_false _ = Lwt.return false + let default_pred_contents _ _ = Lwt.return [] + + let default_pred_node t k = + P.Node.find (node_t t) k >|= function + | None -> [] + | Some v -> + List.rev_map + (function + | _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (P.Node.Val.list v) + + let default_pred_commit t c = + P.Commit.find (commit_t t) c >|= function + | None -> + Log.debug (fun l -> l "%a: not found" (Type.pp Hash.t) c); + [] + | Some c -> + let node = P.Commit.Val.node c in + let parents = P.Commit.Val.parents c in + [ `Node node ] @ List.map (fun k -> `Commit k) parents + + let default_pred_branch t b = + P.Branch.find (branch_t t) b >|= function + | None -> + Log.debug (fun l -> l "%a: not found" (Type.pp P.Branch.Key.t) b); + [] + | Some b -> [ `Commit b ] + + let iter ?cache_size ~min ~max ?edge ?(branch = ignore_lwt) + ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) + ?(skip_branch = return_false) ?(skip_commit = return_false) + ?(skip_node = return_false) ?(skip_contents = return_false) + ?(pred_branch = default_pred_branch) + ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) + ?(pred_contents = default_pred_contents) ?(rev = true) t = + let node = function + | `Commit x -> commit x + | `Node x -> node x + | `Contents x -> contents x + | `Branch x -> branch x + in + let skip = function + | `Commit x -> skip_commit x + | `Node x -> skip_node x + | `Contents x -> skip_contents x + | `Branch x -> skip_branch x + in + let pred = function + | `Commit x -> pred_commit t x + | `Node x -> pred_node t x + | `Contents x -> pred_contents t x + | `Branch x -> pred_branch t x + in + KGraph.iter ?cache_size ~pred ~min ~max ~node ?edge ~skip ~rev () + end + + type t = { + repo : Repo.t; + head_ref : head_ref; + mutable tree : (commit * tree) option; + (* cache for the store tree *) + lock : Lwt_mutex.t; + } + + type step = Key.step [@@deriving irmin] + + let repo t = t.repo + let branch_t t = Repo.branch_t t.repo + let commit_t t = Repo.commit_t t.repo + let history_t t = commit_t t + + let status t = + match t.head_ref with + | `Branch b -> `Branch b + | `Head h -> ( match !h with None -> `Empty | Some c -> `Commit c) + + let head_ref t = + match t.head_ref with + | `Branch t -> `Branch t + | `Head h -> ( match !h with None -> `Empty | Some h -> `Head h) + + let branch t = + match head_ref t with + | `Branch t -> Lwt.return_some t + | `Empty | `Head _ -> Lwt.return_none + + let err_no_head s = Fmt.kstr Lwt.fail_invalid_arg "Irmin.%s: no head" s + + let retry_merge name fn = + let rec aux i = + fn () >>= function + | Error _ as c -> Lwt.return c + | Ok true -> Merge.ok () + | Ok false -> + Log.debug (fun f -> f "Irmin.%s: conflict, retrying (%d)." name i); + aux (i + 1) + in + aux 1 + + let of_ref repo head_ref = + let lock = Lwt_mutex.create () in + Lwt.return { lock; head_ref; repo; tree = None } + + let err_invalid_branch t = + let err = Fmt.str "%a is not a valid branch name." pp_branch t in + Lwt.fail (Invalid_argument err) + + let of_branch repo id = + if Branch_store.Key.is_valid id then of_ref repo (`Branch id) + else err_invalid_branch id + + let master repo = of_branch repo Branch_store.Key.master + let empty repo = of_ref repo (`Head (ref None)) + let of_commit c = of_ref c.Commit.r (`Head (ref (Some c))) + + let skip_key key = + Log.debug (fun l -> l "[watch-key] key %a has not changed" pp_key key); + Lwt.return_unit + + let changed_key key old_t new_t = + Log.debug (fun l -> + let pp = Fmt.option ~none:(Fmt.any "") pp_hash in + let old_h = Option.map Tree.hash old_t in + let new_h = Option.map Tree.hash new_t in + l "[watch-key] key %a has changed: %a -> %a" pp_key key pp old_h pp + new_h) + + let with_tree ~key x f = + x >>= function + | None -> skip_key key + | Some x -> + changed_key key None None; + f x + + let lift_tree_diff ~key tree fn = function + | `Removed x -> + with_tree ~key (tree x) @@ fun v -> + changed_key key (Some v) None; + fn @@ `Removed (x, v) + | `Added x -> + with_tree ~key (tree x) @@ fun v -> + changed_key key None (Some v); + fn @@ `Added (x, v) + | `Updated (x, y) -> ( + assert (not (Commit.equal x y)); + let* vx = tree x in + let* vy = tree y in + match (vx, vy) with + | None, None -> skip_key key + | None, Some vy -> + changed_key key None (Some vy); + fn @@ `Added (y, vy) + | Some vx, None -> + changed_key key (Some vx) None; + fn @@ `Removed (x, vx) + | Some vx, Some vy -> + if Tree.equal vx vy then skip_key key + else ( + changed_key key (Some vx) (Some vy); + fn @@ `Updated ((x, vx), (y, vy)))) + + let head t = + let h = + match head_ref t with + | `Head key -> Lwt.return_some key + | `Empty -> Lwt.return_none + | `Branch name -> ( + Branch_store.find (branch_t t) name >>= function + | None -> Lwt.return_none + | Some h -> Commit.of_hash t.repo h) + in + let+ h = h in + Log.debug (fun f -> f "Head.find -> %a" Fmt.(option Commit.pp_hash) h); + h + + let tree_and_head t = + head t >|= function + | None -> None + | Some h -> ( + match t.tree with + | Some (o, t) when Commit.equal o h -> Some (o, t) + | _ -> + t.tree <- None; + + (* the tree cache needs to be invalidated *) + let tree = Tree.import_no_check (repo t) (`Node (Commit.node h)) in + t.tree <- Some (h, tree); + Some (h, tree)) + + let tree t = + tree_and_head t >|= function + | None -> Tree.empty () + | Some (_, tree) -> (tree :> tree) + + let lift_head_diff repo fn = function + | `Removed x -> ( + Commit.of_hash repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Removed x)) + | `Updated (x, y) -> ( + let* x = Commit.of_hash repo x in + let* y = Commit.of_hash repo y in + match (x, y) with + | None, None -> Lwt.return_unit + | Some x, None -> fn (`Removed x) + | None, Some y -> fn (`Added y) + | Some x, Some y -> fn (`Updated (x, y))) + | `Added x -> ( + Commit.of_hash repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Added x)) + + let watch t ?init fn = + branch t >>= function + | None -> failwith "watch a detached head: TODO" + | Some name0 -> + let init = + match init with + | None -> None + | Some head0 -> Some [ (name0, head0.Commit.h) ] + in + let+ id = + Branch_store.watch (branch_t t) ?init (fun name head -> + if equal_branch name0 name then lift_head_diff t.repo fn head + else Lwt.return_unit) + in + fun () -> Branch_store.unwatch (branch_t t) id + + let watch_key t key ?init fn = + Log.debug (fun f -> f "watch-key %a" pp_key key); + let tree c = Tree.find_tree (Commit.tree c) key in + watch t ?init (lift_tree_diff ~key tree fn) + + module Head = struct + let list = Repo.heads + let find = head + + let get t = + find t >>= function None -> err_no_head "head" | Some k -> Lwt.return k + + let set t c = + match t.head_ref with + | `Head h -> + h := Some c; + Lwt.return_unit + | `Branch name -> Branch_store.set (branch_t t) name c.Commit.h + + let test_and_set_unsafe t ~test ~set = + match t.head_ref with + | `Head head -> + (* [head] is protected by [t.lock]. *) + if Commit.equal_opt !head test then ( + head := set; + Lwt.return_true) + else Lwt.return_false + | `Branch name -> + let h = function None -> None | Some c -> Some c.Commit.h in + Branch_store.test_and_set (branch_t t) name ~test:(h test) + ~set:(h set) + + let test_and_set t ~test ~set = + Lwt_mutex.with_lock t.lock (fun () -> test_and_set_unsafe t ~test ~set) + + type ff_error = [ `Rejected | `No_change | lca_error ] + + let fast_forward t ?max_depth ?n new_head = + let return x = if x then Ok () else Error (`Rejected :> ff_error) in + find t >>= function + | None -> test_and_set t ~test:None ~set:(Some new_head) >|= return + | Some old_head -> ( + Log.debug (fun f -> + f "fast-forward-head old=%a new=%a" Commit.pp_hash old_head + Commit.pp_hash new_head); + if Commit.equal new_head old_head then + (* we only update if there is a change *) + Lwt.return (Error `No_change) + else + H.lcas (history_t t) ?max_depth ?n new_head.Commit.h + old_head.Commit.h + >>= function + | Ok [ x ] when equal_hash x old_head.Commit.h -> + (* we only update if new_head > old_head *) + test_and_set t ~test:(Some old_head) ~set:(Some new_head) + >|= return + | Ok _ -> Lwt.return (Error `Rejected) + | Error e -> Lwt.return (Error (e :> ff_error))) + + (* Merge two commits: + - Search for common ancestors + - Perform recursive 3-way merges *) + let three_way_merge t ?max_depth ?n ~info c1 c2 = + P.Repo.batch (repo t) @@ fun _ _ commit_t -> + H.three_way_merge commit_t ?max_depth ?n ~info c1.Commit.h c2.Commit.h + + (* FIXME: we might want to keep the new commit in case of conflict, + and use it as a base for the next merge. *) + let merge ~into:t ~info ?max_depth ?n c1 = + Log.debug (fun f -> f "merge_head"); + let aux () = + let* head = head t in + match head with + | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) >>= Merge.ok + | Some c2 -> + three_way_merge t ~info ?max_depth ?n c1 c2 >>=* fun c3 -> + let* c3 = Commit.of_hash t.repo c3 in + test_and_set_unsafe t ~test:head ~set:c3 >>= Merge.ok + in + Lwt_mutex.with_lock t.lock (fun () -> retry_merge "merge_head" aux) + end + + (* Retry an operation until the optimistic lock is happy. Ensure + that the operation is done at least once. *) + let retry ~retries fn = + let done_once = ref false in + let rec aux i = + if !done_once && i > retries then + Lwt.return (Error (`Too_many_retries retries)) + else + fn () >>= function + | Ok true -> Lwt.return (Ok ()) + | Error e -> Lwt.return (Error e) + | Ok false -> + done_once := true; + aux (i + 1) + in + aux 0 + + let root_tree = function + | `Node _ as n -> Tree.v n + | `Contents _ -> assert false + + let add_commit t old_head ((c, _) as tree) = + match t.head_ref with + | `Head head -> + Lwt_mutex.with_lock t.lock (fun () -> + if not (Commit.equal_opt old_head !head) then Lwt.return_false + else ( + (* [head] is protected by [t.lock] *) + head := Some c; + t.tree <- Some tree; + Lwt.return_true)) + | `Branch name -> + (* concurrent handlers and/or process can modify the + branch. Need to check that we are still working on the same + head. *) + let test = + match old_head with None -> None | Some c -> Some (Commit.hash c) + in + let set = Some (Commit.hash c) in + let+ r = Branch_store.test_and_set (branch_t t) name ~test ~set in + if r then t.tree <- Some tree; + r + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + + let pp_write_error ppf = function + | `Conflict e -> Fmt.pf ppf "Got a conflict: %s" e + | `Too_many_retries i -> + Fmt.pf ppf + "Failure after %d attempts to retry the operation: Too many attempts." + i + | `Test_was t -> + Fmt.pf ppf "Test-and-set failed: got %a when reading the store" + Type.(pp (option Tree.tree_t)) + t + + let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) + let err_test v = write_error (`Test_was v) + + type snapshot = { + head : commit option; + root : tree; + tree : tree option; + (* the subtree used by the transaction *) + parents : commit list; + } + + let snapshot t key = + tree_and_head t >>= function + | None -> + Lwt.return + { head = None; root = Tree.empty (); tree = None; parents = [] } + | Some (c, root) -> + let root = (root :> tree) in + let+ tree = Tree.find_tree root key in + { head = Some c; root; tree; parents = [ c ] } + + let same_tree x y = + match (x, y) with + | None, None -> true + | None, _ | _, None -> false + | Some x, Some y -> Tree.equal x y + + (* Update the store with a new commit. Ensure the no commit becomes orphan + in the process. *) + let update ?(allow_empty = false) ~info ?parents t key merge_tree f = + let* s = snapshot t key in + (* this might take a very long time *) + let* new_tree = f s.tree in + (* if no change and [allow_empty = true] then, do nothing *) + if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then + Lwt.return (Ok true) + else + merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function + | Error e -> Lwt.return (Error e) + | Ok root -> + let info = info () in + let parents = match parents with None -> s.parents | Some p -> p in + let parents = List.map Commit.hash parents in + let* c = Commit.v (repo t) ~info ~parents root in + let* r = add_commit t s.head (c, root_tree (Tree.destruct root)) in + Lwt.return (Ok r) + + let ok x = Ok x + + let fail name = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstr Lwt.fail_with "%s: %a" name pp_write_error e + + let set_tree_once root key ~current_tree:_ ~new_tree = + match new_tree with + | None -> Tree.remove root key >|= ok + | Some tree -> Tree.add_tree root key tree >|= ok + + let set_tree ?(retries = 13) ?allow_empty ?parents ~info t k v = + Log.debug (fun l -> l "set %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return_some v + + let set_tree_exn ?retries ?allow_empty ?parents ~info t k v = + set_tree ?retries ?allow_empty ?parents ~info t k v >>= fail "set_exn" + + let remove ?(retries = 13) ?allow_empty ?parents ~info t k = + Log.debug (fun l -> l "debug %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return_none + + let remove_exn ?retries ?allow_empty ?parents ~info t k = + remove ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" + + let set ?retries ?allow_empty ?parents ~info t k v = + let v = Tree.of_contents v in + set_tree t k ?retries ?allow_empty ?parents ~info v + + let set_exn ?retries ?allow_empty ?parents ~info t k v = + set t k ?retries ?allow_empty ?parents ~info v >>= fail "set_exn" + + let test_and_set_tree_once ~test root key ~current_tree ~new_tree = + match (test, current_tree) with + | None, None -> set_tree_once root key ~new_tree ~current_tree + | None, _ | _, None -> err_test current_tree + | Some test, Some v -> + if Tree.equal test v then set_tree_once root key ~new_tree ~current_tree + else err_test current_tree + + let test_and_set_tree ?(retries = 13) ?allow_empty ?parents ~info t k ~test + ~set = + Log.debug (fun l -> l "test-and-set %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info (test_and_set_tree_once ~test) + @@ fun _tree -> Lwt.return set + + let test_and_set_tree_exn ?retries ?allow_empty ?parents ~info t k ~test ~set + = + test_and_set_tree ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_tree_exn" + + let test_and_set ?retries ?allow_empty ?parents ~info t k ~test ~set = + let test = Option.map Tree.of_contents test in + let set = Option.map Tree.of_contents set in + test_and_set_tree ?retries ?allow_empty ?parents ~info t k ~test ~set + + let test_and_set_exn ?retries ?allow_empty ?parents ~info t k ~test ~set = + test_and_set ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_exn" + + let merge_once ~old root key ~current_tree ~new_tree = + let old = Merge.promise old in + Merge.f (Merge.option Tree.merge) ~old current_tree new_tree >>= function + | Ok tr -> set_tree_once root key ~new_tree:tr ~current_tree + | Error e -> write_error (e :> write_error) + + let merge_tree ?(retries = 13) ?allow_empty ?parents ~info ~old t k tree = + Log.debug (fun l -> l "merge %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info (merge_once ~old) @@ fun _tree -> + Lwt.return tree + + let merge_tree_exn ?retries ?allow_empty ?parents ~info ~old t k tree = + merge_tree ?retries ?allow_empty ?parents ~info ~old t k tree + >>= fail "merge_tree_exn" + + let merge ?retries ?allow_empty ?parents ~info ~old t k v = + let old = Option.map Tree.of_contents old in + let v = Option.map Tree.of_contents v in + merge_tree ?retries ?allow_empty ?parents ~info ~old t k v + + let merge_exn ?retries ?allow_empty ?parents ~info ~old t k v = + merge ?retries ?allow_empty ?parents ~info ~old t k v >>= fail "merge_exn" + + let mem t k = tree t >>= fun tree -> Tree.mem tree k + let mem_tree t k = tree t >>= fun tree -> Tree.mem_tree tree k + let find_all t k = tree t >>= fun tree -> Tree.find_all tree k + let find t k = tree t >>= fun tree -> Tree.find tree k + let get t k = tree t >>= fun tree -> Tree.get tree k + let find_tree t k = tree t >>= fun tree -> Tree.find_tree tree k + let get_tree t k = tree t >>= fun tree -> Tree.get_tree tree k + + let hash t k = + find_tree t k >|= function + | None -> None + | Some tree -> Some (Tree.hash tree) + + let get_all t k = tree t >>= fun tree -> Tree.get_all tree k + let list t k = tree t >>= fun tree -> Tree.list tree k + let kind t k = tree t >>= fun tree -> Tree.kind tree k + + let with_tree ?(retries = 13) ?allow_empty ?parents + ?(strategy = `Test_and_set) ~info t key f = + let done_once = ref false in + let rec aux n old_tree = + Log.debug (fun l -> l "with_tree %a (%d/%d)" pp_key key n retries); + if !done_once && n > retries then write_error (`Too_many_retries retries) + else + let* new_tree = f old_tree in + match (strategy, new_tree) with + | `Set, Some tree -> + set_tree t key ~retries ?allow_empty ?parents tree ~info + | `Set, None -> remove t key ~retries ?allow_empty ~info ?parents + | `Test_and_set, _ -> ( + test_and_set_tree t key ~retries ?allow_empty ?parents ~info + ~test:old_tree ~set:new_tree + >>= function + | Error (`Test_was tr) when retries > 0 && n <= retries -> + done_once := true; + aux (n + 1) tr + | e -> Lwt.return e) + | `Merge, _ -> ( + merge_tree ~old:old_tree ~retries ?allow_empty ?parents ~info t key + new_tree + >>= function + | Ok _ as x -> Lwt.return x + | Error (`Conflict _) when retries > 0 && n <= retries -> + done_once := true; + + (* use the store's current tree as the new 'old store' *) + let* old_tree = + tree_and_head t >>= function + | None -> Lwt.return_none + | Some (_, tr) -> Tree.find_tree (tr :> tree) key + in + aux (n + 1) old_tree + | Error e -> write_error e) + in + let* old_tree = find_tree t key in + aux 0 old_tree + + let with_tree_exn ?retries ?allow_empty ?parents ?strategy ~info f t key = + with_tree ?retries ?allow_empty ?strategy ?parents ~info f t key + >>= fail "with_tree_exn" + + let clone ~src ~dst = + let* () = + Head.find src >>= function + | None -> Branch_store.remove (branch_t src) dst + | Some h -> Branch_store.set (branch_t src) dst h.Commit.h + in + of_branch (repo src) dst + + let return_lcas r = function + | Error _ as e -> Lwt.return e + | Ok commits -> + Lwt_list.filter_map_p (Commit.of_hash r) commits >|= Result.ok + + let lcas ?max_depth ?n t1 t2 = + let* h1 = Head.get t1 in + let* h2 = Head.get t2 in + H.lcas (history_t t1) ?max_depth ?n h1.Commit.h h2.Commit.h + >>= return_lcas t1.repo + + let lcas_with_commit t ?max_depth ?n c = + let* h = Head.get t in + H.lcas (history_t t) ?max_depth ?n h.Commit.h c.Commit.h + >>= return_lcas t.repo + + let lcas_with_branch t ?max_depth ?n b = + let* h = Head.get t in + let* head = Head.get { t with head_ref = `Branch b } in + H.lcas (history_t t) ?max_depth ?n h.Commit.h head.Commit.h + >>= return_lcas t.repo + + module Private = P + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + let merge_with_branch t ~info ?max_depth ?n other = + Log.debug (fun f -> f "merge_with_branch %a" pp_branch other); + Branch_store.find (branch_t t) other >>= function + | None -> + Fmt.kstr Lwt.fail_invalid_arg + "merge_with_branch: %a is not a valid branch ID" pp_branch other + | Some c -> ( + Commit.of_hash t.repo c >>= function + | None -> Lwt.fail_invalid_arg "invalid commit" + | Some c -> Head.merge ~into:t ~info ?max_depth ?n c) + + let merge_with_commit t ~info ?max_depth ?n other = + Head.merge ~into:t ~info ?max_depth ?n other + + let merge_into ~into ~info ?max_depth ?n t = + Log.debug (fun l -> l "merge"); + match head_ref t with + | `Branch name -> merge_with_branch into ~info ?max_depth ?n name + | `Head h -> merge_with_commit into ~info ?max_depth ?n h + | `Empty -> Merge.ok () + + module History = OCamlGraph.Persistent.Digraph.ConcreteBidirectional (struct + type t = commit + + let hash h = P.Commit.Key.short_hash h.Commit.h + let compare_key = Type.(unstage (compare P.Commit.Key.t)) + let compare x y = compare_key x.Commit.h y.Commit.h + let equal x y = equal_hash x.Commit.h y.Commit.h + end) + + module Gmap = struct + module Src = Object_graph.Make (Hash) (Branch_store.Key) + + module Dst = struct + include History + + let empty () = empty + end + + let filter_map f g = + let t = Dst.empty () in + if Src.nb_vertex g = 1 then + match Src.vertex g with + | [ v ] -> ( + f v >|= function Some v -> Dst.add_vertex t v | None -> t) + | _ -> assert false + else + Src.fold_edges + (fun x y t -> + let* t = t in + let* x = f x in + let+ y = f y in + match (x, y) with + | Some x, Some y -> + let t = Dst.add_vertex t x in + let t = Dst.add_vertex t y in + Dst.add_edge t x y + | _ -> t) + g (Lwt.return t) + end + + let history ?depth ?(min = []) ?(max = []) t = + Log.debug (fun f -> f "history"); + let pred = function + | `Commit k -> + H.parents (history_t t) k + >>= Lwt_list.filter_map_p (Commit.of_hash t.repo) + >|= fun parents -> List.map (fun x -> `Commit x.Commit.h) parents + | _ -> Lwt.return_nil + in + let* max = Head.find t >|= function Some h -> [ h ] | None -> max in + let max = List.map (fun k -> `Commit k.Commit.h) max in + let min = List.map (fun k -> `Commit k.Commit.h) min in + let* g = Gmap.Src.closure ?depth ~min ~max ~pred () in + Gmap.filter_map + (function `Commit k -> Commit.of_hash t.repo k | _ -> Lwt.return_none) + g + + module Heap = Binary_heap.Make (struct + type t = commit * int + + let compare c1 c2 = + (* [bheap] operates on miminums, we need to invert the comparison. *) + -Int64.compare + (Info.date (Commit.info (fst c1))) + (Info.date (Commit.info (fst c2))) + end) + + let last_modified ?depth ?(n = 1) t key = + Log.debug (fun l -> + l "last_modified depth=%a n=%d key=%a" pp_option depth n pp_key key); + let repo = repo t in + let* commit = Head.get t in + let heap = Heap.create ~dummy:(commit, 0) 0 in + let () = Heap.add heap (commit, 0) in + let rec search acc = + if Heap.is_empty heap || List.length acc = n then Lwt.return acc + else + let current, current_depth = Heap.pop_minimum heap in + let parents = Commit.parents current in + let tree = Commit.tree current in + let* current_value = Tree.find tree key in + if List.length parents = 0 then + if current_value <> None then Lwt.return (current :: acc) + else Lwt.return acc + else + let max_depth = + match depth with + | Some depth -> current_depth >= depth + | None -> false + in + let* found = + Lwt_list.for_all_p + (fun hash -> + Commit.of_hash repo hash >>= function + | Some commit -> ( + let () = + if not max_depth then + Heap.add heap (commit, current_depth + 1) + in + let tree = Commit.tree commit in + let+ e = Tree.find tree key in + match (e, current_value) with + | Some x, Some y -> not (equal_contents x y) + | Some _, None -> true + | None, Some _ -> true + | _, _ -> false) + | None -> Lwt.return_false) + parents + in + if found then search (current :: acc) else search acc + in + search [] + + module Branch = struct + include P.Branch.Key + + let mem t = P.Branch.mem (P.Repo.branch_t t) + + let find t br = + P.Branch.find (Repo.branch_t t) br >>= function + | None -> Lwt.return_none + | Some h -> Commit.of_hash t h + + let set t br h = P.Branch.set (P.Repo.branch_t t) br (Commit.hash h) + let remove t = P.Branch.remove (P.Repo.branch_t t) + let list = Repo.branches + + let watch t k ?init f = + let init = match init with None -> None | Some h -> Some h.Commit.h in + let+ w = + P.Branch.watch_key (Repo.branch_t t) k ?init (lift_head_diff t f) + in + fun () -> Branch_store.unwatch (Repo.branch_t t) w + + let watch_all t ?init f = + let init = + match init with + | None -> None + | Some i -> Some (List.map (fun (k, v) -> (k, v.Commit.h)) i) + in + let f k v = lift_head_diff t (f k) v in + let+ w = P.Branch.watch (Repo.branch_t t) ?init f in + fun () -> Branch_store.unwatch (Repo.branch_t t) w + + let err_not_found k = + Fmt.kstr invalid_arg "Branch.get: %a not found" pp_branch k + + let get t k = + find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + end + + module Status = struct + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + let t r = + let open Type in + variant "status" (fun empty branch commit -> function + | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c) + |~ case0 "empty" `Empty + |~ case1 "branch" Branch.t (fun b -> `Branch b) + |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) + |> sealv + + let pp ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Branch b -> Type.pp Branch.t ppf b + | `Commit c -> Type.pp Hash.t ppf (Commit.hash c) + end + + let tree_t = Tree.tree_t + let commit_t = Commit.t + let branch_t = Branch.t + + type kind = [ `Contents | `Node ] [@@deriving irmin] + + let ff_error_t = + Type.enum "ff-error" + [ + ("max-depth-reached", `Max_depth_reached); + ("too-many-lcas", `Too_many_lcas); + ("no-change", `No_change); + ("rejected", `Rejected); + ] + + let write_error_t = + let open Type in + variant "write-error" (fun c m e -> function + | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x) + |~ case1 "conflict" string (fun x -> `Conflict x) + |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) + |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) + |> sealv + + let write_error_t = + let of_string _ = assert false in + Type.like ~pp:pp_write_error ~of_string write_error_t +end + +module Json_tree (Store : S with type contents = Contents.json) = struct + include Contents.Json_value + + type json = Contents.json + + let to_concrete_tree j : Store.Tree.concrete = + let rec obj j acc = + match j with + | [] -> `Tree acc + | (k, v) :: l -> ( + match Type.of_string Store.Key.step_t k with + | Ok key -> obj l ((key, node v []) :: acc) + | _ -> obj l acc) + and node j acc = + match j with + | `O j -> obj j acc + | _ -> `Contents (j, Store.Metadata.default) + in + node j [] + + let of_concrete_tree c : json = + let step = Type.to_string Store.Key.step_t in + let rec tree t acc = + match t with + | [] -> `O acc + | (k, v) :: l -> tree l ((step k, contents v []) :: acc) + and contents t acc = + match t with `Contents (c, _) -> c | `Tree c -> tree c acc + in + contents c [] + + let set_tree (tree : Store.tree) key j : Store.tree Lwt.t = + let c = to_concrete_tree j in + let c = Store.Tree.of_concrete c in + Store.Tree.add_tree tree key c + + let get_tree (tree : Store.tree) key = + let* t = Store.Tree.get_tree tree key in + let+ c = Store.Tree.to_concrete t in + of_concrete_tree c + + let set t key j ~info = + set_tree (Store.Tree.empty ()) Store.Key.empty j >>= function + | tree -> Store.set_tree_exn ~info t key tree + + let get t key = + let* tree = Store.get_tree t key in + get_tree tree Store.Key.empty +end + +type S.remote += Store : (module S with type t = 'a) * 'a -> S.remote diff --git a/vendors/irmin/irmin/store.mli b/vendors/irmin/irmin/store.mli new file mode 100644 index 000000000000..912df7f3acb5 --- /dev/null +++ b/vendors/irmin/irmin/store.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Branch-consistent stores: read-write store with support fork/merge + operations. *) + +include Store_intf.Store +(** @inline *) diff --git a/vendors/irmin/irmin/store_intf.ml b/vendors/irmin/irmin/store_intf.ml new file mode 100644 index 000000000000..a0c6bfe9abd0 --- /dev/null +++ b/vendors/irmin/irmin/store_intf.ml @@ -0,0 +1,1035 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Sigs = S +open Sigs.Store_properties + +module type S = sig + (** {1 Irmin stores} + + Irmin stores are tree-like read-write stores with extended capabilities. + They allow an application (or a collection of applications) to work with + multiple local states, which can be forked and merged programmatically, + without having to rely on a global state. In a way very similar to version + control systems, Irmin local states are called {i branches}. + + There are two kinds of store in Irmin: the ones based on {{!persistent} + persistent} named branches and the ones based {{!temporary} temporary} + detached heads. These exist relative to a local, larger (and shared) + store, and have some (shared) contents. This is exactly the same as usual + version control systems, that the informed user can see as an implicit + purely functional data-structure. *) + + type repo + (** The type for Irmin repositories. *) + + type t + (** The type for Irmin stores. *) + + type step + (** The type for {!key} steps. *) + + type key + (** The type for store keys. A key is a sequence of {!step}s. *) + + type metadata + (** The type for store metadata. *) + + type contents + (** The type for store contents. *) + + type node + (** The type for store nodes. *) + + type tree + (** The type for store trees. *) + + type hash + (** The type for object hashes. *) + + type commit + (** Type for commit identifiers. Similar to Git's commit SHA1s. *) + + type branch + (** Type for persistent branch names. Branches usually share a common global + namespace and it's the user's responsibility to avoid name clashes. *) + + type slice + (** Type for store slices. *) + + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] + (** The type for errors associated with functions computing least common + ancestors *) + + type ff_error = [ `No_change | `Rejected | lca_error ] + (** The type for errors for {!fast_forward}. *) + + (** Repositories. *) + module Repo : sig + (** {1 Repositories} + + A repository contains a set of branches. *) + + type t = repo + (** The type of repository handles. *) + + val v : S.config -> t Lwt.t + (** [v config] connects to a repository in a backend-specific manner. *) + + include CLOSEABLE with type _ t := t + (** @inline *) + + val heads : t -> commit list Lwt.t + (** [heads] is {!Head.list}. *) + + val branches : t -> branch list Lwt.t + (** [branches] is {!Branch.list}. *) + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:[ `Head | `Max of commit list ] -> + t -> + slice Lwt.t + (** [export t ~full ~depth ~min ~max] exports the store slice between [min] + and [max], using at most [depth] history depth (starting from the max). + + If [max] is `Head (also the default value), use the current [heads]. If + [min] is not specified, use an unbound past (but can still be limited by + [depth]). + + [depth] is used to limit the depth of the commit history. [None] here + means no limitation. + + If [full] is set (default is true), the full graph, including the + commits, nodes and contents, is exported, otherwise it is the commit + history graph only. *) + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + (** [import t s] imports the contents of the slice [s] in [t]. Does not + modify branches. *) + + type elt = + [ `Commit of hash | `Node of hash | `Contents of hash | `Branch of branch ] + [@@deriving irmin] + (** The type for elements iterated over by {!iter}. *) + + val default_pred_commit : t -> hash -> elt list Lwt.t + val default_pred_node : t -> hash -> elt list Lwt.t + val default_pred_contents : t -> hash -> elt list Lwt.t + + val iter : + ?cache_size:int -> + min:elt list -> + max:elt list -> + ?edge:(elt -> elt -> unit Lwt.t) -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(hash -> unit Lwt.t) -> + ?node:(hash -> unit Lwt.t) -> + ?contents:(hash -> unit Lwt.t) -> + ?skip_branch:(branch -> bool Lwt.t) -> + ?skip_commit:(hash -> bool Lwt.t) -> + ?skip_node:(hash -> bool Lwt.t) -> + ?skip_contents:(hash -> bool Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> hash -> elt list Lwt.t) -> + ?pred_node:(t -> hash -> elt list Lwt.t) -> + ?pred_contents:(t -> hash -> elt list Lwt.t) -> + ?rev:bool -> + t -> + unit Lwt.t + (** [iter t] iterates in topological order over the closure graph of [t]. If + [rev] is set (by default it is) the traversal is done in reverse order. + + [skip_branch], [skip_commit], [skip_node] and [skip_contents] allow the + traversal to be stopped when the corresponding objects are traversed. By + default no objects are skipped. + + The [branch], [commit], [node] and [contents] functions are called + whenever the corresponding objects are traversed. By default these + functions do nothing. These functions are not called on skipped objects. + + [pred_branch], [pred_commit], [pred_node] and [pred_contents] implicitly + define the graph underlying the traversal. By default they exactly match + the underlying Merkle graph of the repository [t]. These functions can + be used to traverse a slightly modified version of that graph, for + instance by modifying [pred_contents] to implicitly link structured + contents with other objects in the graph. + + The traversed objects are all included between [min] (included) and + [max] (included), following the Merkle graph order. Moreover, the [min] + boundary is extended as follows: + + - contents and node objects in [min] stop the traversal; their + predecessors are not traversed. + - commit objects in [min] stop the traversal for their commit + predecessors, but their sub-node are still traversed. This allows + users to define an inclusive range of commit to iterate over. + - branch objects in [min] implicitly add to [min] the commit they are + pointing to; this allow users to define the iteration between two + branches. + + [cache_size] is the size of the LRU used to store traversed objects. If + an entry is evicted from the LRU, it can be traversed multiple times by + {!Repo.iter}. When [cache_size] is [None] (the default), no entries is + ever evicted from the cache; hence every object is only traversed once, + at the cost of having to store all the traversed objects in memory. *) + end + + val empty : repo -> t Lwt.t + (** [empty repo] is a temporary, empty store. Becomes a normal temporary store + after the first update. *) + + val master : repo -> t Lwt.t + (** [master repo] is a persistent store based on [r]'s master branch. This + operation is cheap, can be repeated multiple times. *) + + val of_branch : repo -> branch -> t Lwt.t + (** [of_branch r name] is a persistent store based on the branch [name]. + Similar to [master], but use [name] instead {!Branch.S.master}. *) + + val of_commit : commit -> t Lwt.t + (** [of_commit c] is a temporary store, based on the commit [c]. + + Temporary stores do not have stable names: instead they can be addressed + using the hash of the current commit. Temporary stores are similar to + Git's detached heads. In a temporary store, all the operations are + performed relative to the current head and update operations can modify + the current head: the current stores's head will automatically become the + new head obtained after performing the update. *) + + val repo : t -> repo + (** [repo t] is the repository containing [t]. *) + + val tree : t -> tree Lwt.t + (** [tree t] is [t]'s current tree. Contents is not allowed at the root of the + tree. *) + + module Status : sig + type t = [ `Empty | `Branch of branch | `Commit of commit ] + (** The type for store status. *) + + val t : repo -> t Type.t + (** [t] is the value type for {!t}. *) + + val pp : t Fmt.t + (** [pp] is the pretty-printer for store status. *) + end + + val status : t -> Status.t + (** [status t] is [t]'s status. It can either be a branch, a commit or empty. *) + + (** Managing the store's heads. *) + module Head : sig + val list : repo -> commit list Lwt.t + (** [list t] is the list of all the heads in local store. Similar to + [git rev-list --all]. *) + + val find : t -> commit option Lwt.t + (** [find t] is the current head of the store [t]. This works for both + persistent and temporary branches. In the case of a persistent branch, + this involves getting the the head associated with the branch, so this + may block. In the case of a temporary store, it simply returns the + current head. Returns [None] if the store has no contents. Similar to + [git rev-parse HEAD]. *) + + val get : t -> commit Lwt.t + (** Same as {!find} but raise [Invalid_argument] if the store does not have + any contents. *) + + val set : t -> commit -> unit Lwt.t + (** [set t h] updates [t]'s contents with the contents of the commit [h]. + Can cause data loss as it discards the current contents. Similar to + [git reset --hard ]. *) + + val fast_forward : + t -> ?max_depth:int -> ?n:int -> commit -> (unit, ff_error) result Lwt.t + (** [fast_forward t h] is similar to {!update} but the [t]'s head is updated + to [h] only if [h] is stricly in the future of [t]'s current head. + [max_depth] or [n] are used to limit the search space of the lowest + common ancestors (see {!lcas}). + + The result is: + + - [Ok ()] if the operation is succesfull; + - [Error `No_change] if [h] is already [t]'s head; + - [Error `Rejected] if [h] is not in the strict future of [t]'s head. + - [Error e] if the history exploration has been cut before getting + useful results. In that case. the operation can be retried using + different parameters of [n] and [max_depth] to get better results. *) + + val test_and_set : + t -> test:commit option -> set:commit option -> bool Lwt.t + (** Same as {!update_head} but check that the value is [test] before + updating to [set]. Use {!update} or {!merge} instead if possible. *) + + val merge : + into:t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + (unit, Merge.conflict) result Lwt.t + (** [merge ~into:t ?max_head ?n commit] merges the contents of the commit + associated to [commit] into [t]. [max_depth] is the maximal depth used + for getting the lowest common ancestor. [n] is the maximum number of + lowest common ancestors. If present, [max_depth] or [n] are used to + limit the search space of the lowest common ancestors (see {!lcas}). *) + end + + module Hash : Hash.S with type t = hash + (** Object hashes. *) + + (** [Commit] defines immutable objects to describe store updates. *) + module Commit : sig + type t = commit + (** The type for store commits. *) + + val t : repo -> t Type.t + (** [t] is the value type for {!t}. *) + + val pp_hash : t Fmt.t + (** [pp] is the pretty-printer for commit. Display only the hash. *) + + val v : repo -> info:Info.t -> parents:hash list -> tree -> commit Lwt.t + (** [v r i ~parents:p t] is the commit [c] such that: + + - [info c = i] + - [parents c = p] + - [tree c = t] *) + + val tree : commit -> tree + (** [tree c] is [c]'s root tree. *) + + val parents : commit -> hash list + (** [parents c] are [c]'s parents. *) + + val info : commit -> Info.t + (** [info c] is [c]'s info. *) + + (** {1 Import/Export} *) + + val hash : commit -> hash + (** [hash c] it [c]'s hash. *) + + val of_hash : repo -> hash -> commit option Lwt.t + (** [of_hash r h] is the the commit object in [r] having [h] as hash, or + [None] is no such commit object exists. *) + end + + (** [Contents] provides base functions for the store's contents. *) + module Contents : sig + include Contents.S with type t = contents + + (** {1 Import/Export} *) + + val hash : contents -> hash + (** [hash c] it [c]'s hash in the repository [r]. *) + + val of_hash : repo -> hash -> contents option Lwt.t + (** [of_hash r h] is the the contents object in [r] having [h] as hash, or + [None] is no such contents object exists. *) + end + + (** Managing store's trees. *) + module Tree : sig + include + Tree.S + with type t := tree + and type step := step + and type key := key + and type metadata := metadata + and type contents := contents + and type node := node + and type hash := hash + + (** {1 Import/Export} *) + + val hash : ?cache:bool -> tree -> hash + (** [hash c] is [c]'s hash. *) + + type kinded_hash := [ `Contents of hash * metadata | `Node of hash ] + (** Hashes in the Irmin store are tagged with the type of the value they + reference (either {!contents} or {!node}). In the [contents] case, the + hash is paired with corresponding {!metadata}. *) + + val kinded_hash : ?cache:bool -> tree -> kinded_hash + (** [kinded_hash t] is [c]'s kinded hash. *) + + val of_hash : Repo.t -> kinded_hash -> tree option Lwt.t + (** [of_hash r h] is the the tree object in [r] having [h] as hash, or + [None] is no such tree object exists. *) + + val shallow : Repo.t -> kinded_hash -> tree + (** [shallow r h] is the shallow tree object with the hash [h]. No check is + performed to verify if [h] actually exists in [r]. *) + + (** {1 Proofs} *) + + val produce_proof : + repo -> kinded_hash -> (tree -> tree Lwt.t) -> Proof.t Lwt.t + (** [produce r h f] runs [f] on top of a real store [r], producing a proof + using the initial root hash [h]. + + The trees produced during [f]'s computation will carry the full history + of reads. This history will be reset when [f] is complete so subtrees + escaping the scope of [f] will not cause memory leaks. + + It is possible to call [produce_proof] recursively. In that case, each + input trees will have their own history of reads and will contain only + the reads needed to unshallow that corresponding trees. Proof trees + proof should then interact as if they were all unshallowed (note: in the + case of nested proofs, it's unclear what [verify_proof] should do...). *) + + val verify_proof : Proof.t -> (tree -> tree Lwt.t) -> tree Lwt.t + (** [verify t f] runs [f] in checking mode, loading data from the proof as + needed. + + The generated tree is the tree after [f] has completed. More operations + can be run on that tree, but it won't be able to access the underlying + storage. + + Reject the proof by raising [Proof.Bad_proof] unless the given + computation performs exactly the same state operations as the generating + computation, *in some order*. *) + end + + (** {1 Reads} *) + + val kind : t -> key -> [ `Contents | `Node ] option Lwt.t + (** [kind] is {!Tree.kind} applied to [t]'s root tree. *) + + val list : t -> key -> (step * tree) list Lwt.t + (** [list t] is {!Tree.list} applied to [t]'s root tree. *) + + val mem : t -> key -> bool Lwt.t + (** [mem t] is {!Tree.mem} applied to [t]'s root tree. *) + + val mem_tree : t -> key -> bool Lwt.t + (** [mem_tree t] is {!Tree.mem_tree} applied to [t]'s root tree. *) + + val find_all : t -> key -> (contents * metadata) option Lwt.t + (** [find_all t] is {!Tree.find_all} applied to [t]'s root tree. *) + + val find : t -> key -> contents option Lwt.t + (** [find t] is {!Tree.find} applied to [t]'s root tree. *) + + val get_all : t -> key -> (contents * metadata) Lwt.t + (** [get_all t] is {!Tree.get_all} applied on [t]'s root tree. *) + + val get : t -> key -> contents Lwt.t + (** [get t] is {!Tree.get} applied to [t]'s root tree. *) + + val find_tree : t -> key -> tree option Lwt.t + (** [find_tree t] is {!Tree.find_tree} applied to [t]'s root tree. *) + + val get_tree : t -> key -> tree Lwt.t + (** [get_tree t k] is {!Tree.get_tree} applied to [t]'s root tree. *) + + val hash : t -> key -> hash option Lwt.t + (** [hash t k] *) + + (** {1 Udpates} *) + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + (** The type for write errors. + + - Merge conflict. + - Concurrent transactions are competing to get the current operation + committed and too many attemps have been tried (livelock). + - A "test and set" operation has failed and the current value is [v] + instead of the one we were waiting for. *) + + val set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + contents -> + (unit, write_error) result Lwt.t + (** [set t k ~info v] sets [k] to the value [v] in [t]. Discard any previous + results but ensure that no operation is lost in the history. + + This function always uses {!Metadata.default} as metadata. Use {!set_tree} + with `[Contents (c, m)] for different ones. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + contents -> + unit Lwt.t + (** [set_exn] is like {!set} but raise [Failure _] instead of using a result + type. *) + + val set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + tree -> + (unit, write_error) result Lwt.t + (** [set_tree] is like {!set} but for trees. *) + + val set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + tree -> + unit Lwt.t + (** [set_tree] is like {!set_exn} but for trees. *) + + val remove : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + (unit, write_error) result Lwt.t + (** [remove t ~info k] remove any bindings to [k] in [t]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val remove_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + unit Lwt.t + (** [remove_exn] is like {!remove} but raise [Failure _] instead of a using + result type. *) + + val test_and_set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:contents option -> + set:contents option -> + (unit, write_error) result Lwt.t + (** [test_and_set ~test ~set] is like {!set} but it atomically checks that the + tree is [test] before modifying it to [set]. + + This function always uses {!Metadata.default} as metadata. Use + {!test_and_set_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Test t)] if the current tree is [t] instead of + [test]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val test_and_set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:contents option -> + set:contents option -> + unit Lwt.t + (** [test_and_set_exn] is like {!test_and_set} but raise [Failure _] instead + of using a result type. *) + + val test_and_set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:tree option -> + set:tree option -> + (unit, write_error) result Lwt.t + (** [test_and_set_tree] is like {!test_and_set} but for trees. *) + + val test_and_set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:tree option -> + set:tree option -> + unit Lwt.t + (** [test_and_set_tree_exn] is like {!test_and_set_exn} but for trees. *) + + val merge : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + key -> + contents option -> + (unit, write_error) result Lwt.t + (** [merge ~old] is like {!set} but merge the current tree and the new tree + using [old] as ancestor in case of conflicts. + + This function always uses {!Metadata.default} as metadata. Use + {!merge_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Conflict c)] if the merge failed with the conflict + [c]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val merge_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + key -> + contents option -> + unit Lwt.t + (** [merge_exn] is like {!merge} but raise [Failure _] instead of using a + result type. *) + + val merge_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + key -> + tree option -> + (unit, write_error) result Lwt.t + (** [merge_tree] is like {!merge_tree} but for trees. *) + + val merge_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + key -> + tree option -> + unit Lwt.t + (** [merge_tree] is like {!merge_tree} but for trees. *) + + val with_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + key -> + (tree option -> tree option Lwt.t) -> + (unit, write_error) result Lwt.t + (** [with_tree t k ~info f] replaces {i atomically} the subtree [v] under [k] + in the store [t] by the contents of the tree [f v], using the commit info + [info ()]. + + If [v = f v] and [allow_empty] is unset (default) then, the operation is a + no-op. + + If [v != f v] and no other changes happen concurrently, [f v] becomes the + new subtree under [k]. If other changes happen concurrently to that + operations, the semantics depend on the value of [strategy]: + + - if [strategy = `Set], use {!set} and discard any concurrent updates to + [k]. + - if [strategy = `Test_and_set] (default), use {!test_and_set} and ensure + that no concurrent operations are updating [k]. + - if [strategy = `Merge], use {!merge} and ensure that concurrent updates + and merged with the values present at the beginning of the transaction. + + {b Note:} Irmin transactions provides + {{:https://en.wikipedia.org/wiki/Snapshot_isolation} snapshot isolation} + guarantees: reads and writes are isolated in every transaction, but only + write conflicts are visible on commit. *) + + val with_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + key -> + (tree option -> tree option Lwt.t) -> + unit Lwt.t + (** [with_tree_exn] is like {!with_tree} but raise [Failure _] instead of + using a return type. *) + + (** {1 Clones} *) + + val clone : src:t -> dst:branch -> t Lwt.t + (** [clone ~src ~dst] makes [dst] points to [Head.get src]. [dst] is created + if needed. Remove the current contents en [dst] if [src] is {!empty}. *) + + (** {1 Watches} *) + + type watch + (** The type for store watches. *) + + val watch : t -> ?init:commit -> (commit S.diff -> unit Lwt.t) -> watch Lwt.t + (** [watch t f] calls [f] every time the contents of [t]'s head is updated. + + {b Note:} even if [f] might skip some head updates, it will never be + called concurrently: all consecutive calls to [f] are done in sequence, so + we ensure that the previous one ended before calling the next one. *) + + val watch_key : + t -> + key -> + ?init:commit -> + ((commit * tree) S.diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch_key t key f] calls [f] every time the [key]'s value is added, + removed or updated. If the current branch is deleted, no signal is sent to + the watcher. *) + + val unwatch : watch -> unit Lwt.t + (** [unwatch w] disable [w]. Return once the [w] is fully disabled. *) + + (** {1 Merges and Common Ancestors.} *) + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + (** The type for merge functions. *) + + val merge_into : into:t -> t merge + (** [merge_into ~into i t] merges [t]'s current branch into [x]'s current + branch using the info [i]. After that operation, the two stores are still + independent. Similar to [git merge ]. *) + + val merge_with_branch : t -> branch merge + (** Same as {!merge} but with a branch ID. *) + + val merge_with_commit : t -> commit merge + (** Same as {!merge} but with a commit ID. *) + + val lcas : + ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result Lwt.t + (** [lca ?max_depth ?n msg t1 t2] returns the collection of least common + ancestors between the heads of [t1] and [t2] branches. + + - [max_depth] is the maximum depth of the exploration (default is + [max_int]). Return [Error `Max_depth_reached] if this depth is exceeded. + - [n] is the maximum expected number of lcas. Stop the exploration as soon + as [n] lcas are found. Return [Error `Too_many_lcas] if more [lcas] are + found. *) + + val lcas_with_branch : + t -> + ?max_depth:int -> + ?n:int -> + branch -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a branch ID as argument. *) + + val lcas_with_commit : + t -> + ?max_depth:int -> + ?n:int -> + commit -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a commit ID as argument. *) + + (** {1 History} *) + + module History : Graph.Sig.P with type V.t = commit + (** An history is a DAG of heads. *) + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + (** [history ?depth ?min ?max t] is a view of the history of the store [t], of + depth at most [depth], starting from the [t]'s head (or from [max] if the + head is not set) and stopping at [min] if specified. *) + + val last_modified : ?depth:int -> ?n:int -> t -> key -> commit list Lwt.t + (** [last_modified ?number c k] is the list of the last [number] commits that + modified [key], in ascending order of date. [depth] is the maximum depth + to be explored in the commit graph, if any. Default value for [number] is + 1. *) + + (** Manipulate branches. *) + module Branch : sig + (** {1 Branch Store} + + Manipulate relations between {{!branch} branches} and {{!commit} + commits}. *) + + val mem : repo -> branch -> bool Lwt.t + (** [mem r b] is true iff [b] is present in [r]. *) + + val find : repo -> branch -> commit option Lwt.t + (** [find r b] is [Some c] iff [c] is bound to [b] in [t]. It is [None] if + [b] is not present in [t]. *) + + val get : repo -> branch -> commit Lwt.t + (** [get t b] is similar to {!find} but raise [Invalid_argument] if [b] is + not present in [t]. *) + + val set : repo -> branch -> commit -> unit Lwt.t + (** [set t b c] bounds [c] to [b] in [t]. *) + + val remove : repo -> branch -> unit Lwt.t + (** [remove t b] removes [b] from [t]. *) + + val list : repo -> branch list Lwt.t + (** [list t] is the list of branches present in [t]. *) + + val watch : + repo -> + branch -> + ?init:commit -> + (commit S.diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch t b f] calls [f] on every change in [b]. *) + + val watch_all : + repo -> + ?init:(branch * commit) list -> + (branch -> commit S.diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch_all t f] calls [f] on every branch-related change in [t], + including creation/deletion events. *) + + include Branch.S with type t = branch + (** Base functions for branches. *) + end + + (** [Key] provides base functions for the stores's paths. *) + module Key : Path.S with type t = key and type step = step + + module Metadata : S.METADATA with type t = metadata + (** [Metadata] provides base functions for node metadata. *) + + (** {1 Value Types} *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) + + val key_t : key Type.t + (** [key_t] is the value type for {!key}. *) + + val metadata_t : metadata Type.t + (** [metadata_t] is the value type for {!metadata}. *) + + val contents_t : contents Type.t + (** [contents_t] is the value type for {!contents}. *) + + val node_t : node Type.t + (** [node_t] is the value type for {!node}. *) + + val tree_t : tree Type.t + (** [tree_t] is the value type for {!tree}. *) + + val commit_t : repo -> commit Type.t + (** [commit_t r] is the value type for {!commit}. *) + + val branch_t : branch Type.t + (** [branch_t] is the value type for {!branch}. *) + + val slice_t : slice Type.t + (** [slice_t] is the value type for {!slice}. *) + + val kind_t : [ `Contents | `Node ] Type.t + (** [kind_t] is the value type for values returned by {!kind}. *) + + val lca_error_t : lca_error Type.t + (** [lca_error_t] is the value type for {!lca_error}. *) + + val ff_error_t : ff_error Type.t + (** [ff_error_t] is the value type for {!ff_error}. *) + + val write_error_t : write_error Type.t + (** [write_error_t] is the value type for {!write_error}. *) + + (** Private functions, which might be used by the backends. *) + module Private : sig + include + Private.S + with type Contents.value = contents + and module Hash = Hash + and module Node.Path = Key + and type Node.Metadata.t = metadata + and type Branch.key = branch + and type Slice.t = slice + and type Repo.t = repo + end + + type S.remote += + | E of Private.Sync.endpoint + (** Extend the [remote] type with [endpoint]. *) + + (** {2 Converters to private types} *) + + val to_private_node : node -> Private.Node.value Tree.or_error Lwt.t + val of_private_node : repo -> Private.Node.value -> node + + val to_private_commit : commit -> Private.Commit.value + (** [to_private_commit c] is the private commit object associated with the + commit [c]. *) + + val of_private_commit : repo -> Private.Commit.value -> commit + (** [of_private_commit r c] is the commit associated with the private commit + object [c]. *) + + val save_contents : [> write ] Private.Contents.t -> contents -> hash Lwt.t + (** Save a content into the database *) + + val save_tree : + ?clear:bool -> + repo -> + [> write ] Private.Contents.t -> + [> read_write ] Private.Node.t -> + tree -> + hash Lwt.t + (** Save a tree into the database. Does not do any reads. If [clear] is set + (it is by default), the tree cache will be cleared after the save. *) +end + +module type MAKER = functor + (M : S.METADATA) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) + -> + S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + and type Private.Sync.endpoint = unit + +module type Maker_future = sig + type endpoint + + module Make + (M : S.METADATA) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) : + S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + and type Private.Sync.endpoint = endpoint +end + +module type JSON_TREE = functor + (Store : S with type contents = Contents.json) + -> sig + include Contents.S with type t = Contents.json + + val to_concrete_tree : t -> Store.Tree.concrete + val of_concrete_tree : Store.Tree.concrete -> t + + val get_tree : Store.tree -> Store.key -> t Lwt.t + (** Extract a [json] value from tree at the given key. *) + + val set_tree : Store.tree -> Store.key -> t -> Store.tree Lwt.t + (** Project a [json] value onto a tree at the given key. *) + + val get : Store.t -> Store.key -> t Lwt.t + (** Extract a [json] value from a store at the given key. *) + + val set : Store.t -> Store.key -> t -> info:Info.f -> unit Lwt.t + (** Project a [json] value onto a store at the given key. *) +end + +module type Store = sig + module type S = S + module type MAKER = MAKER + module type JSON_TREE = JSON_TREE + + type Sigs.remote += Store : (module S with type t = 'a) * 'a -> Sigs.remote + + module Make (P : Private.S) : + S + with type key = P.Node.Path.t + and type contents = P.Contents.value + and type branch = P.Branch.key + and type hash = P.Hash.t + and type slice = P.Slice.t + and type step = P.Node.Path.step + and type metadata = P.Node.Metadata.t + and module Key = P.Node.Path + and type repo = P.Repo.t + and module Private = P + + module Json_tree : JSON_TREE + (** [Json_tree] is used to project JSON values onto trees. Instead of the + entire object being stored under one key, it is split across several keys + starting at the specified root key. *) + + module Content_addressable + (X : Sigs.APPEND_ONLY_STORE_MAKER) + (K : Hash.S) + (V : Type.S) : sig + include + Sigs.CONTENT_ADDRESSABLE_STORE + with type 'a t = 'a X(K)(V).t + and type key = K.t + and type value = V.t + + include BATCH with type 'a t := 'a t + include OF_CONFIG with type 'a t := 'a t + include CLOSEABLE with type 'a t := 'a t + end + + module type Maker_future = Maker_future + (** Exported for compatibility with a future version of Irmin. *) +end diff --git a/vendors/irmin/irmin/sync.ml b/vendors/irmin/irmin/sync.ml new file mode 100644 index 000000000000..73d406ca1993 --- /dev/null +++ b/vendors/irmin/irmin/sync.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Sync_intf + +module None (H : Type.S) (R : Type.S) = struct + type t = unit + + let v _ = Lwt.return_unit + + type endpoint = unit + type commit = H.t + type branch = R.t + + let fetch () ?depth:_ _ _br = + Lwt.return (Error (`Msg "fetch operation is not available")) + + let push () ?depth:_ _ _br = + Lwt.return (Error (`Msg "push operation is not available")) +end diff --git a/vendors/irmin/irmin/sync.mli b/vendors/irmin/irmin/sync.mli new file mode 100644 index 000000000000..18af62dd46d4 --- /dev/null +++ b/vendors/irmin/irmin/sync.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store Synchronisation signatures. *) + +include Sync_intf.Sync diff --git a/vendors/irmin/irmin/sync_ext.ml b/vendors/irmin/irmin/sync_ext.ml new file mode 100644 index 000000000000..6de62880a703 --- /dev/null +++ b/vendors/irmin/irmin/sync_ext.ml @@ -0,0 +1,218 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Sync_ext_intf + +let invalid_argf fmt = Fmt.kstr Lwt.fail_invalid_arg fmt +let src = Logs.Src.create "irmin.sync" ~doc:"Irmin remote sync" + +module Log = (val Logs.src_log src : Logs.LOG) + +let remote_store m x = Store.Store (m, x) + +module Make (S : Store.S) = struct + module B = S.Private.Sync + + type db = S.t + type commit = S.commit + + let conv dx dy = + let dx_to_bin_string = Type.(unstage (to_bin_string dx)) in + let dy_of_bin_string = Type.(unstage (of_bin_string dy)) in + Type.stage (fun x -> dy_of_bin_string (dx_to_bin_string x)) + + let convert_slice (type r s) (module RP : Private.S with type Slice.t = r) + (module SP : Private.S with type Slice.t = s) r = + let conv_contents_k = + Type.unstage (conv RP.Contents.Key.t SP.Contents.Key.t) + in + let conv_contents_v = + Type.unstage (conv RP.Contents.Val.t SP.Contents.Val.t) + in + let conv_node_k = Type.unstage (conv RP.Node.Key.t SP.Node.Key.t) in + let conv_node_v = Type.unstage (conv RP.Node.Val.t SP.Node.Val.t) in + let conv_commit_k = Type.unstage (conv RP.Commit.Key.t SP.Commit.Key.t) in + let conv_commit_v = Type.unstage (conv RP.Commit.Val.t SP.Commit.Val.t) in + let* s = SP.Slice.empty () in + let* () = + RP.Slice.iter r (function + | `Contents (k, v) -> ( + let k = conv_contents_k k in + let v = conv_contents_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Contents (k, v)) + | _ -> Lwt.return_unit) + | `Node (k, v) -> ( + let k = conv_node_k k in + let v = conv_node_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Node (k, v)) + | _ -> Lwt.return_unit) + | `Commit (k, v) -> ( + let k = conv_commit_k k in + let v = conv_commit_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) + | _ -> Lwt.return_unit)) + in + Lwt.return s + + let convs src dst l = + let conv = Type.unstage (conv src dst) in + List.fold_left + (fun acc x -> match conv x with Ok x -> x :: acc | _ -> acc) + [] l + + let pp_branch = Type.pp S.Branch.t + let pp_hash = Type.pp S.Hash.t + + type status = [ `Empty | `Head of commit ] + + let pp_status ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Head c -> Type.pp S.Hash.t ppf (S.Commit.hash c) + + let status_t t = + let open Type in + variant "status" (fun empty head -> function + | `Empty -> empty | `Head c -> head c) + |~ case0 "empty" `Empty + |~ case1 "head" S.(commit_t @@ repo t) (fun c -> `Head c) + |> sealv + + let fetch t ?depth remote = + match remote with + | Store.Store ((module R), r) -> ( + Log.debug (fun f -> f "fetch store"); + let s_repo = S.repo t in + let r_repo = R.repo r in + let conv = + Type.unstage (conv R.(commit_t r_repo) S.(commit_t s_repo)) + in + let* min = S.Repo.heads s_repo in + let min = convs S.(commit_t s_repo) R.(commit_t r_repo) min in + R.Head.find r >>= function + | None -> Lwt.return (Ok `Empty) + | Some h -> ( + let* r_slice = + R.Repo.export (R.repo r) ?depth ~min ~max:(`Max [ h ]) + in + let* s_slice = + convert_slice (module R.Private) (module S.Private) r_slice + in + S.Repo.import s_repo s_slice >|= function + | Error e -> Error e + | Ok () -> ( + match conv h with Ok h -> Ok (`Head h) | Error e -> Error e))) + | S.E e -> ( + match S.status t with + | `Empty | `Commit _ -> Lwt.return (Ok `Empty) + | `Branch br -> ( + Log.debug (fun l -> l "Fetching branch %a" pp_branch br); + let* g = B.v (S.repo t) in + B.fetch g ?depth e br >>= function + | Error _ as e -> Lwt.return e + | Ok (Some c) -> ( + Log.debug (fun l -> l "Fetched %a" pp_hash c); + S.Commit.of_hash (S.repo t) c >|= function + | None -> Ok `Empty + | Some x -> Ok (`Head x)) + | Ok None -> ( + S.Head.find t >>= function + | Some h -> Lwt.return (Ok (`Head h)) + | None -> Lwt.return (Ok `Empty)))) + | _ -> Lwt.return (Error (`Msg "fetch operation is not available")) + + let fetch_exn t ?depth remote = + fetch t ?depth remote >>= function + | Ok h -> Lwt.return h + | Error (`Msg e) -> invalid_argf "Sync.fetch_exn: %s" e + + type pull_error = [ `Msg of string | Merge.conflict ] + + let pp_pull_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Conflict c -> Fmt.pf ppf "conflict: %s" c + + let pull t ?depth remote kind : (status, pull_error) result Lwt.t = + fetch t ?depth remote >>= function + | Error e -> Lwt.return (Error (e :> pull_error)) + | Ok (`Head k) -> ( + match kind with + | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) + | `Merge info -> ( + S.Head.merge ~into:t ~info k >>= function + | Ok () -> Lwt.return (Ok (`Head k)) + | Error e -> Lwt.return (Error (e :> pull_error)))) + | Ok `Empty -> Lwt.return (Ok `Empty) + + let pull_exn t ?depth remote kind = + pull t ?depth remote kind >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.pull_exn: %a" pp_pull_error e + + type push_error = [ `Msg of string | `Detached_head ] + + let pp_push_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Detached_head -> Fmt.string ppf "cannot push to a non-persistent store" + + let push t ?depth remote = + Log.debug (fun f -> f "push"); + match remote with + | Store.Store ((module R), r) -> ( + S.Head.find t >>= function + | None -> Lwt.return (Ok `Empty) + | Some h -> ( + Log.debug (fun f -> f "push store"); + let* min = R.Repo.heads (R.repo r) in + let r_repo = R.repo r in + let s_repo = S.repo t in + let min = convs R.(commit_t r_repo) S.(commit_t s_repo) min in + let conv = + Type.unstage (conv S.(commit_t s_repo) R.(commit_t r_repo)) + in + let* s_slice = S.Repo.export (S.repo t) ?depth ~min in + let* r_slice = + convert_slice (module S.Private) (module R.Private) s_slice + in + R.Repo.import (R.repo r) r_slice >>= function + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok () -> ( + match conv h with + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok h -> + R.Head.set r h >>= fun () -> + let+ head = S.Head.get t in + Ok (`Head head)))) + | S.E e -> ( + match S.status t with + | `Empty -> Lwt.return (Ok `Empty) + | `Commit _ -> Lwt.return (Error `Detached_head) + | `Branch br -> ( + let* head = S.of_branch (S.repo t) br >>= S.Head.get in + let* g = B.v (S.repo t) in + B.push g ?depth e br >>= function + | Ok () -> Lwt.return (Ok (`Head head)) + | Error err -> Lwt.return (Error (err :> push_error)))) + | _ -> Lwt.return (Error (`Msg "push operation is not available")) + + let push_exn t ?depth remote = + push t ?depth remote >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.push_exn: %a" pp_push_error e +end diff --git a/vendors/irmin/irmin/sync_ext.mli b/vendors/irmin/irmin/sync_ext.mli new file mode 100644 index 000000000000..9178981df9e3 --- /dev/null +++ b/vendors/irmin/irmin/sync_ext.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store Synchronisation. *) + +include Sync_ext_intf.Sync_ext diff --git a/vendors/irmin/irmin/sync_ext_intf.ml b/vendors/irmin/irmin/sync_ext_intf.ml new file mode 100644 index 000000000000..5e78c274c8d9 --- /dev/null +++ b/vendors/irmin/irmin/sync_ext_intf.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open S + +module type SYNC_STORE = sig + (** {1 Native Synchronization} *) + + type db + (** Type type for store handles. *) + + type commit + (** The type for store heads. *) + + type status = [ `Empty | `Head of commit ] + (** The type for remote status. *) + + val status_t : db -> status Type.t + (** [status_t db] is the value type for {!status} of remote [db]. *) + + val pp_status : status Fmt.t + (** [pp_status] pretty-prints return statuses. *) + + val fetch : + db -> ?depth:int -> remote -> (status, [ `Msg of string ]) result Lwt.t + (** [fetch t ?depth r] populate the local store [t] with objects for the + remote store [r], using [t]'s current branch. The [depth] parameter limits + the history depth. Return [`Empty] if either the local or remote store do + not have a valid head. *) + + val fetch_exn : db -> ?depth:int -> remote -> status Lwt.t + (** Same as {!fetch} but raise [Invalid_argument] if either the local or + remote store do not have a valid head. *) + + type pull_error = [ `Msg of string | Merge.conflict ] + (** The type for pull errors. *) + + val pp_pull_error : pull_error Fmt.t + (** [pp_push_error] pretty-prints pull errors. *) + + val pull : + db -> + ?depth:int -> + remote -> + [ `Merge of Info.f | `Set ] -> + (status, pull_error) result Lwt.t + (** [pull t ?depth r s] is similar to {{!Sync.fetch} fetch} but it also + updates [t]'s current branch. [s] is the update strategy: + + - [`Merge] uses [Head.merge]. Can return a conflict. + - [`Set] uses [S.Head.set]. *) + + val pull_exn : + db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> status Lwt.t + (** Same as {!pull} but raise [Invalid_arg] in case of conflict. *) + + type push_error = [ `Msg of string | `Detached_head ] + (** The type for push errors. *) + + val pp_push_error : push_error Fmt.t + (** [pp_push_error] pretty-prints push errors. *) + + val push : db -> ?depth:int -> remote -> (status, push_error) result Lwt.t + (** [push t ?depth r] populates the remote store [r] with objects from the + current store [t], using [t]'s current branch. If [b] is [t]'s current + branch, [push] also updates the head of [b] in [r] to be the same as in + [t]. + + {b Note:} {e Git} semantics is to update [b] only if the new head if more + recent. This is not the case in {e Irmin}. *) + + val push_exn : db -> ?depth:int -> remote -> status Lwt.t + (** Same as {!push} but raise [Invalid_argument] if an error happens. *) +end + +module type Sync_ext = sig + module type SYNC_STORE = SYNC_STORE + + val remote_store : (module Store.S with type t = 'a) -> 'a -> remote + + module Make (X : Store.S) : + SYNC_STORE with type db = X.t and type commit = X.commit +end diff --git a/vendors/irmin/irmin/sync_intf.ml b/vendors/irmin/irmin/sync_intf.ml new file mode 100644 index 000000000000..170015d60df7 --- /dev/null +++ b/vendors/irmin/irmin/sync_intf.ml @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Remote synchronization} *) + + type t + (** The type for store handles. *) + + type commit + (** The type for store heads. *) + + type branch + (** The type for branch IDs. *) + + type endpoint + (** The type for sync endpoints. *) + + val fetch : + t -> + ?depth:int -> + endpoint -> + branch -> + (commit option, [ `Msg of string ]) result Lwt.t + (** [fetch t uri] fetches the contents of the remote store located at [uri] + into the local store [t]. Return the head of the remote branch with the + same name, which is now in the local store. [No_head] means no such branch + exists. *) + + val push : + t -> + ?depth:int -> + endpoint -> + branch -> + (unit, [ `Msg of string | `Detached_head ]) result Lwt.t + (** [push t uri] pushes the contents of the local store [t] into the remote + store located at [uri]. *) +end + +module type Sync = sig + module type S = S + + (** Provides stub implementations of the {!S} that always returns [Error] when + push/pull operations are attempted. *) + module None (H : Type.S) (R : Type.S) : sig + include + S with type commit = H.t and type branch = R.t and type endpoint = unit + + val v : 'a -> t Lwt.t + (** Create a remote store handle. *) + end +end diff --git a/vendors/irmin/irmin/tree.ml b/vendors/irmin/irmin/tree.ml new file mode 100644 index 000000000000..42abad0d5c69 --- /dev/null +++ b/vendors/irmin/irmin/tree.ml @@ -0,0 +1,2053 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Tree_intf +module Irmin_node = Node + +let src = Logs.Src.create "irmin.tree" ~doc:"Persistent lazy trees for Irmin" + +module Log = (val Logs.src_log src : Logs.LOG) + +type fuzzy_bool = False | True | Maybe +type ('a, 'r) cont = ('a -> 'r) -> 'r +type ('a, 'r) cont_lwt = ('a, 'r Lwt.t) cont + +let ok x = Lwt.return (Ok x) + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = + match (l1, l2) with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1, v1) :: t1, (k2, v2) :: t2 -> ( + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + (aux [@tailcall]) t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + (aux [@tailcall]) t1 l2) + else ( + f k2 (`Right v2); + (aux [@tailcall]) l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_s (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !l3) + +module Make (P : Private.S) = struct + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; + } + [@@deriving irmin] + + let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t + + let fresh_counters () = + { + contents_hash = 0; + contents_add = 0; + contents_find = 0; + node_hash = 0; + node_mem = 0; + node_add = 0; + node_find = 0; + node_val_v = 0; + node_val_find = 0; + node_val_list = 0; + } + + let reset_counters t = + t.contents_hash <- 0; + t.contents_add <- 0; + t.contents_find <- 0; + t.node_hash <- 0; + t.node_mem <- 0; + t.node_add <- 0; + t.node_find <- 0; + t.node_val_v <- 0; + t.node_val_find <- 0; + t.node_val_list <- 0 + + let cnt = fresh_counters () + + module Path = P.Node.Path + + module StepMap = struct + module X = struct + type t = Path.step + + let t = Path.step_t + let compare = Type.(unstage (compare Path.step_t)) + end + + include Map.Make (X) + + let stdlib_merge = merge + + include Merge.Map (X) + + let to_array m = + let length = cardinal m in + if length = 0 then [||] + else + let arr = Array.make length (choose m) in + let (_ : int) = + fold + (fun k v i -> + arr.(i) <- (k, v); + i + 1) + m 0 + in + arr + end + + module Metadata = P.Node.Metadata + + type key = Path.t + type hash = P.Hash.t + + let compare_hash = Type.(unstage (compare P.Hash.t)) + + type error = [ `Dangling_hash of hash | `Pruned_hash of hash ] + type 'a or_error = ('a, error) result + type step = Path.step + type contents = P.Contents.value + type repo = P.Repo.t + + let pp_hash = Type.pp P.Hash.t + let pp_step = Type.pp Path.step_t + let pp_path = Type.pp Path.t + + module Hashes = Hashtbl.Make (struct + type t = hash + + let hash = P.Hash.short_hash + let equal = Type.(unstage (equal P.Hash.t)) + end) + + let dummy_marks = Hashes.create 0 + + type marks = unit Hashes.t + + let empty_marks () = Hashes.create 39 + + type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] + type uniq = [ `False | `True | `Marks of marks ] + type 'a node_fn = key -> step list -> 'a -> 'a Lwt.t + + type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + [@@deriving irmin] + + let equal_contents = Type.(unstage (equal P.Contents.Val.t)) + let equal_metadata = Type.(unstage (equal Metadata.t)) + let equal_hash = Type.(unstage (equal P.Hash.t)) + let equal_node = Type.(unstage (equal P.Node.Val.t)) + + exception Pruned_hash of { context : string; hash : hash } + exception Dangling_hash of { context : string; hash : hash } + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered dangling hash %a" context + pp_hash hash) + | Pruned_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered pruned hash %a" context pp_hash + hash) + | _ -> None) + + let err_pruned h = Error (`Pruned_hash h) + let raise_pruned context hash = raise (Pruned_hash { context; hash }) + + let get_ok : type a. string -> a or_error -> a = + fun context -> function + | Ok x -> x + | Error (`Pruned_hash hash) -> raise_pruned context hash + | Error (`Dangling_hash hash) -> raise (Dangling_hash { context; hash }) + + module Env = Proof.Env (P.Hash) (P.Contents.Val) (P.Node.Val) + + module Contents = struct + type v = Hash of repo option * hash | Value of contents + + type info = { + mutable hash : hash option; + mutable value : contents option; + env : Env.t; + } + + type t = { mutable v : v; info : info } + + let info_is_empty i = i.hash = None && i.value = None + + let v = + let open Type in + variant "Node.Contents.v" (fun hash value -> function + | Hash (_, x) -> hash x | Value v -> value v) + |~ case1 "hash" P.Hash.t (fun h -> Hash (None, h)) + |~ case1 "value" P.Contents.Val.t (fun v -> Value v) + |> sealv + + let clear_info i = + if not (info_is_empty i) then ( + i.value <- None; + i.hash <- None) + + let clear t = clear_info t.info + + let of_v ~env ?hash v = + let hash = + match (v, hash) with + | Hash (_, k), _ -> Some k + | _, (Some _ as k) -> k + | _ -> None + in + let value = match v with Value v -> Some v | _ -> None in + let info = { hash; value; env } in + { v; info } + + let export ?clear:(c = true) repo t k = + let hash = t.info.hash in + if c then clear t; + match (t.v, hash) with + | Hash (None, _), _ -> + (* The main export function never exports a pruned position. *) + assert false + | Hash (Some repo', _), _ when repo == repo' -> () + | Hash (_, k), _ -> t.v <- Hash (Some repo, k) + | Value _, None -> t.v <- Hash (Some repo, k) + | Value _, Some k -> t.v <- Hash (Some repo, k) + + let of_value ?hash c = of_v ?hash (Value c) + let of_hash repo k = of_v (Hash (repo, k)) + + let cached_hash t = + match (t.v, t.info.hash) with + | Hash (_, k), None -> + let h = Some k in + t.info.hash <- h; + h + | _, h -> h + + let cached_value t = + match (t.v, t.info.value) with + | Value v, None -> Some v + | _, (Some _ as v) -> v + | _ -> ( + match cached_hash t with + | None -> None + | Some h -> ( + match Env.find_contents t.info.env h with + | None -> None + | Some c -> Some c)) + + let hash ?(cache = true) c = + match cached_hash c with + | Some k -> k + | None -> ( + match cached_value c with + | None -> assert false + | Some v -> + cnt.contents_hash <- cnt.contents_hash + 1; + let k = P.Contents.Key.hash v in + if cache then c.info.hash <- Some k; + k) + + let value_of_hash ~cache t repo k = + match cached_value t with + | Some v -> Lwt.return_ok v + | None -> ( + cnt.contents_find <- cnt.contents_find + 1; + let+ some_v = P.Contents.find (P.Repo.contents_t repo) k in + Option.iter (Env.add_contents_from_store t.info.env k) some_v; + if cache then t.info.value <- some_v; + match some_v with None -> Error (`Dangling_hash k) | Some v -> Ok v) + + let to_value_aux ~cache ~value_of_hash ~return t = + match cached_value t with + | Some v -> return (Ok v) + | None -> ( + match t.v with + | Value v -> return (Ok v) + | Hash (Some repo, k) -> value_of_hash ~cache t repo k + | Hash (None, h) -> return (err_pruned h)) + + let to_value = to_value_aux ~value_of_hash ~return:Lwt.return + let force = to_value ~cache:true + + let force_exn t = + force t >|= function + | Ok v -> v + | Error (`Pruned_hash hash) -> + raise (Pruned_hash { context = "force_exn"; hash }) + | Error (`Dangling_hash hash) -> + raise (Dangling_hash { context = "force_exn"; hash }) + + let equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_contents x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare v of_v (fun t -> t.v) + + let merge : t Merge.t = + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let+ c = to_value ~cache:true old >|= Option.of_result in + Ok (Some c)) + in + let x_env = x.info.env in + let y_env = y.info.env in + let* x = to_value ~cache:true x >|= Option.of_result in + let* y = to_value ~cache:true y >|= Option.of_result in + Merge.(f P.Contents.Val.merge) ~old x y >|= function + | Ok (Some c) -> + Env.merge x_env y_env; + Ok (of_value ~env:x_env c) + | Ok None -> Error (`Conflict "empty contents") + | Error _ as e -> e + in + Merge.v t f + + let fold ~force ~cache ~path f_value f_tree t acc = + match force with + | `True -> + let* c = to_value ~cache t in + f_value path (get_ok "fold" c) acc >>= f_tree path + | `False skip -> ( + match cached_value t with + | None -> skip path acc + | Some c -> f_value path c acc >>= f_tree path) + end + + module Node = struct + type value = P.Node.Val.t + + type elt = [ `Node of t | `Contents of Contents.t * Metadata.t ] + + and update = Add of elt | Remove + + and updatemap = update StepMap.t + + and map = elt StepMap.t + + and info = { + mutable value : value option; + mutable map : map option; + mutable hash : hash option; + mutable findv_cache : map option; + env : Env.t; + } + + and v = + | Map of map + | Hash of repo option * hash + | Value of repo option * value * updatemap option + + and t = { mutable v : v; info : info } + (** [t.v] has 3 possible states: + + - A [Map], only after a [Tree.of_concrete] operation. + - A [Value], only after an add, a remove, temporarily during an export + or at the end of a merge. + - It is otherwise a [Hash]. + + [t.info.map] is only populated during a call to [Node.to_map]. *) + + let elt_t (t : t Type.t) : elt Type.t = + let open Type in + variant "Node.value" (fun node contents contents_m -> function + | `Node x -> node x + | `Contents (c, m) -> + if equal_metadata m Metadata.default then contents c + else contents_m (c, m)) + |~ case1 "Node" t (fun x -> `Node x) + |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) + |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) + |> sealv + + let stepmap_t : 'a. 'a Type.t -> 'a StepMap.t Type.t = + fun elt -> + let open Type in + let to_map x = + List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x + in + let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in + map (list (pair Path.step_t elt)) to_map of_map + + let update_t (elt : elt Type.t) : update Type.t = + let open Type in + variant "Node.update" (fun add remove -> function + | Add elt -> add elt | Remove -> remove) + |~ case1 "add" elt (fun elt -> Add elt) + |~ case0 "remove" Remove + |> sealv + + let v_t (elt : elt Type.t) : v Type.t = + let m = stepmap_t elt in + let um = stepmap_t (update_t elt) in + let open Type in + variant "Node.node" (fun map hash value -> function + | Map m -> map m + | Hash (_, y) -> hash y + | Value (_, v, m) -> value (v, m)) + |~ case1 "map" m (fun m -> Map m) + |~ case1 "hash" P.Hash.t (fun h -> Hash (None, h)) + |~ case1 "value" + (pair P.Node.Val.t (option um)) + (fun (v, o) -> Value (None, v, o)) + |> sealv + + let of_v ~env v = + let hash = match v with Hash (_, k) -> Some k | _ -> None in + let value = match v with Value (_, v, None) -> Some v | _ -> None in + let map = match v with Map m -> Some m | _ -> None in + let findv_cache = None in + let info = { hash; map; value; findv_cache; env } in + { v; info } + + let of_map m = of_v (Map m) + let of_hash repo k = of_v (Hash (repo, k)) + let of_value ?updates repo v = of_v (Value (repo, v, updates)) + + let cached_hash t = + match (t.v, t.info.hash) with + | Hash (_, h), None -> + let h = Some h in + t.info.hash <- h; + h + | _, h -> h + + let cached_map t = + match (t.v, t.info.map) with + | Map m, None -> + let m = Some m in + t.info.map <- m; + m + | _, m -> m + + let cached_value t = + match (t.v, t.info.value) with + | Value (_, v, None), None -> Some v + | _, (Some _ as v) -> v + | _ -> ( + match cached_hash t with + | None -> None + | Some h -> ( + match Env.find_node t.info.env h with + | None -> None + | Some c -> Some c)) + + let info_is_empty i = + i.map = None && i.value = None && i.findv_cache = None && i.hash = None + + let clear_info_fields i = + if not (info_is_empty i) then ( + i.value <- None; + i.map <- None; + i.hash <- None; + i.findv_cache <- None) + + let rec clear_elt ~max_depth depth v = + match v with + | `Contents (c, _) -> if depth + 1 > max_depth then Contents.clear c + | `Node t -> clear ~max_depth (depth + 1) t + + and clear_info ~max_depth ?v depth i = + let clear _ v = clear_elt ~max_depth depth v in + let () = + match v with + | Some (Value (_, _, Some um)) -> + StepMap.iter + (fun k -> function Remove -> () | Add v -> clear k v) + um + | _ -> () + in + let () = + match (v, i.map) with + | Some (Map m), _ | _, Some m -> StepMap.iter clear m + | _ -> () + in + let () = + match i.findv_cache with Some m -> StepMap.iter clear m | None -> () + in + if depth >= max_depth then clear_info_fields i + + and clear ~max_depth depth t = clear_info ~v:t.v ~max_depth depth t.info + + (* export t to the given repo and clear the cache *) + let export ?clear:(c = true) repo t k = + let hash = t.info.hash in + if c then clear_info_fields t.info; + match t.v with + | Hash (None, _) | Value (None, _, _) -> + (* The main export function never exports a pruned position. *) + assert false + | Hash (repo', _) when repo' == repo -> () + | Hash (_, k) -> t.v <- Hash (repo, k) + | _ -> ( + match hash with + | None -> t.v <- Hash (repo, k) + | Some k -> t.v <- Hash (repo, k)) + + let map_of_value ~cache ~env repo (n : value) : map = + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = P.Node.Val.seq ~cache n in + let aux = function + | `Node h -> `Node (of_hash ~env repo h) + | `Contents (c, m) -> `Contents (Contents.of_hash ~env repo c, m) + in + Seq.fold_left + (fun acc (k, v) -> StepMap.add k (aux v) acc) + StepMap.empty entries + + let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = + fun ~cache t k -> + match cached_hash t with + | Some h -> k h + | None -> ( + let a_of_value v = + cnt.node_hash <- cnt.node_hash + 1; + let h = P.Node.Key.hash v in + if cache then t.info.hash <- Some h; + k h + in + match cached_value t with + | Some v -> a_of_value v + | None -> ( + match t.v with + | Hash (_, h) -> k h + | Value (_, v, None) -> a_of_value v + | Value (_, v, Some um) -> + value_of_updates ~cache t v um a_of_value + | Map m -> value_of_map ~cache t m a_of_value)) + + and value_of_map : type r. cache:bool -> t -> map -> (value, r) cont = + fun ~cache t map k -> + cnt.node_val_v <- cnt.node_val_v + 1; + let v = + StepMap.to_seq map + |> Seq.map (function + | step, `Contents (c, m) -> + (step, `Contents (Contents.hash ~cache c, m)) + | step, `Node n -> (step, hash ~cache n (fun h -> `Node h))) + |> P.Node.Val.of_seq + in + if cache then t.info.value <- Some v; + k v + + and value_of_elt : type r. cache:bool -> elt -> (P.Node.Val.value, r) cont = + fun ~cache e k -> + match e with + | `Contents (c, m) -> k (`Contents (Contents.hash ~cache c, m)) + | `Node n -> hash ~cache n (fun h -> k (`Node h)) + + and value_of_updates : + type r. cache:bool -> t -> value -> _ -> (value, r) cont = + fun ~cache t v updates k -> + let updates = StepMap.bindings updates in + let rec aux acc = function + | [] -> + if cache then t.info.value <- Some acc; + k acc + | (k, Add e) :: rest -> + value_of_elt ~cache e (fun e -> aux (P.Node.Val.add acc k e) rest) + | (k, Remove) :: rest -> aux (P.Node.Val.remove acc k) rest + in + aux v updates + + let hash ~cache k = hash ~cache k (fun x -> x) + + let value_of_hash ~cache t repo k = + match cached_value t with + | Some v -> Lwt.return_ok v + | None -> ( + cnt.node_find <- cnt.node_find + 1; + let+ some_v = P.Node.find (P.Repo.node_t repo) k in + Option.iter (Env.add_node_from_store t.info.env k) some_v; + if cache then t.info.value <- some_v; + match some_v with None -> Error (`Dangling_hash k) | Some v -> Ok v) + + let to_value_aux ~cache ~value_of_hash ~return t = + let ok x = return (Ok x) in + match cached_value t with + | Some v -> ok v + | None -> ( + match t.v with + | Value (_, v, None) -> ok v + | Value (_, v, Some um) -> value_of_updates ~cache t v um ok + | Map m -> value_of_map ~cache t m ok + | Hash (Some repo, h) -> value_of_hash ~cache t repo h + | Hash (None, h) -> return (err_pruned h)) + + let to_value = to_value_aux ~value_of_hash ~return:Lwt.return + + let to_map ~cache t = + match cached_map t with + | Some m -> Lwt.return (Ok m) + | None -> ( + let env = t.info.env in + let of_value repo v updates = + let m = map_of_value ~cache ~env repo v in + let m = + match updates with + | None -> m + | Some updates -> + StepMap.stdlib_merge + (fun _ left right -> + match (left, right) with + | None, None -> assert false + | (Some _ as v), None -> v + | _, Some (Add v) -> Some v + | _, Some Remove -> None) + m updates + in + if cache then t.info.map <- Some m; + m + in + match t.v with + | Map m -> Lwt.return (Ok m) + | Value (repo, v, m) -> Lwt.return (Ok (of_value repo v m)) + | Hash (Some repo, k) -> ( + value_of_hash ~cache t repo k >|= function + | Error _ as e -> e + | Ok v -> Ok (of_value (Some repo) v None)) + | Hash (None, h) -> Lwt.return (err_pruned h)) + + let hash_equal x y = x == y || equal_hash x y + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let rec elt_equal (x : elt) (y : elt) = + x == y + || + match (x, y) with + | `Contents x, `Contents y -> contents_equal x y + | `Node x, `Node y -> equal x y + | _ -> false + + and map_equal (x : map) (y : map) = StepMap.equal elt_equal x y + + and equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_node x y + | _ -> ( + match (cached_map x, cached_map y) with + | Some x, Some y -> map_equal x y + | _ -> hash_equal (hash ~cache:true x) (hash ~cache:true y))) + + (* same as [equal] but do not compare in-memory maps + recursively. *) + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (cached_hash x, cached_hash y) with + | Some x, Some y -> if equal_hash x y then True else False + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> if equal_node x y then True else False + | _ -> Maybe) + + let empty () = of_map StepMap.empty ~env:(Env.empty ()) + let empty_hash = hash ~cache:false (empty ()) + + (** Does [um] empties [v]? + + Gotcha: Some [Remove] entries in [um] might not be in [v]. *) + let is_empty_after_updates ~cache v um = + let any_add = + StepMap.to_seq um + |> Seq.exists (function _, Remove -> false | _, Add _ -> true) + in + if any_add then false + else + let val_is_empty = P.Node.Val.is_empty v in + if val_is_empty then true + else + let remove_count = StepMap.cardinal um in + if (not val_is_empty) && remove_count = 0 then false + else if P.Node.Val.length v > remove_count then false + else ( + (* Starting from this point the function is expensive, but there is + no alternative. *) + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = P.Node.Val.seq ~cache v in + Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) + + let length ~cache t = + match cached_map t with + | Some m -> StepMap.cardinal m |> Lwt.return + | None -> + let+ v = to_value ~cache t in + get_ok "length" v |> P.Node.Val.length + + let is_empty ~cache t = + match cached_map t with + | Some m -> StepMap.is_empty m + | None -> ( + match cached_value t with + | Some v -> P.Node.Val.is_empty v + | None -> ( + match t.v with + | Value (_, v, Some um) -> is_empty_after_updates ~cache v um + | Hash (_, h) -> hash_equal empty_hash h + | Map _ -> assert false (* [cached_map <> None] *) + | Value (_, _, None) -> assert false (* [cached_value <> None] *)) + ) + + let add_to_findv_cache t step v = + match t.info.findv_cache with + | None -> t.info.findv_cache <- Some (StepMap.singleton step v) + | Some m -> t.info.findv_cache <- Some (StepMap.add step v m) + + let findv_aux ~cache ~value_of_hash ~return ~bind ctx t step = + let of_map m = try Some (StepMap.find step m) with Not_found -> None in + let of_value repo v = + let env = t.info.env in + match P.Node.Val.find ~cache v step with + | None -> None + | Some (`Contents (c, m)) -> + let c = Contents.of_hash ~env repo c in + let (v : elt) = `Contents (c, m) in + if cache then add_to_findv_cache t step v; + Some v + | Some (`Node n) -> + let n = of_hash ~env repo n in + let v = `Node n in + if cache then add_to_findv_cache t step v; + Some v + in + let of_t () = + match t.v with + | Map m -> return (of_map m) + | Value (repo, v, None) -> return (of_value repo v) + | Value (repo, v, Some um) -> ( + match StepMap.find_opt step um with + | Some (Add v) -> return (Some v) + | Some Remove -> return None + | None -> return (of_value repo v)) + | Hash (repo, h) -> ( + match cached_value t with + | Some v -> return (of_value repo v) + | None -> ( + match repo with + | None -> raise_pruned "Node.find" h + | Some repo -> + bind (value_of_hash ~cache t repo h) (fun v -> + let v = get_ok ctx v in + return (of_value (Some repo) v)))) + in + + match cached_map t with + | Some m -> return (of_map m) + | None -> ( + match t.info.findv_cache with + | None -> of_t () + | Some m -> ( + match of_map m with None -> of_t () | Some _ as r -> return r)) + + let findv = findv_aux ~value_of_hash ~return:Lwt.return ~bind:Lwt.bind + + let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t = + let take seq = + match length with None -> seq | Some n -> Seq.take n seq + in + StepMap.to_seq m |> Seq.drop offset |> take + + let seq_of_value ~env repo ?offset ?length ~cache v : (step * elt) Seq.t = + cnt.node_val_list <- cnt.node_val_list + 1; + let seq = P.Node.Val.seq ?offset ?length ~cache v in + Seq.map + (fun (k, v) -> + match v with + | `Node n -> + let n = `Node (of_hash ~env repo n) in + (k, n) + | `Contents (c, m) -> + let c = Contents.of_hash ~env repo c in + (k, `Contents (c, m))) + seq + + let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error Lwt.t = + let env = t.info.env in + match cached_map t with + | Some m -> ok (seq_of_map ?offset ?length m) + | None -> ( + match cached_value t with + | Some n -> ok (seq_of_value ~env ?offset ?length ~cache None n) + | _ -> ( + match t.v with + | Hash (Some repo, h) -> ( + value_of_hash ~cache t repo h >>= function + | Error _ as e -> Lwt.return e + | Ok v -> + ok + (seq_of_value ~env ?offset ?length ~cache (Some repo) v) + ) + | _ -> ( + to_map ~cache t >>= function + | Error _ as e -> Lwt.return e + | Ok m -> ok (seq_of_map ?offset ?length m)))) + + let bindings ~cache t = + (* XXX: If [t] is value, no need to [to_map]. Let's remove and inline + this into Tree.entries. *) + to_map ~cache t >|= function + | Error _ as e -> e + | Ok m -> Ok (StepMap.bindings m) + + let seq_of_updates updates value_bindings = + (* This operation can be costly for large updates. *) + if StepMap.is_empty updates then + (* Short-circuit return if we have no more updates to apply. *) + value_bindings + else + let value_bindings = + Seq.filter (fun (s, _) -> not (StepMap.mem s updates)) value_bindings + in + let updates = + StepMap.to_seq updates + |> Seq.filter_map (fun (s, elt) -> + match elt with Remove -> None | Add e -> Some (s, e)) + in + Seq.append value_bindings updates + + type ('v, 'acc, 'r) folder = + path:key -> 'acc -> int -> 'v -> ('acc, 'r) cont_lwt + (** A ('val, 'acc, 'r) folder is a CPS, threaded fold function over values + of type ['v] producing an accumulator of type ['acc]. *) + + let fold : + type acc. + order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + force:acc force -> + cache:bool -> + uniq:uniq -> + pre:acc node_fn option -> + post:acc node_fn option -> + path:Path.t -> + ?depth:depth -> + node:(key -> _ -> acc -> acc Lwt.t) -> + contents:(key -> contents -> acc -> acc Lwt.t) -> + tree:(key -> _ -> acc -> acc Lwt.t) -> + t -> + acc -> + acc Lwt.t = + fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents + ~tree t acc -> + let env = t.info.env in + let marks = + match uniq with + | `False -> dummy_marks + | `True -> empty_marks () + | `Marks n -> n + in + let pre path bindings acc = + match pre with + | None -> Lwt.return acc + | Some pre -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + pre path s acc + in + let post path bindings acc = + match post with + | None -> Lwt.return acc + | Some post -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + post path s acc + in + let rec aux : type r. (t, acc, r) folder = + fun ~path acc d t k -> + let apply acc = node path t acc >>= tree path (`Node t) in + let next acc = + match force with + | `True -> ( + match (order, t.v) with + | `Random state, _ -> + let* m = to_map ~cache t >|= get_ok "fold" in + let arr = StepMap.to_array m in + let () = shuffle state arr in + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k + | `Sorted, _ | `Undefined, Map _ -> + let* m = to_map ~cache t >|= get_ok "fold" in + (map [@tailcall]) ~path acc d (Some m) k + | `Undefined, Value (repo, v, updates) -> + (value [@tailcall]) ~path acc d (repo, v, updates) k + | `Undefined, Hash (repo, _) -> + let* v = to_value ~cache t >|= get_ok "fold" in + (value [@tailcall]) ~path acc d (repo, v, None) k) + | `False skip -> ( + match cached_map t with + | Some n -> (map [@tailcall]) ~path acc d (Some n) k + | None -> + (* XXX: That node is skipped if is is of tag Value *) + skip path acc >>= k) + in + match depth with + | None -> apply acc >>= next + | Some (`Eq depth) -> if d < depth then next acc else apply acc >>= k + | Some (`Le depth) -> + if d < depth then apply acc >>= next else apply acc >>= k + | Some (`Lt depth) -> + if d < depth - 1 then apply acc >>= next else apply acc >>= k + | Some (`Ge depth) -> if d < depth then next acc else apply acc >>= next + | Some (`Gt depth) -> + if d <= depth then next acc else apply acc >>= next + and aux_uniq : type r. (t, acc, r) folder = + fun ~path acc d t k -> + if uniq = `False then (aux [@tailcall]) ~path acc d t k + else + let h = hash ~cache t in + if Hashes.mem marks h then k acc + else ( + Hashes.add marks h (); + (aux [@tailcall]) ~path acc d t k) + and step : type r. (step * elt, acc, r) folder = + fun ~path acc d (s, v) k -> + let path = Path.rcons path s in + match v with + | `Node n -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k + | `Contents c -> ( + let apply () = + let tree path = tree path (`Contents c) in + Contents.fold ~force ~cache ~path contents tree (fst c) acc >>= k + in + match depth with + | None -> apply () + | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc + | Some (`Le depth) -> if d < depth then apply () else k acc + | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc + | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc + | Some (`Gt depth) -> if d >= depth then apply () else k acc) + and steps : type r. ((step * elt) Seq.t, acc, r) folder = + fun ~path acc d s k -> + match s () with + | Seq.Nil -> k acc + | Seq.Cons (h, t) -> + (step [@tailcall]) ~path acc d h (fun acc -> + (steps [@tailcall]) ~path acc d t k) + and map : type r. (map option, acc, r) folder = + fun ~path acc d m k -> + match m with + | None -> k acc + | Some m -> + let bindings = StepMap.to_seq m in + seq ~path acc d bindings k + and value : + type r. (repo option * value * updatemap option, acc, r) folder = + fun ~path acc d (repo, v, updates) k -> + let to_elt = function + | `Node n -> `Node (of_hash ~env repo n) + | `Contents (c, m) -> `Contents (Contents.of_hash ~env repo c, m) + in + let bindings = + P.Node.Val.seq v |> Seq.map (fun (s, v) -> (s, to_elt v)) + in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and seq : type r. ((step * elt) Seq.t, acc, r) folder = + fun ~path acc d bindings k -> + let* acc = pre path bindings acc in + (steps [@tailcall]) ~path acc d bindings (fun acc -> + post path bindings acc >>= k) + in + aux_uniq ~path acc 0 t Lwt.return + + let update t step up = + let env = t.info.env in + let of_map m = + let m' = + match up with + | Remove -> StepMap.remove step m + | Add v -> StepMap.add step v m + in + if m == m' then t else of_map ~env m' + in + let of_value repo n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t + else of_value ~env repo n ~updates:updates' + in + match t.v with + | Map m -> Lwt.return (of_map m) + | Value (repo, n, None) -> Lwt.return (of_value repo n StepMap.empty) + | Value (repo, n, Some um) -> Lwt.return (of_value repo n um) + | Hash (repo, h) -> ( + match (cached_value t, cached_map t) with + | Some v, _ -> Lwt.return (of_value repo v StepMap.empty) + | _, Some m -> Lwt.return (of_map m) + | None, None -> ( + match repo with + | None -> raise_pruned "update" h + | Some repo -> + let+ v = + value_of_hash ~cache:true t repo h >|= get_ok "update" + in + of_value (Some repo) v StepMap.empty)) + + let remove t step = update t step Remove + let add t step v = update t step (Add v) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t node = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare node of_v (fun t -> t.v) + + let _, t = + Type.mu2 (fun _ y -> + let elt = elt_t y in + let v = v_t elt in + let t = t v in + (v, t)) + + let elt_t = elt_t t + let dump = Type.pp_json ~minify:false t + + let rec merge : type a. (t Merge.t -> a) -> a = + fun k -> + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let+ m = to_map ~cache:true old >|= Option.of_result in + Ok (Some m)) + in + let x_env = x.info.env in + let y_env = y.info.env in + let* x = to_map ~cache:true x >|= Option.of_result in + let* y = to_map ~cache:true y >|= Option.of_result in + let m = + StepMap.merge elt_t (fun _step -> + (merge_elt [@tailcall]) Merge.option) + in + Merge.(f @@ option m) ~old x y >|= function + | Ok (Some map) -> + Env.merge x_env y_env; + Ok (of_map ~env:x_env map) + | Ok None -> Error (`Conflict "empty map") + | Error _ as e -> e + in + k (Merge.v t f) + + and merge_elt : type r. (elt Merge.t, r) cont = + fun k -> + let open Merge.Infix in + let f : elt Merge.f = + fun ~old x y -> + match (x, y) with + | `Contents (x, cx), `Contents (y, cy) -> + let mold = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (_, m) -> Lwt.return (Ok (Some m)) + | `Node _ -> Lwt.return (Ok None)) + in + Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (c, _) -> Lwt.return (Ok (Some c)) + | `Node _ -> Lwt.return (Ok None)) + in + Merge.(f Contents.merge) ~old x y >>=* fun c -> + Merge.ok (`Contents (c, m)) + | `Node x, `Node y -> + (merge [@tailcall]) (fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents _ -> Lwt.return (Ok None) + | `Node n -> Lwt.return (Ok (Some n))) + in + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) + | _ -> Merge.conflict "add/add values" + in + k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) + + let merge_elt = merge_elt (fun x -> x) + end + + type node = Node.t [@@deriving irmin] + type metadata = Metadata.t + + type t = [ `Node of node | `Contents of Contents.t * Metadata.t ] + [@@deriving irmin { name = "tree_t" }] + + let of_private_node repo n = Node.of_value ~env:(Env.empty ()) (Some repo) n + let to_private_node = Node.to_value ~cache:true + + let dump ppf = function + | `Node n -> Fmt.pf ppf "node: %a" Node.dump n + | `Contents (c, _) -> Fmt.pf ppf "contents: %a" (Type.pp Contents.t) c + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 + || (c1 == c2 && m1 == m2) + || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let equal (x : t) (y : t) = + x == y + || + match (x, y) with + | `Node x, `Node y -> Node.equal x y + | `Contents x, `Contents y -> contents_equal x y + | `Node _, `Contents _ | `Contents _, `Node _ -> false + + let is_empty = function + | `Node n -> Node.is_empty ~cache:true n + | `Contents _ -> false + + type elt = [ `Node of node | `Contents of contents * metadata ] + + let of_node n = `Node n + + let of_contents ?(metadata = Metadata.default) c = + let env = Env.empty () in + let c = Contents.of_value ~env c in + `Contents (c, metadata) + + let v : elt -> t = function + | `Contents (c, metadata) -> of_contents ~metadata c + | `Node n -> `Node n + + type kinded_hash = [ `Contents of P.Hash.t * Metadata.t | `Node of P.Hash.t ] + [@@deriving irmin ~equal] + + let pruned : kinded_hash -> t = function + | `Contents (h, meta) -> + `Contents (Contents.of_hash ~env:(Env.empty ()) None h, meta) + | `Node h -> `Node (Node.of_hash ~env:(Env.empty ()) None h) + + let destruct x = x + + let clear ?(depth = 0) = function + | `Node n -> Node.clear ~max_depth:depth 0 n + | `Contents _ -> () + + let sub ~cache ctx t path = + let rec aux node path = + match Path.decons path with + | None -> Lwt.return_some node + | Some (h, p) -> ( + Node.findv ~cache ctx node h >>= function + | None | Some (`Contents _) -> Lwt.return_none + | Some (`Node n) -> (aux [@tailcall]) n p) + in + match t with + | `Node n -> (aux [@tailcall]) n path + | `Contents _ -> Lwt.return_none + + let find_tree (t : t) path = + let cache = true in + Log.debug (fun l -> l "Tree.find_tree %a" pp_path path); + match (t, Path.rdecons path) with + | v, None -> Lwt.return_some v + | _, Some (path, file) -> ( + sub ~cache "find_tree.sub" t path >>= function + | None -> Lwt.return_none + | Some n -> Node.findv ~cache "find_tree" n file) + + let id _ _ acc = Lwt.return acc + + let fold ?(order = `Sorted) ?(force = `True) ?(cache = false) ?(uniq = `False) + ?pre ?post ?depth ?(contents = id) ?(node = id) ?(tree = id) (t : t) acc = + match t with + | `Contents (c, _) as c' -> + let tree path = tree path c' in + Contents.fold ~force ~cache ~path:Path.empty contents tree c acc + | `Node n -> + Node.fold ~order ~force ~cache ~uniq ~pre ~post ~path:Path.empty ?depth + ~contents ~node ~tree n acc + + type stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int; + } + [@@deriving irmin] + + let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + let incr_nodes s = { s with nodes = s.nodes + 1 } + let incr_leafs s = { s with leafs = s.leafs + 1 } + let incr_skips s = { s with skips = s.skips + 1 } + + let set_depth p s = + let n_depth = List.length (Path.map p (fun _ -> ())) in + let depth = max n_depth s.depth in + { s with depth } + + let set_width childs s = + let width = max s.width (List.length childs) in + { s with width } + + let err_not_found n k = + Fmt.kstr invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k + + let get_tree (t : t) path = + find_tree t path >|= function + | None -> err_not_found "get_tree" path + | Some v -> v + + let find_all t k = + find_tree t k >>= function + | None | Some (`Node _) -> Lwt.return_none + | Some (`Contents (c, m)) -> + let+ c = Contents.to_value ~cache:true c in + Some (get_ok "find_all" c, m) + + let find t k = + find_all t k >|= function None -> None | Some (c, _) -> Some c + + let get_all t k = + find_all t k >>= function + | None -> err_not_found "get" k + | Some v -> Lwt.return v + + let get t k = get_all t k >|= fun (c, _) -> c + let mem t k = find t k >|= function None -> false | _ -> true + let mem_tree t k = find_tree t k >|= function None -> false | _ -> true + + let kind t path = + let cache = true in + Log.debug (fun l -> l "Tree.kind %a" pp_path path); + match (t, Path.rdecons path) with + | `Contents _, None -> Lwt.return_some `Contents + | `Node _, None -> Lwt.return_some `Node + | _, Some (dir, file) -> ( + sub "kind.sub" ~cache t dir >>= function + | None -> Lwt.return_none + | Some m -> ( + Node.findv "kind.findv" ~cache m file >>= function + | None -> Lwt.return_none + | Some (`Contents _) -> Lwt.return_some `Contents + | Some (`Node _) -> Lwt.return_some `Node)) + + let length t ?(cache = true) path = + Log.debug (fun l -> l "Tree.length %a" pp_path path); + sub ~cache "length" t path >>= function + | None -> Lwt.return 0 + | Some n -> Node.length ~cache:true n + + let seq t ?offset ?length ~cache path : (step * t) Seq.t Lwt.t = + Log.debug (fun l -> l "Tree.seq %a" pp_path path); + sub ~cache "seq" t path >>= function + | None -> Lwt.return Seq.empty + | Some n -> ( + Node.seq ?offset ?length ~cache n >|= function + | Error _ -> Seq.empty + | Ok l -> l) + + let list t ?offset ?length ?(cache = true) path = + seq t ?offset ?length ~cache path >|= List.of_seq + + let empty () = `Node (Node.empty ()) + + (** During recursive updates, we keep track of whether or not we've made a + modification in order to avoid unnecessary allocations of identical tree + objects. *) + type 'a updated = Changed of 'a | Unchanged + + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (x, y) with + | `Node x, `Node y -> Node.maybe_equal x y + | _ -> if equal x y then True else False + + let get_env = function + | `Node n -> n.Node.info.env + | `Contents (c, _) -> c.Contents.info.env + + let update_tree ~cache ~f_might_return_empty_node ~f root_tree path = + (* User-introduced empty nodes will be removed immediately if necessary. *) + let prune_empty : node -> bool = + if not f_might_return_empty_node then Fun.const false + else Node.is_empty ~cache + in + match Path.rdecons path with + | None -> ( + let empty_tree () = + match is_empty root_tree with true -> root_tree | false -> empty () + in + f (Some root_tree) >>= function + (* Here we consider "deleting" a root contents value or node to consist + of changing it to an empty node. Note that this introduces + sensitivity to ordering of subtree operations: updating in a subtree + and adding the subtree are not necessarily commutative. *) + | None -> Lwt.return (empty_tree ()) + | Some (`Node _ as new_root) -> ( + match maybe_equal root_tree new_root with + | True -> Lwt.return root_tree + | Maybe | False -> Lwt.return new_root) + | Some (`Contents c' as new_root) -> ( + match root_tree with + | `Contents c when contents_equal c c' -> Lwt.return root_tree + | _ -> Lwt.return new_root)) + | Some (path, file) -> ( + let rec aux : type r. key -> node -> (node updated, r) cont_lwt = + fun path parent_node k -> + let changed (n : node) = k (Changed n) in + match Path.decons path with + | None -> ( + let with_new_child t = Node.add parent_node file t >>= changed in + let* old_binding = + Node.findv ~cache "update_tree.findv" parent_node file + in + let* new_binding = f old_binding in + match (old_binding, new_binding) with + | None, None -> k Unchanged + | None, Some (`Contents _ as t) -> with_new_child t + | None, Some (`Node n as t) -> ( + match prune_empty n with + | true -> k Unchanged + | false -> with_new_child t) + | Some _, None -> Node.remove parent_node file >>= changed + | Some old_value, Some (`Node n as t) -> ( + match prune_empty n with + | true -> Node.remove parent_node file >>= changed + | false -> ( + match maybe_equal old_value t with + | True -> k Unchanged + | Maybe | False -> with_new_child t)) + | Some (`Contents c), Some (`Contents c' as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Node _), Some (`Contents _ as t) -> with_new_child t) + | Some (step, key_suffix) -> + let* old_binding = + Node.findv ~cache "update_tree.findv" parent_node step + in + let to_recurse = + match old_binding with + | Some (`Node child) -> child + | None | Some (`Contents _) -> Node.empty () + in + (aux [@tailcall]) key_suffix to_recurse (function + | Unchanged -> + (* This includes [remove]s in an empty node, in which case we + want to avoid adding a binding anyway. *) + k Unchanged + | Changed child -> ( + match Node.is_empty ~cache child with + | true -> + (* A [remove] has emptied previously non-empty child with + binding [h], so we remove the binding. *) + Node.remove parent_node step >>= changed + | false -> + Node.add parent_node step (`Node child) >>= changed)) + in + let top_node = + match root_tree with `Node n -> n | `Contents _ -> Node.empty () + in + aux path top_node @@ function + | Unchanged -> Lwt.return root_tree + | Changed node -> + Env.copy ~into:node.info.env (get_env root_tree); + Lwt.return (`Node node)) + + let update root k ?(metadata = Metadata.default) f = + Log.debug (fun l -> l "Tree.update %a" pp_path k); + let cache = true in + update_tree ~cache root k ~f_might_return_empty_node:false ~f:(fun t -> + let+ old_contents = + match t with + | Some (`Node _) | None -> Lwt.return_none + | Some (`Contents (c, _)) -> + let+ c = Contents.to_value ~cache c in + Some (get_ok "update" c) + in + match f old_contents with + | None -> None + | Some c -> of_contents ~metadata c |> Option.some) + + let add t k ?(metadata = Metadata.default) c = + Log.debug (fun l -> l "Tree.add %a" pp_path k); + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_some (of_contents ~metadata c)) + ~f_might_return_empty_node:false + + let add_tree t k v = + Log.debug (fun l -> l "Tree.add_tree %a" pp_path k); + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_some v) + ~f_might_return_empty_node:true + + let remove t k = + Log.debug (fun l -> l "Tree.remove %a" pp_path k); + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_none) + ~f_might_return_empty_node:false + + let update_tree t k f = + Log.debug (fun l -> l "Tree.update_tree %a" pp_path k); + update_tree ~cache:true t k ~f:(Lwt.wrap1 f) ~f_might_return_empty_node:true + + let import repo = function + | `Contents (k, m) -> ( + P.Contents.mem (P.Repo.contents_t repo) k >|= function + | true -> + let env = Env.empty () in + let c = Contents.of_hash ~env (Some repo) k in + Some (`Contents (c, m)) + | false -> None) + | `Node k -> ( + let env = Env.empty () in + cnt.node_mem <- cnt.node_mem + 1; + P.Node.mem (P.Repo.node_t repo) k >|= function + | true -> Some (`Node (Node.of_hash ~env (Some repo) k)) + | false -> None) + + let import_with_env ~env repo = function + | `Node k -> `Node (Node.of_hash ~env (Some repo) k) + | `Contents (k, m) -> `Contents (Contents.of_hash ~env (Some repo) k, m) + + let import_no_check repo f = import_with_env ~env:(Env.empty ()) repo f + + let export ?clear repo contents_t node_t n = + let cache = + match clear with + | Some true | None -> + (* This choice of [cache] flag has no impact, since we either + immediately clear the corresponding cache or are certain that + the it is already filled. *) + false + | Some false -> true + in + let skip n = + match Node.cached_hash n with + | Some h -> + cnt.node_mem <- cnt.node_mem + 1; + P.Node.mem node_t h + | None -> Lwt.return_false + in + let rec on_node (`Node n) k = + match n.Node.v with + | Node.Hash (None, h) -> raise_pruned "export.node" h + | Node.Value (None, _, _) -> + let h = Node.hash ~cache:false n in + raise_pruned "export" h + | Node.Hash (Some _, h) -> + Node.export ?clear (Some repo) n h; + k () + | Node.Value (Some _, v, None) -> + let h = P.Node.Key.hash v in + Node.export ?clear (Some repo) n h; + k () + | Node.Map _ | Node.Value (Some _, _, Some _) -> ( + skip n >>= function + | true -> k () + | false -> + let new_children_seq = + let seq = + match n.Node.v with + | Node.Value (_, _, Some m) -> + StepMap.to_seq m + |> Seq.filter_map (function + | step, Node.Add v -> Some (step, v) + | _, Remove -> None) + | Node.Map m -> StepMap.to_seq m + | _ -> assert false + in + Seq.map (fun (_, x) -> x) seq + in + on_node_seq new_children_seq @@ fun () -> + let* v = Node.to_value ~cache n in + let v = get_ok "export" v in + cnt.node_add <- cnt.node_add + 1; + let* key = P.Node.add node_t v in + let () = + (* Sanity check: Did we just store the same hash as the one represented + by the Tree.Node [n]? *) + match Node.cached_hash n with + | None -> + (* No hash is in [n]. Computing it would result in getting it from + [v] or rebuilding a private node. *) + () + | Some key' -> assert (equal_hash key key') + in + + Node.export ?clear (Some repo) n key; + k ()) + and on_contents (`Contents (c, _)) k = + match c.Contents.v with + | Contents.Hash (None, h) -> raise_pruned "export.contents" h + | Contents.Hash (Some repo, key) -> + Contents.export ?clear repo c key; + k () + | Contents.Value _ -> + let* v = Contents.to_value ~cache c in + let v = get_ok "export" v in + let key = Contents.hash ~cache c in + cnt.contents_add <- cnt.contents_add + 1; + let* key' = P.Contents.add contents_t v in + assert (equal_hash key key'); + Contents.export ?clear repo c key; + k () + and on_node_seq seq k = + match seq () with + | Seq.Nil -> + (* Have iterated on all children, let's export parent now *) + k () + | Seq.Cons ((`Node _ as n), rest) -> + on_node n (fun () -> on_node_seq rest k) + | Seq.Cons ((`Contents _ as c), rest) -> + on_contents c (fun () -> on_node_seq rest k) + in + let+ () = on_node (`Node n) (fun () -> Lwt.return_unit) in + Node.hash ~cache n + + let merge : t Merge.t = + let f ~old (x : t) y = + Merge.(f Node.merge_elt) ~old x y >>= function + | Ok t -> Merge.ok t + | Error e -> Lwt.return (Error e) + in + Merge.v tree_t f + + let entries path tree = + let rec aux acc = function + | [] -> Lwt.return acc + | (path, h) :: todo -> + let* childs = Node.bindings ~cache:true h >|= get_ok "entries" in + let acc, todo = + List.fold_left + (fun (acc, todo) (k, v) -> + let path = Path.rcons path k in + match v with + | `Node v -> (acc, (path, v) :: todo) + | `Contents c -> ((path, c) :: acc, todo)) + (acc, todo) childs + in + (aux [@tailcall]) acc todo + in + (aux [@tailcall]) [] [ (path, tree) ] + + (** Given two forced lazy values, return an empty diff if they both use the + same dangling hash. *) + let diff_force_result (type a b) ~(empty : b) ~(diff_ok : a * a -> b) + (x : a or_error) (y : a or_error) : b = + match (x, y) with + | Error (`Dangling_hash h1), Error (`Dangling_hash h2) + | Error (`Pruned_hash h1), Error (`Dangling_hash h2) + | Error (`Dangling_hash h1), Error (`Pruned_hash h2) + | Error (`Pruned_hash h1), Error (`Pruned_hash h2) -> ( + match equal_hash h1 h2 with true -> empty | false -> assert false) + | Error _, Ok _ -> assert false + | Ok _, Error _ -> assert false + | Ok x, Ok y -> diff_ok (x, y) + + let diff_contents x y = + if Node.contents_equal x y then Lwt.return_nil + else + let* cx = Contents.to_value ~cache:true (fst x) in + let+ cy = Contents.to_value ~cache:true (fst y) in + diff_force_result cx cy ~empty:[] ~diff_ok:(fun (cx, cy) -> + [ `Updated ((cx, snd x), (cy, snd y)) ]) + + let compare_step = Type.(unstage (compare Path.step_t)) + + let diff_node (x : node) (y : node) = + let bindings n = + Node.to_map ~cache:true n >|= function + | Ok m -> Ok (StepMap.bindings m) + | Error _ as e -> e + in + let removed acc (k, (c, m)) = + let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + (k, `Removed (c, m)) :: acc + in + let added acc (k, (c, m)) = + let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + (k, `Added (c, m)) :: acc + in + let rec diff_bindings acc todo path x y = + let acc = ref acc in + let todo = ref todo in + let* () = + alist_iter2_lwt compare_step + (fun key v -> + let path = Path.rcons path key in + match v with + (* Left *) + | `Left (`Contents x) -> + let+ x = removed !acc (path, x) in + acc := x + | `Left (`Node x) -> + let* xs = entries path x in + let+ xs = Lwt_list.fold_left_s removed !acc xs in + acc := xs + (* Right *) + | `Right (`Contents y) -> + let+ y = added !acc (path, y) in + acc := y + | `Right (`Node y) -> + let* ys = entries path y in + let+ ys = Lwt_list.fold_left_s added !acc ys in + acc := ys + (* Both *) + | `Both (`Node x, `Node y) -> + todo := (path, x, y) :: !todo; + Lwt.return_unit + | `Both (`Contents x, `Node y) -> + let* ys = entries path y in + let* x = removed !acc (path, x) in + let+ ys = Lwt_list.fold_left_s added x ys in + acc := ys + | `Both (`Node x, `Contents y) -> + let* xs = entries path x in + let* y = added !acc (path, y) in + let+ ys = Lwt_list.fold_left_s removed y xs in + acc := ys + | `Both (`Contents x, `Contents y) -> + let+ content_diffs = + diff_contents x y >|= List.map (fun d -> (path, d)) + in + acc := content_diffs @ !acc) + x y + in + (diff_node [@tailcall]) !acc !todo + and diff_node acc = function + | [] -> Lwt.return acc + | (path, x, y) :: todo -> + if Node.equal x y then (diff_node [@tailcall]) acc todo + else + let* x = bindings x in + let* y = bindings y in + diff_force_result ~empty:Lwt.return_nil + ~diff_ok:(fun (x, y) -> diff_bindings acc todo path x y) + x y + in + (diff_node [@tailcall]) [] [ (Path.empty, x, y) ] + + let diff (x : t) (y : t) = + match (x, y) with + | `Contents ((c1, m1) as x), `Contents ((c2, m2) as y) -> + if contents_equal x y then Lwt.return_nil + else + let* c1 = Contents.to_value ~cache:true c1 >|= get_ok "diff" in + let* c2 = Contents.to_value ~cache:true c2 >|= get_ok "diff" in + Lwt.return [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] + | `Node x, `Node y -> diff_node x y + | `Contents (x, m), `Node y -> + let* diff = diff_node (Node.empty ()) y in + let+ x = Contents.to_value ~cache:true x >|= get_ok "diff" in + (Path.empty, `Removed (x, m)) :: diff + | `Node x, `Contents (y, m) -> + let* diff = diff_node x (Node.empty ()) in + let+ y = Contents.to_value ~cache:true y >|= get_ok "diff" in + (Path.empty, `Added (y, m)) :: diff + + type concrete = + [ `Tree of (Path.step * concrete) list + | `Contents of P.Contents.Val.t * Metadata.t ] + [@@deriving irmin] + + type 'a or_empty = Empty | Non_empty of 'a + + let of_concrete c = + let rec concrete : type r. concrete -> (t or_empty, r) cont = + fun t k -> + match t with + | `Contents (c, m) -> k (Non_empty (of_contents ~metadata:m c)) + | `Tree childs -> + tree StepMap.empty childs (function + | Empty -> k Empty + | Non_empty n -> k (Non_empty (`Node n))) + and tree : + type r. + Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont + = + fun map t k -> + match t with + | [] -> + k + (if StepMap.is_empty map then Empty + else Non_empty (Node.of_map ~env:(Env.empty ()) map)) + | (s, n) :: t -> + (concrete [@tailcall]) n (fun v -> + (tree [@tailcall]) + (StepMap.update s + (function + | None -> ( + match v with + | Empty -> None (* Discard empty sub-directories *) + | Non_empty v -> Some v) + | Some _ -> + Fmt.invalid_arg + "of_concrete: duplicate bindings for step `%a`" + pp_step s) + map) + t k) + in + (concrete [@tailcall]) c (function Empty -> empty () | Non_empty x -> x) + + let to_concrete t = + let rec tree : type r. t -> (concrete, r) cont_lwt = + fun t k -> + match t with + | `Contents c -> contents c k + | `Node n -> + let* m = Node.to_map ~cache:true n in + let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in + (node [@tailcall]) [] bindings (fun n -> + let n = List.sort (fun (s, _) (s', _) -> compare_step s s') n in + k (`Tree n)) + and contents : type r. Contents.t * metadata -> (concrete, r) cont_lwt = + fun (c, m) k -> + let* c = Contents.to_value ~cache:true c >|= get_ok "to_concrete" in + k (`Contents (c, m)) + and node : + type r. + (step * concrete) list -> + (step * Node.elt) list -> + ((step * concrete) list, r) cont_lwt = + fun childs x k -> + match x with + | [] -> k childs + | (s, n) :: t -> ( + match n with + | `Node _ as n -> + (tree [@tailcall]) n (fun tree -> node ((s, tree) :: childs) t k) + | `Contents c -> + (contents [@tailcall]) c (fun c -> + (node [@tailcall]) ((s, c) :: childs) t k)) + in + tree t (fun x -> Lwt.return x) + + let hash ?(cache = true) (t : t) = + Log.debug (fun l -> l "Tree.hash"); + match t with + | `Node n -> `Node (Node.hash ~cache n) + | `Contents (c, m) -> `Contents (Contents.hash ~cache c, m) + + let stats ?(force = false) (t : t) = + let cache = true in + let force = + if force then `True + else `False (fun k s -> set_depth k s |> incr_skips |> Lwt.return) + in + let contents k _ s = set_depth k s |> incr_leafs |> Lwt.return in + let pre k childs s = + if childs = [] then Lwt.return s + else set_depth k s |> set_width childs |> incr_nodes |> Lwt.return + in + let post _ _ acc = Lwt.return acc in + fold ~force ~cache ~pre ~post ~contents t empty_stats + + let counters () = cnt + let dump_counters ppf () = dump_counters ppf cnt + let reset_counters () = reset_counters cnt + + let inspect = function + | `Contents _ -> `Contents + | `Node n -> + `Node + (match n.Node.v with + | Map _ -> `Map + | Value _ -> `Value + | Hash _ -> `Hash) + + module Proof = struct + type irmin_tree = t + + include Proof.Make (P.Contents.Val) (P.Hash) (Path) (Metadata) + + type proof_tree = tree + + let bad_proof_exn c = Proof.bad_proof_exn ("Irmin.Tree." ^ c) + + type node_proof = P.Node.Val.proof + (** The type of tree proofs. *) + + let value_of_hash ~cache:_ _node _repo h = Error (`Pruned_hash h) + + let to_value node = + Node.to_value_aux ~cache:false ~value_of_hash ~return:Fun.id node + + let findv ctx node = + let value_of_hash ~cache:_ _node _repo h = Error (`Pruned_hash h) in + Node.findv_aux ~value_of_hash ~return:Fun.id + ~bind:(fun x f -> f x) + ~cache:false ctx node + + let rec proof_of_tree : type a. irmin_tree -> (proof_tree -> a) -> a = + fun tree k -> + match tree with + | `Contents (c, h) -> proof_of_contents c h k + | `Node node -> proof_of_node node k + + and proof_of_contents : + type a. Contents.t -> metadata -> (proof_tree -> a) -> a = + fun c m k -> + match Contents.cached_value c with + | Some v -> k (Contents (v, m)) + | None -> k (Blinded_contents (Contents.hash c, m)) + + and proof_of_node : type a. node -> (proof_tree -> a) -> a = + fun node k -> + match to_value node with + | Error (`Dangling_hash h) -> k (Blinded_node h) + | Error (`Pruned_hash h) -> k (Blinded_node h) + | Ok v -> proof_of_node_proof node (P.Node.Val.to_proof v) k + + (** [of_node_proof n np] is [p] (of type [Tree.Proof.t]) which is very + similar to [np] (of type [P.Node.Val.proof]) except that the values + loaded in [n] have been expanded. + + If [np] is of tag [Inode], [of_node_proof] will be called recursively + for each of the proofs [np'] in [p.proofs], using [n] again (i.e. + [of_node_proof n np']). + + If [np] is of tag [Values], the proofs contained in it will be ignored + and instead be recomputed one value at a time, using the tag [Blinded] + for the values non-loaded in [n], and some other tag for the values + loaded in [n]. *) + and proof_of_node_proof : + type a. node -> node_proof -> (proof_tree -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_node h) + | `Inode (length, proofs) -> proof_of_inode node length proofs k + | `Values vs -> proof_of_values node vs k + + and proof_of_inode : + type a. node -> int -> (_ * node_proof) list -> (proof_tree -> a) -> a = + fun node length proofs k -> + let rec aux acc = function + | [] -> k (Inode { length; proofs = List.rev acc }) + | (index, proof) :: rest -> + proof_of_node_proof node proof (fun proof -> + aux ((index, proof) :: acc) rest) + in + aux [] proofs + + and proof_of_values : + type a. node -> (step * P.Node.Val.value) list -> (proof_tree -> a) -> a + = + fun node steps k -> + let findv = findv "Proof.proof_of_values" node in + let rec aux acc = function + | [] -> k (Node (List.rev acc)) + | (step, _) :: rest -> ( + match findv step with + | None -> assert false + | Some t -> + let k p = aux ((step, p) :: acc) rest in + proof_of_tree t k) + in + aux [] steps + + let of_tree t = proof_of_tree t Fun.id + + let rec load_proof : type a. env:_ -> proof_tree -> (kinded_hash -> a) -> a + = + fun ~env p k -> + match p with + | Blinded_node h -> k (`Node h) + | Node n -> load_node_proof ~env n k + | Inode { length; proofs } -> load_inode_proof ~env length proofs k + | Blinded_contents (h, m) -> k (`Contents (h, m)) + | Contents (v, m) -> + let h = P.Contents.Key.hash v in + Env.add_contents_from_proof env h v; + k (`Contents (h, m)) + + (* Recontruct private node from [P.Node.Val.empty] *) + and load_node_proof : + type a. env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = + fun ~env n k -> + let rec aux acc = function + | [] -> + let h = P.Node.Key.hash acc in + Env.add_node_from_proof env h acc; + k (`Node h) + | (s, p) :: rest -> + let k h = aux (P.Node.Val.add acc s h) rest in + load_proof ~env p k + in + aux P.Node.Val.empty n + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_inode_proof : + type a. env:_ -> int -> (_ * proof_tree) list -> (kinded_hash -> a) -> a + = + fun ~env len proofs k -> + let rec aux : _ list -> _ list -> a = + fun acc proofs -> + match proofs with + | [] -> + let np = `Inode (len, List.rev acc) in + let v = P.Node.Val.of_proof np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node.Key.hash v in + Env.add_node_from_proof env h v; + k (`Node h) + | (i, p) :: rest -> + let k p = aux ((i, p) :: acc) rest in + node_proof_of_proof ~env p k + in + aux [] proofs + + and node_proof_of_proof : + type a. env:_ -> proof_tree -> (node_proof -> a) -> a = + fun ~env t k -> + match t with + | Blinded_contents _ -> + bad_proof_exn + "Proof.to_node_proof: found Blinded_contents inside an inode" + | Contents _ -> + bad_proof_exn "Proof.to_node_proof: found Contents inside an inode" + | Blinded_node x -> k (`Blinded x) + | Inode { length; proofs } -> node_proof_of_inode ~env length proofs k + | Node n -> node_proof_of_node ~env n k + + and node_proof_of_inode : + type a. env:_ -> int -> (_ * proof_tree) list -> (node_proof -> a) -> a + = + fun ~env length proofs k -> + let rec aux acc = function + | [] -> k (`Inode (length, List.rev acc)) + | (i, p) :: rest -> + node_proof_of_proof ~env p (fun p -> aux ((i, p) :: acc) rest) + in + aux [] proofs + + and node_proof_of_node : + type a. env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = + fun ~env node k -> + let rec aux acc = function + | [] -> k (`Values (List.rev acc)) + | (s, p) :: rest -> + load_proof ~env p (fun n -> aux ((s, n) :: acc) rest) + in + aux [] node + + let to_tree p = + let env = Env.empty () in + Env.to_mode env Deserialise; + let h = load_proof ~env (state p) Fun.id in + let tree = + match h with + | `Contents (h, meta) -> `Contents (Contents.of_hash ~env None h, meta) + | `Node h -> `Node (Node.of_hash ~env None h) + in + Env.to_mode env Consume; + Fmt.epr "to_tree to Consume\n%!"; + tree + end + + let produce_proof repo kinded_hash f = + let env = Env.empty () in + let tree = import_with_env ~env repo kinded_hash in + Env.with_mode env Produce @@ fun () -> + let* tree_after = f tree in + let after = hash tree_after in + (* Here, we build a proof from [tree] (not from [tree_after]!), on purpose: + we look at the effect on [f] on [tree]'s caches and we rely on the fact + that the caches are env across copy-on-write copies of [tree]. *) + clear tree; + Env.with_mode env Serialise @@ fun () -> + let proof = Proof.of_tree tree in + (* [env] will be purged when leaving the scope, that should avoid any memory + leaks *) + Proof.v ~before:kinded_hash ~after proof |> Lwt.return + + let verify_proof p f = + let env = Env.empty () in + let before = Proof.before p in + let after = Proof.after p in + Env.with_mode env Deserialise @@ fun () -> + (* First convert to proof to [Env] *) + let h = Proof.(load_proof ~env (state p) Fun.id) in + (* Then check that the consistency of the proof *) + if not (equal_kinded_hash before h) then + Proof.bad_proof_exn "verify_proof: invalid before hash"; + let tree = + match h with + | `Contents (h, meta) -> `Contents (Contents.of_hash ~env None h, meta) + | `Node h -> `Node (Node.of_hash ~env None h) + in + Lwt.catch + (fun () -> + Env.with_mode env Consume @@ fun () -> + (* Then apply [f] on a cleaned tree, an exception will be raised if [f] + reads out of the proof. *) + let+ tree_after = f tree in + (* then check that [after] corresponds to [tree_after]'s hash. *) + if not (equal_kinded_hash after (hash tree_after)) then + Proof.bad_proof_exn "verify_proof: invalid before hash"; + tree_after) + (function + | Pruned_hash h -> + (* finaly check that [f] only access valid parts of the proof. *) + Fmt.kstr Proof.bad_proof_exn + "verify_proof: %s is trying to read through a blinded node or \ + object (%a)" + h.context pp_hash h.hash + | e -> raise e) +end diff --git a/vendors/irmin/irmin/tree.mli b/vendors/irmin/irmin/tree.mli new file mode 100644 index 000000000000..f85e369e03f6 --- /dev/null +++ b/vendors/irmin/irmin/tree.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Tree_intf.Tree +(** @inline *) diff --git a/vendors/irmin/irmin/tree_intf.ml b/vendors/irmin/irmin/tree_intf.ml new file mode 100644 index 000000000000..d995fb9e7fb7 --- /dev/null +++ b/vendors/irmin/irmin/tree_intf.ml @@ -0,0 +1,435 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type key + type step + type metadata + type contents + type node + type hash + + (** [Tree] provides immutable, in-memory partial mirror of the store, with + lazy reads and delayed writes. + + Trees are like staging area in Git: they are immutable temporary + non-persistent areas (they disappear if the host crash), held in memory + for efficiency, where reads are done lazily and writes are done only when + needed on commit: if you modify a key twice, only the last change will be + written to the store when you commit. *) + + type t + (** The type of trees. *) + + (** {1 Constructors} *) + + val empty : unit -> t + (** [empty ()] is the empty tree. The empty tree does not have associated + backend configuration values, as they can perform in-memory operation, + independently of any given backend. *) + + val of_contents : ?metadata:metadata -> contents -> t + (** [of_contents c] is the subtree built from the contents [c]. *) + + val of_node : node -> t + (** [of_node n] is the subtree built from the node [n]. *) + + type elt = [ `Node of node | `Contents of contents * metadata ] + (** The type for tree elements. *) + + val v : elt -> t + (** General-purpose constructor for trees. *) + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + val pruned : kinded_hash -> t + (** [pruned h] is a purely in-memory tree with the hash [h]. Such trees can be + used as children of other in-memory tree nodes, for instance in order to + compute the hash of the parent, but they cannot be dereferenced. + + Any operation that would require loading the contents of a pruned node + (e.g. calling {!find} on one of its children) will instead raise a + {!Pruned_hash} exception. Attempting to export a tree containing pruned + sub-trees to a repository will fail similarly. *) + + val kind : t -> key -> [ `Contents | `Node ] option Lwt.t + (** [kind t k] is the type of [s] in [t]. It could either be a tree node or + some file contents. It is [None] if [k] is not present in [t]. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty} (i.e. a tree node with no + children). Trees with {!kind} = [`Contents] are never considered empty. *) + + (** {1 Diffs} *) + + val diff : t -> t -> (key * (contents * metadata) Diff.t) list Lwt.t + (** [diff x y] is the difference of contents between [x] and [y]. *) + + (** {1 Manipulating Contents} *) + + type error = [ `Dangling_hash of hash | `Pruned_hash of hash ] + (** The type for errors. *) + + type 'a or_error = ('a, error) result + (** Operations on lazy nodes can fail if the underlying store does not contain + the expected hash. *) + + exception Dangling_hash of { context : string; hash : hash } + (** The exception raised by functions that can force lazy tree nodes but do + not return an explicit {!or_error}. *) + + exception Pruned_hash of { context : string; hash : hash } + (** The exception raised by functions that attempt to load {!pruned} tree + nodes. *) + + (** Operations on lazy tree contents. *) + module Contents : sig + type t + (** The type of lazy tree contents. *) + + val hash : ?cache:bool -> t -> hash + (** [hash t] is the hash of the {!contents} value returned when [t] is + {!force}d successfully. + + {2 caching} + + [cache] regulates the caching behaviour regarding the node's internal + data which are be lazily loaded from the backend. + + [cache] defaults to [true] which may greatly reduce the IOs and the + runtime but may also grealy increase the memory consumption. + + [cache = false] doesn't replace a call to [clear], it only prevents the + storing of new data, it doesn't discard the existing one. *) + + val force : t -> contents or_error Lwt.t + (** [force t] forces evaluation of the lazy content value [t], or returns an + error if no such value exists in the underlying repository. *) + + val force_exn : t -> contents Lwt.t + (** Equivalent to {!force}, but raises an exception if the lazy content + value is not present in the underlying repository. *) + + val clear : t -> unit + (** [clear t] clears [t]'s cache. *) + end + + val mem : t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is associated to some contents in [t]. *) + + val find_all : t -> key -> (contents * metadata) option Lwt.t + (** [find_all t k] is [Some (b, m)] if [k] is associated to the contents [b] + and metadata [m] in [t] and [None] if [k] is not present in [t]. *) + + val length : t -> ?cache:bool -> key -> int Lwt.t + (** [length t key] is the number of files and sub-nodes stored under [k] in + [t]. + + It is equivalent to [List.length (list t k)] but backends might optimise + this call: for instance it's a constant time operation in [irmin-pack]. + + [cache] defaults to [true], see {!caching} for an explanation of the + parameter.*) + + val find : t -> key -> contents option Lwt.t + (** [find] is similar to {!find_all} but it discards metadata. *) + + val get_all : t -> key -> (contents * metadata) Lwt.t + (** Same as {!find_all} but raise [Invalid_arg] if [k] is not present in [t]. *) + + val list : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + key -> + (step * t) list Lwt.t + (** [list t key] is the list of files and sub-nodes stored under [k] in [t]. + The result order is not specified but is stable. + + [offset] and [length] are used for pagination. + + [cache] defaults to [true], see {!caching} for an explanation of the + parameter. *) + + val get : t -> key -> contents Lwt.t + (** Same as {!get_all} but ignore the metadata. *) + + val add : t -> key -> ?metadata:metadata -> contents -> t Lwt.t + (** [add t k c] is the tree where the key [k] is bound to the contents [c] but + is similar to [t] for other bindings. *) + + val update : + t -> + key -> + ?metadata:metadata -> + (contents option -> contents option) -> + t Lwt.t + (** [update t k f] is the tree [t'] that is the same as [t] for all keys + except [k], and whose binding for [k] is determined by [f (find t k)]. + + If [k] refers to an internal node of [t], [f] is called with [None] to + determine the value with which to replace it. *) + + val remove : t -> key -> t Lwt.t + (** [remove t k] is the tree where [k] bindings has been removed but is + similar to [t] for other bindings. *) + + (** {1 Manipulating Subtrees} *) + + val mem_tree : t -> key -> bool Lwt.t + (** [mem_tree t k] is false iff [find_tree k = None]. *) + + val find_tree : t -> key -> t option Lwt.t + (** [find_tree t k] is [Some v] if [k] is associated to [v] in [t]. It is + [None] if [k] is not present in [t]. *) + + val get_tree : t -> key -> t Lwt.t + (** [get_tree t k] is [v] if [k] is associated to [v] in [t]. Raise + [Invalid_arg] if [k] is not present in [t].*) + + val add_tree : t -> key -> t -> t Lwt.t + (** [add_tree t k v] is the tree where the key [k] is bound to the non-empty + tree [v] but is similar to [t] for other bindings. + + If [v] is empty, this is equivalent to [remove t k]. *) + + val update_tree : t -> key -> (t option -> t option) -> t Lwt.t + (** [update_tree t k f] is the tree [t'] that is the same as [t] for all + subtrees except under [k], and whose subtree at [k] is determined by + [f (find_tree t k)]. + + [f] returning either [None] or [Some empty] causes the subtree at [k] to + be unbound (i.e. it is equivalent to [remove t k]). *) + + val merge : t Merge.t + (** [merge] is the 3-way merge function for trees. *) + + (** {1 Folds} *) + + val destruct : t -> [ `Node of node | `Contents of Contents.t * metadata ] + (** General-purpose destructor for trees. *) + + type marks + (** The type for fold marks. *) + + val empty_marks : unit -> marks + (** [empty_marks ()] is an empty collection of marks. *) + + type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] + (** The type for {!fold}'s [force] parameter. [`True] forces the fold to read + the objects of the lazy nodes and contents. [`False f] is applying [f] on + every lazy node and content value instead. *) + + type uniq = [ `False | `True | `Marks of marks ] + (** The type for {!fold}'s [uniq] parameters. [`False] folds over all the + nodes. [`True] does not recurse on nodes already seen. [`Marks m] uses the + collection of marks [m] to store the cache of keys: the fold will modify + [m]. This can be used for incremental folds. *) + + type 'a node_fn = key -> step list -> 'a -> 'a Lwt.t + (** The type for {!fold}'s [pre] and [post] parameters. *) + + type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + [@@deriving irmin] + (** The type for fold depths. + + - [Eq d] folds over nodes and contents of depth exactly [d]. + - [Lt d] folds over nodes and contents of depth strictly less than [d]. + - [Gt d] folds over nodes and contents of depth strictly more than [d]. + + [Le d] is [Eq d] and [Lt d]. [Ge d] is [Eq d] and [Gt d]. *) + + val fold : + ?order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + ?force:'a force -> + ?cache:bool -> + ?uniq:uniq -> + ?pre:'a node_fn -> + ?post:'a node_fn -> + ?depth:depth -> + ?contents:(key -> contents -> 'a -> 'a Lwt.t) -> + ?node:(key -> node -> 'a -> 'a Lwt.t) -> + ?tree:(key -> t -> 'a -> 'a Lwt.t) -> + t -> + 'a -> + 'a Lwt.t + (** [fold f t acc] folds [f] over [t]'s leafs. + + For every node [n], ui [n] is a leaf node, call [f path n]. Otherwise: + + - Call [pre path n]. By default [pre] is the identity; + - Recursively call [fold] on each children. + - Call [post path n]; By default [post] is the identity. + + See {!force} for details about the [force] parameters. By default it is + [`True]. + + See {!uniq} for details about the [uniq] parameters. By default it is + [`False]. + + The fold depth is controlled by the [depth] parameter. + + [cache] defaults to [false], see {!caching} for an explanation of the + parameter. + + If [order] is [`Sorted] (the default), the elements are traversed in + lexicographic order of their keys. If [`Random state], they are traversed + in a random order. For large nodes, these two modes are memory-consuming, + use [`Undefined] for a more memory efficient [fold]. *) + + (** {1 Stats} *) + + type stats = { + nodes : int; (** Number of node. *) + leafs : int; (** Number of leafs. *) + skips : int; (** Number of lazy nodes. *) + depth : int; (** Maximal depth. *) + width : int; (** Maximal width. *) + } + [@@deriving irmin] + (** The type for tree stats. *) + + val stats : ?force:bool -> t -> stats Lwt.t + (** [stats ~force t] are [t]'s statistics. If [force] is true, this will force + the reading of lazy nodes. By default it is [false]. *) + + (** {1 Concrete Trees} *) + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + [@@deriving irmin] + (** The type for concrete trees. *) + + val concrete_t : concrete Type.t + (** The value-type for {!concrete}. *) + + val of_concrete : concrete -> t + (** [of_concrete c] is the subtree equivalent of the concrete tree [c]. + + @raise Invalid_argument + if [c] contains duplicate bindings for a given path. *) + + val to_concrete : t -> concrete Lwt.t + (** [to_concrete t] is the concrete tree equivalent of the subtree [t]. *) + + (** {1 Proofs} *) + + module Proof : sig + include + Proof.S + with type contents := contents + and type hash := hash + and type step := step + and type metadata := metadata + + type irmin_tree + + val to_tree : t -> irmin_tree + (** [to_tree p] is the tree [t] representing the tree proof [p]. Blinded + parts of the proof will raise [Dangling_hash] when traversed. *) + end + with type irmin_tree := t + + (** {1 Caches} *) + + val clear : ?depth:int -> t -> unit + (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a + depth higher than [depth]. If [depth] is not set, all of the subtrees are + cleared. + + A call to [clear] doesn't discard the subtrees of [t], only their cache + are discarded. Even the lazily loaded and unmodified subtrees remain. *) + + (** {1 Performance counters} *) + + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; + } + + val counters : unit -> counters + val dump_counters : unit Fmt.t + val reset_counters : unit -> unit + val inspect : t -> [ `Contents | `Node of [ `Map | `Hash | `Value | `Pruned ] ] + + (** / *) + + (** Internals Useful for testing purposes only. *) + + module Env : sig + type t [@@deriving irmin] + + val is_empty : t -> bool + end + + val get_env : t -> Env.t +end + +module type Tree = sig + module type S = sig + include S + (** @inline *) + end + + module Make (P : Private.S) : sig + include + S + with type key = P.Node.Path.t + and type step = P.Node.Path.step + and type metadata = P.Node.Metadata.t + and type contents = P.Contents.value + and type hash = P.Hash.t + + type kinded_hash := [ `Contents of hash * metadata | `Node of hash ] + + val import : P.Repo.t -> kinded_hash -> t option Lwt.t + val import_no_check : P.Repo.t -> kinded_hash -> t + + val export : + ?clear:bool -> + P.Repo.t -> + [> write ] P.Contents.t -> + [> read_write ] P.Node.t -> + node -> + P.Node.key Lwt.t + + val dump : t Fmt.t + val equal : t -> t -> bool + val node_t : node Type.t + val tree_t : t Type.t + val hash : ?cache:bool -> t -> kinded_hash + val of_private_node : P.Repo.t -> P.Node.value -> node + val to_private_node : node -> P.Node.value or_error Lwt.t + + val produce_proof : + P.Repo.t -> kinded_hash -> (t -> t Lwt.t) -> Proof.t Lwt.t + + val verify_proof : Proof.t -> (t -> t Lwt.t) -> t Lwt.t + end +end diff --git a/vendors/irmin/irmin/type.ml b/vendors/irmin/irmin/type.ml new file mode 100644 index 000000000000..8b9e7567a403 --- /dev/null +++ b/vendors/irmin/irmin/type.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2016-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Repr diff --git a/vendors/irmin/irmin/type.mli b/vendors/irmin/irmin/type.mli new file mode 100644 index 000000000000..95954a25d9a0 --- /dev/null +++ b/vendors/irmin/irmin/type.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2016-2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include module type of Repr +(** @inline *) diff --git a/vendors/irmin/irmin/version.ml b/vendors/irmin/irmin/version.ml new file mode 100644 index 000000000000..3274b52a91db --- /dev/null +++ b/vendors/irmin/irmin/version.ml @@ -0,0 +1 @@ +let current = "%%VERSION%%" diff --git a/vendors/irmin/irmin/watch.ml b/vendors/irmin/irmin/watch.ml new file mode 100644 index 000000000000..c6ff822d9387 --- /dev/null +++ b/vendors/irmin/irmin/watch.ml @@ -0,0 +1,328 @@ +(* + * Copyright (c) 2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Watch_intf + +let src = Logs.Src.create "irmin.watch" ~doc:"Irmin watch notifications" + +module Log = (val Logs.src_log src : Logs.LOG) + +let none _ _ = + Printf.eprintf "Listen hook not set!\n%!"; + assert false + +let listen_dir_hook = ref none + +type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + +let set_listen_dir_hook (h : hook) = listen_dir_hook := h + +let id () = + let c = ref 0 in + fun () -> + incr c; + !c + +let global = id () +let workers_r = ref 0 +let workers () = !workers_r + +let scheduler () = + let p = ref None in + let niet () = () in + let c = ref niet in + let push elt = + match !p with + | Some p -> p elt + | None -> + let stream, push = Lwt_stream.create () in + incr workers_r; + Lwt.async (fun () -> + (* FIXME: we would like to skip some updates if more recent ones + are at the back of the queue. *) + Lwt_stream.iter_s (fun f -> f ()) stream); + p := Some push; + (c := fun () -> push None); + push elt + in + let clean () = + !c (); + decr workers_r; + c := niet; + p := None + in + let enqueue v = push (Some v) in + (clean, enqueue) + +module Make (K : sig + type t + + val t : t Type.t +end) (V : sig + type t + + val t : t Type.t +end) = +struct + type key = K.t + type value = V.t + type watch = int + + module KMap = Map.Make (struct + type t = K.t + + let compare = Type.(unstage (compare K.t)) + end) + + module IMap = Map.Make (struct + type t = int + + let compare (x : int) (y : int) = compare x y + end) + + type key_handler = value Diff.t -> unit Lwt.t + type all_handler = key -> value Diff.t -> unit Lwt.t + + let pp_value = Type.pp V.t + let equal_opt_values = Type.(unstage (equal (option V.t))) + let equal_keys = Type.(unstage (equal K.t)) + + type t = { + id : int; + (* unique watch manager id. *) + lock : Lwt_mutex.t; + (* protect [keys] and [glob]. *) + mutable next : int; + (* next id, to identify watch handlers. *) + mutable keys : (key * value option * key_handler) IMap.t; + (* key handlers. *) + mutable glob : (value KMap.t * all_handler) IMap.t; + (* global handlers. *) + enqueue : (unit -> unit Lwt.t) -> unit; + (* enqueue notifications. *) + clean : unit -> unit; + (* destroy the notification thread. *) + mutable listeners : int; + (* number of listeners. *) + mutable stop_listening : unit -> unit Lwt.t; + (* clean-up listen resources. *) + mutable notifications : int; (* number of notifcations. *) + } + + let stats t = (IMap.cardinal t.keys, IMap.cardinal t.glob) + + let to_string t = + let k, a = stats t in + Printf.sprintf "[%d: %dk/%dg|%d]" t.id k a t.listeners + + let next t = + let id = t.next in + t.next <- id + 1; + id + + let is_empty t = IMap.is_empty t.keys && IMap.is_empty t.glob + + let clear_unsafe t = + t.keys <- IMap.empty; + t.glob <- IMap.empty; + t.next <- 0 + + let clear t = + Lwt_mutex.with_lock t.lock (fun () -> + clear_unsafe t; + Lwt.return_unit) + + let v () = + let lock = Lwt_mutex.create () in + let clean, enqueue = scheduler () in + { + lock; + clean; + enqueue; + id = global (); + next = 0; + keys = IMap.empty; + glob = IMap.empty; + listeners = 0; + stop_listening = (fun () -> Lwt.return_unit); + notifications = 0; + } + + let unwatch_unsafe t id = + Log.debug (fun f -> f "unwatch %s: id=%d" (to_string t) id); + let glob = IMap.remove id t.glob in + let keys = IMap.remove id t.keys in + t.glob <- glob; + t.keys <- keys + + let unwatch t id = + Lwt_mutex.with_lock t.lock (fun () -> + unwatch_unsafe t id; + if is_empty t then t.clean (); + Lwt.return_unit) + + let mk old value = + match (old, value) with + | None, None -> assert false + | Some v, None -> `Removed v + | None, Some v -> `Added v + | Some x, Some y -> `Updated (x, y) + + let protect f () = + Lwt.catch f (fun e -> + Log.err (fun l -> + l "watch callback got: %a\n%s" Fmt.exn e (Printexc.get_backtrace ())); + Lwt.return_unit) + + let pp_option = Fmt.option ~none:(Fmt.any "") + let pp_key = Type.pp K.t + + let notify_all_unsafe t key value = + let todo = ref [] in + let glob = + IMap.fold + (fun id ((init, f) as arg) acc -> + let fire old_value = + todo := + protect (fun () -> + Log.debug (fun f -> + f "notify-all[%d.%d:%a]: %d firing! (%a -> %a)" t.id id + pp_key key t.notifications (pp_option pp_value) + old_value (pp_option pp_value) value); + t.notifications <- t.notifications + 1; + f key (mk old_value value)) + :: !todo; + let init = + match value with + | None -> KMap.remove key init + | Some v -> KMap.add key v init + in + IMap.add id (init, f) acc + in + let old_value = + try Some (KMap.find key init) with Not_found -> None + in + if equal_opt_values old_value value then ( + Log.debug (fun f -> + f "notify-all[%d:%d:%a]: same value, skipping." t.id id pp_key + key); + IMap.add id arg acc) + else fire old_value) + t.glob IMap.empty + in + t.glob <- glob; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify_key_unsafe t key value = + let todo = ref [] in + let keys = + IMap.fold + (fun id ((k, old_value, f) as arg) acc -> + if not (equal_keys key k) then IMap.add id arg acc + else if equal_opt_values value old_value then ( + Log.debug (fun f -> + f "notify-key[%d.%d:%a]: same value, skipping." t.id id pp_key + key); + IMap.add id arg acc) + else ( + todo := + protect (fun () -> + Log.debug (fun f -> + f "notify-key[%d:%d:%a] %d firing! (%a -> %a)" t.id id + pp_key key t.notifications (pp_option pp_value) + old_value (pp_option pp_value) value); + t.notifications <- t.notifications + 1; + f (mk old_value value)) + :: !todo; + IMap.add id (k, value, f) acc)) + t.keys IMap.empty + in + t.keys <- keys; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify t key value = + Lwt_mutex.with_lock t.lock (fun () -> + if is_empty t then Lwt.return_unit + else ( + notify_all_unsafe t key value; + notify_key_unsafe t key value; + Lwt.return_unit)) + + let watch_key_unsafe t key ?init f = + let id = next t in + Log.debug (fun f -> f "watch-key %s: id=%d" (to_string t) id); + t.keys <- IMap.add id (key, init, f) t.keys; + id + + let watch_key t key ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_key_unsafe t ?init key f in + Lwt.return id) + + let kmap_of_alist l = + List.fold_left (fun map (k, v) -> KMap.add k v map) KMap.empty l + + let watch_unsafe t ?(init = []) f = + let id = next t in + Log.debug (fun f -> f "watch %s: id=%d" (to_string t) id); + t.glob <- IMap.add id (kmap_of_alist init, f) t.glob; + id + + let watch t ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_unsafe t ?init f in + Lwt.return id) + + let listen_dir t dir ~key ~value = + let init () = + if t.listeners = 0 then ( + Log.debug (fun f -> f "%s: start listening to %s" (to_string t) dir); + let+ f = + !listen_dir_hook t.id dir (fun file -> + match key file with + | None -> Lwt.return_unit + | Some key -> + let rec read n = + let* value = value key in + let n' = t.notifications in + if n = n' then notify t key value + else ( + Log.debug (fun l -> l "Stale event, trying reading again"); + read n') + in + read t.notifications) + in + t.stop_listening <- f) + else ( + Log.debug (fun f -> f "%s: already listening on %s" (to_string t) dir); + Lwt.return_unit) + in + init () >|= fun () -> + t.listeners <- t.listeners + 1; + function + | () -> + if t.listeners > 0 then t.listeners <- t.listeners - 1; + if t.listeners <> 0 then Lwt.return_unit + else ( + Log.debug (fun f -> f "%s: stop listening to %s" (to_string t) dir); + t.stop_listening ()) +end diff --git a/vendors/irmin/irmin/watch.mli b/vendors/irmin/irmin/watch.mli new file mode 100644 index 000000000000..c69f79368c6a --- /dev/null +++ b/vendors/irmin/irmin/watch.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Watch] provides helpers to register event notifications on read-write + stores. *) + +include Watch_intf.Watch diff --git a/vendors/irmin/irmin/watch_intf.ml b/vendors/irmin/irmin/watch_intf.ml new file mode 100644 index 000000000000..861171e77d24 --- /dev/null +++ b/vendors/irmin/irmin/watch_intf.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Watch Helpers} *) + + type key + (** The type for store keys. *) + + type value + (** The type for store values. *) + + type watch + (** The type for watch handlers. *) + + type t + (** The type for watch state. *) + + val stats : t -> int * int + (** [stats t] is a tuple [(k,a)] represeting watch stats. [k] is the number of + single key watchers for the store [t] and [a] the number of global + watchers for [t]. *) + + val notify : t -> key -> value option -> unit Lwt.t + (** Notify all listeners in the given watch state that a key has changed, with + the new value associated to this key. [None] means the key has been + removed. *) + + val v : unit -> t + (** Create a watch state. *) + + val clear : t -> unit Lwt.t + (** Clear all register listeners in the given watch state. *) + + val watch_key : + t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + (** Watch a given key for changes. More efficient than {!watch}. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** Add a watch handler. To watch a specific key, use {!watch_key} which is + more efficient. *) + + val unwatch : t -> watch -> unit Lwt.t + (** Remove a watch handler. *) + + val listen_dir : + t -> + string -> + key:(string -> key option) -> + value:(key -> value option Lwt.t) -> + (unit -> unit Lwt.t) Lwt.t + (** Register a thread looking for changes in the given directory and return a + function to stop watching and free up resources. *) +end + +module type Watch = sig + module type S = S + (** The signature for watch helpers. *) + + val workers : unit -> int + (** [workers ()] is the number of background worker threads managing event + notification currently active. *) + + type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + (** The type for watch hooks. *) + + val none : hook + (** [none] is the hooks which asserts false. *) + + val set_listen_dir_hook : hook -> unit + (** Register a function which looks for file changes in a directory and return + a function to stop watching. It is probably best to use + {!Irmin_watcher.hook} there. By default, it uses {!none}. *) + + (** [Make] builds an implementation of watch helpers. *) + module Make (K : Type.S) (V : Type.S) : + S with type key = K.t and type value = V.t +end -- GitLab From b3133b95f9eb1352284e30e78208ac46ca4702b2 Mon Sep 17 00:00:00 2001 From: Corneliu Hoffman Date: Thu, 23 Dec 2021 18:20:49 +0000 Subject: [PATCH 11/11] added length to commit --- .../sigs/v5/context.mli | 94 +++++++++++++++++++ 1 file changed, 94 insertions(+) diff --git a/src/lib_protocol_environment/sigs/v5/context.mli b/src/lib_protocol_environment/sigs/v5/context.mli index 6114a50ed394..f6fa95056e57 100644 --- a/src/lib_protocol_environment/sigs/v5/context.mli +++ b/src/lib_protocol_environment/sigs/v5/context.mli @@ -67,6 +67,13 @@ module type VIEW = sig val list : t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t + (** [length t key] is an Lwt promise that resolve to the number of + files and sub-nodes stored under [k] in [t]. + + It is equivalent to [list t k >|= List.length] but has a + constant-time complexity. *) + val length : t -> key -> int Lwt.t + (** {2 Setters} *) (** [add t k v] is an Lwt promise that resolves to [c] such that: @@ -119,6 +126,91 @@ module type VIEW = sig 'a Lwt.t end +module Proof : sig + (** Proofs are compact representations of trees which can be shared + between a node and a client. + + The protocol is the following: + + - The node runs a function [f] over a tree [t]. While performing + this computation, the node records: the hash of [t] (called [before] + below), the hash of [f t] (called [after] below) and a subset of [t] + which is needed to replay [f] without any access to the node's storage. + Once done, the node packs this into a proof [p] and sends this to the + client. + + - The client generates an initial tree [t'] from [p] and computes [f t']. + Once done, it compares [t']'s hash and [f t']'s hash to [before] and + [after]. If they match, they know that the result state [f t'] is a + valid context state, without having to have access to the full node's + storage. *) + + (** The type for (internal) inode proofs. + + These proofs encode large directories into a more efficient tree-like + structure. + + Invariant are dependent on the backend. + + [length] is the total number of entries in the chidren of the inode. + E.g. the size of the "flattened" version of that inode. This is used + to efficiently implements paginated lists. + + Paths of singleton inodes are compacted into a single inode addressed by + that path (hence the [int list] indexing). + + [proofs] have a length of at most [Conf.entries] entries. This list can + be sparse so every proof is indexed by their position between + [0 ... (Conf.entries-1)]. For binary trees, this boolean + index is a segment of the left-right decision proof corresponding + to the path in that binary tree. *) + type 'a inode = {length : int; proofs : (int list * 'a) list} + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proofs. + + [Blinded_node h] is a shallow pointer to a node having hash [h]. + + [Node ls] is a "flat" node containing the list of files [ls]. The length + of [ls] is at most [Conf.stable_hash]. + + [Inode i] is an optimized representation of a node as a tree. Pointers in + that trees would refer to blinded nodes, nodes or to other inodes. E.g. + Blinded content is not expected to appear directly in an inodes. + + [Blinded_contents h] is a shallow pointer to contents having hash [h]. + + [Contents c] is the contents [c]. *) + type tree = + | Blinded_node of Context_hash.t + | Node of (string * tree) list + | Inode of tree inode + | Blinded_contents of Context_hash.t + | Contents of bytes + + type t + + (** The type for kinded hashes. *) + type kinded_hash = [`Contents of Context_hash.t | `Node of Context_hash.t] + + (** A proof [p] proves that the state advanced from [before p] to + [after p]. [state p]'s hash is [before p], and [state p] contains + the minimal information for the computation to reach [after p]. *) + + (** [before t] it the state's hash at the beginning of the computation. *) + val before : t -> kinded_hash + + (** [after t] is the state's hash at the end of the computation. *) + val after : t -> kinded_hash + + (** [proof t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) + val state : t -> tree +end + module Kind : sig type t = [`Value | `Tree] end @@ -183,6 +275,8 @@ module Tree : and type value := value and type tree := tree +val verify_proof : Proof.t -> (tree -> tree Lwt.t) -> tree Lwt.t + val register_resolver : 'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit -- GitLab