diff --git a/buildkite/scripts/export-git-env-vars.sh b/buildkite/scripts/export-git-env-vars.sh index db14a7810f3..9ce1369dbbb 100755 --- a/buildkite/scripts/export-git-env-vars.sh +++ b/buildkite/scripts/export-git-env-vars.sh @@ -55,10 +55,10 @@ export MINA_DOCKER_TAG="$(echo "${MINA_DEB_VERSION}-${MINA_DEB_CODENAME}" | sed # Determine the packages to build (mainnet y/N) case $GITBRANCH in - compatible|master|release/1*) # whitelist of branches that are "mainnet-like" - MINA_BUILD_MAINNET=true ;; + compatible|master|release-automation-testing/*|release/1*|release/3*) # whitelist of branches that are "mainnet-like" + export MINA_BUILD_MAINNET=true ;; *) # Other branches - MINA_BUILD_MAINNET=false ;; + export MINA_BUILD_MAINNET=false ;; esac echo "Publishing on release channel \"${RELEASE}\"" diff --git a/buildkite/scripts/promote-deb.sh b/buildkite/scripts/promote-deb.sh index 79c3d585ba1..498493cb975 100755 --- a/buildkite/scripts/promote-deb.sh +++ b/buildkite/scripts/promote-deb.sh @@ -53,7 +53,7 @@ echo "Promoting debs: ${PACKAGE}_${VERSION} to Release: ${TO_COMPONENT} and Code # If this fails, attempt to remove the lockfile and retry. if [[ -z "$NEW_VERSION" ]] || [[ "$NEW_VERSION" == "$VERSION" ]]; then - deb-s3 copy --s3-region=us-west-2 --bucket packages.o1test.net --preserve-versions --cache-control=max-age=120 $PACKAGE $CODENAME $TO_COMPONENT --versions $VERSION --arch $ARCH --component ${FROM_COMPONENT} --codename ${CODENAME} + deb-s3 copy --s3-region=us-west-2 --lock --bucket packages.o1test.net --preserve-versions --cache-control=max-age=120 $PACKAGE $CODENAME $TO_COMPONENT --versions $VERSION --arch $ARCH --component ${FROM_COMPONENT} --codename ${CODENAME} else source scripts/reversion-deb.sh \ --deb $PACKAGE \ diff --git a/buildkite/scripts/run_verify_promoted_build_job.sh b/buildkite/scripts/run_verify_promoted_build_job.sh new file mode 100755 index 00000000000..ed093b1a44b --- /dev/null +++ b/buildkite/scripts/run_verify_promoted_build_job.sh @@ -0,0 +1,110 @@ +#!/bin/bash + +# Usage (in buildkite definition) + +# steps: +# - commands: +# - "./buildkite/scripts/run_promote_build_job.sh | buildkite-agent pipeline upload" +# label: ":pipeline: run promote dockers build job" +# agents: +# size: "generic" +# plugins: +# "docker#v3.5.0": +# environment: +# - BUILDKITE_AGENT_ACCESS_TOKEN +# - "DOCKERS=Archive,Daemon" +# - "REMOVE_PROFILE_FROM_NAME=1" +# - "PROFILE=Hardfork" +# - "NETWORK=Devnet" +# - "FROM_VERSION=3.0.0devnet-tooling-dkijania-hardfork-package-gen-in-nightly-b37f50e" +# - "NEW_VERSION=3.0.0fake-ddb6fc4" +# - "CODENAMES=Focal,Buster,Bullseye" +# - "FROM_CHANNEL=Unstable" +# - "TO_CHANNEL=Experimental" +# image: codaprotocol/ci-toolchain-base:v3 +# mount-buildkite-agent: true +# propagate-environment: true + + +DEBIAN_DHALL_DEF="(./buildkite/src/Constants/DebianPackage.dhall)" +DOCKER_DHALL_DEF="(./buildkite/src/Constants/Artifacts.dhall)" +DEBIAN_VERSION_DHALL_DEF="(./buildkite/src/Constants/DebianVersions.dhall)" +PROMOTE_PACKAGE_DHALL_DEF="(./buildkite/src/Entrypoints/PromotePackage.dhall)" +PROFILES_DHALL_DEF="(./buildkite/src/Constants/Profiles.dhall)" +NETWORK_DHALL_DEF="(./buildkite/src/Constants/Network.dhall)" +DEBIAN_CHANNEL_DHALL_DEF="(./buildkite/src/Constants/DebianChannel.dhall)" + + +function usage() { + if [[ -n "$1" ]]; then + echo -e "${RED}☞ $1${CLEAR}\n"; + fi + echo " DEBIANS The comma delimitered debian names. For example: 'Daemon,Archive' " + echo " DOCKERS The comma delimitered docker names. For example: 'Daemon,Archive' " + echo " CODENAMES The Debian codenames (Bullseye, Buster etc.)" + echo " NEW_VERSION The new Debian version or new Docker tag" + echo " REMOVE_PROFILE_FROM_NAME Should we remove profile suffix from debian name" + echo " PROFILE The Docker and Debian profile (Standard, Lightnet)" + echo " NETWORK The Docker and Debian network (Devnet, Mainnet, Berkeley)" + echo " TO_CHANNEL Target debian channel" + echo " PUBLISH The Publish to docker.io flag. If defined, script will publish docker do docker.io. Otherwise it will still resides in gcr.io" + echo "" + exit 1 +} + +if [ -z "$DEBIANS" ] && [ -z "$DOCKERS" ]; then usage "No Debians nor Dockers defined for promoting!"; exit 1; fi; + +DHALL_DEBIANS="([] : List $DEBIAN_DHALL_DEF.Type)" + +if [[ -n "$DEBIANS" ]]; then + if [[ -z "$CODENAMES" ]]; then usage "Codenames is not set!"; exit 1; fi; + if [[ -z "$PROFILE" ]]; then PROFILE="Standard"; fi; + if [[ -z "$NETWORK" ]]; then NETWORK="Berkeley"; fi; + if [[ -z "$REMOVE_PROFILE_FROM_NAME" ]]; then REMOVE_PROFILE_FROM_NAME=0; fi; + if [[ -z "$PUBLISH" ]]; then PUBLISH=0; fi; + if [[ -z "$TO_CHANNEL" ]]; then TO_CHANNEL="Unstable"; fi; + if [[ -z "$NEW_VERSION" ]]; then NEW_VERSION=$FROM_VERSION; fi; + + + arr_of_debians=(${DEBIANS//,/ }) + DHALL_DEBIANS="" + for i in "${arr_of_debians[@]}"; do + DHALL_DEBIANS="${DHALL_DEBIANS}, $DEBIAN_DHALL_DEF.Type.${i}" + done + DHALL_DEBIANS="[${DHALL_DEBIANS:1}]" +fi + + +DHALL_DOCKERS="([] : List $DOCKER_DHALL_DEF.Type)" + +if [[ $PUBLISH -eq 1 ]]; then + DHALL_PUBLISH="True" + else + DHALL_PUBLISH="False" +fi + +if [[ -n "$DOCKERS" ]]; then + if [[ -z "$NEW_VERSION" ]]; then usage "New Tag is not set!"; fi; + if [[ -z "$PROFILE" ]]; then PROFILE="Standard"; fi; + + arr_of_dockers=(${DOCKERS//,/ }) + DHALL_DOCKERS="" + for i in "${arr_of_dockers[@]}"; do + DHALL_DOCKERS="${DHALL_DOCKERS}, $DOCKER_DHALL_DEF.Type.${i}" + done + DHALL_DOCKERS="[${DHALL_DOCKERS:1}]" +fi + +CODENAMES=(${CODENAMES//,/ }) +DHALL_CODENAMES="" + for i in "${CODENAMES[@]}"; do + DHALL_CODENAMES="${DHALL_CODENAMES}, $DEBIAN_VERSION_DHALL_DEF.DebVersion.${i}" + done + DHALL_CODENAMES="[${DHALL_CODENAMES:1}]" + +if [[ "${REMOVE_PROFILE_FROM_NAME}" -eq 0 ]]; then + REMOVE_PROFILE_FROM_NAME="False" +else + REMOVE_PROFILE_FROM_NAME="True" +fi +echo $PROMOTE_PACKAGE_DHALL_DEF'.verify_artifacts '"$DHALL_DEBIANS"' '"$DHALL_DOCKERS"' "'"${NEW_VERSION}"'" '$PROFILES_DHALL_DEF'.Type.'"${PROFILE}"' '$NETWORK_DHALL_DEF'.Type.'"${NETWORK}"' '"${DHALL_CODENAMES}"' '$DEBIAN_CHANNEL_DHALL_DEF'.Type.'"${TO_CHANNEL}"' "'"${TAG}"'" '${REMOVE_PROFILE_FROM_NAME}' '${DHALL_PUBLISH}' ' | dhall-to-yaml --quoted diff --git a/buildkite/src/Command/PromotePackage.dhall b/buildkite/src/Command/PromotePackage.dhall index 02076c0c731..78a5bbabcd9 100644 --- a/buildkite/src/Command/PromotePackage.dhall +++ b/buildkite/src/Command/PromotePackage.dhall @@ -104,6 +104,21 @@ let promoteDebianStep = \(spec : PromoteDebianSpec.Type) -> `if` = spec.`if` } +let promoteDebianVerificationStep = \(spec : PromoteDebianSpec.Type) -> + let name = if spec.remove_profile_from_name then "${Package.debianName spec.package Profiles.Type.Standard spec.network}" else (Package.debianName spec.package spec.profile spec.network) + in + Command.build + Command.Config::{ + commands = [ + Cmd.run "./scripts/debian/verify.sh --package ${name} --version ${spec.new_version} --codename ${DebianVersions.lowerName spec.codename} --channel ${DebianChannel.lowerName spec.to_channel}" + ], + label = "Debian: ${spec.step_key}", + key = spec.step_key, + target = Size.Small, + depends_on = spec.deps, + `if` = spec.`if` + } + let promoteDockerStep = \(spec : PromoteDockerSpec.Type) -> let old_tag = Artifact.dockerTag spec.name spec.version spec.codename spec.profile spec.network False let new_tag = Artifact.dockerTag spec.name spec.new_tag spec.codename spec.profile spec.network spec.remove_profile_from_name @@ -121,8 +136,24 @@ let promoteDockerStep = \(spec : PromoteDockerSpec.Type) -> `if` = spec.`if` } +let promoteDockerVerificationStep = \(spec : PromoteDockerSpec.Type) -> + let new_tag = Artifact.dockerTag spec.name spec.new_tag spec.codename spec.profile spec.network spec.remove_profile_from_name + let repo = if spec.publish then "docker.io/minaprotocol" else "gcr.io/o1labs-192920" + in + Command.build + Command.Config::{ + commands = [ + Cmd.run "docker pull ${repo}/${Artifact.dockerName spec.name}:${new_tag}" + ], + label = "Docker: ${spec.step_key}", + key = spec.step_key, + target = Size.Small, + depends_on = spec.deps, + `if` = spec.`if` + } + -let pipeline : List PromoteDebianSpec.Type -> +let promotePipeline : List PromoteDebianSpec.Type -> List PromoteDockerSpec.Type -> DebianVersions.DebVersion -> PipelineMode.Type -> @@ -159,11 +190,53 @@ let pipeline : List PromoteDebianSpec.Type -> }, steps = steps } + +let verifyPipeline : List PromoteDebianSpec.Type -> + List PromoteDockerSpec.Type -> + DebianVersions.DebVersion -> + PipelineMode.Type -> + Pipeline.Config.Type = + \(debians_spec : List PromoteDebianSpec.Type) -> + \(dockers_spec : List PromoteDockerSpec.Type) -> + \(debVersion: DebianVersions.DebVersion) -> + \(mode: PipelineMode.Type) -> + + let steps = + (List/map + PromoteDebianSpec.Type + Command.Type + (\(spec: PromoteDebianSpec.Type ) -> promoteDebianVerificationStep spec ) + debians_spec + ) + # + (List/map + PromoteDockerSpec.Type + Command.Type + (\(spec: PromoteDockerSpec.Type ) -> promoteDockerVerificationStep spec ) + dockers_spec + ) + in + --- tags are empty on purpose not to allow run job from automatically triggered pipelines + Pipeline.Config::{ + spec = + JobSpec::{ + dirtyWhen = DebianVersions.dirtyWhen debVersion, + path = "Release", + name = "VerifyPackage", + tags = []: List PipelineTag.Type, + mode = mode + }, + steps = steps + } + in { promoteDebianStep = promoteDebianStep , promoteDockerStep = promoteDockerStep - , pipeline = pipeline + , promoteDebianVerificationStep = promoteDebianVerificationStep + , promoteDockerVerificationStep = promoteDockerVerificationStep + , promotePipeline = promotePipeline + , verifyPipeline = verifyPipeline , PromoteDebianSpec = PromoteDebianSpec , PromoteDockerSpec = PromoteDockerSpec } \ No newline at end of file diff --git a/buildkite/src/Entrypoints/PromotePackage.dhall b/buildkite/src/Entrypoints/PromotePackage.dhall index ac3db935482..bc353f0c5ee 100644 --- a/buildkite/src/Entrypoints/PromotePackage.dhall +++ b/buildkite/src/Entrypoints/PromotePackage.dhall @@ -104,7 +104,101 @@ let promote_artifacts = let pipelineType = Pipeline.build ( - PromotePackage.pipeline + PromotePackage.promotePipeline + (debians_spec) + (dockers_spec) + (DebianVersions.DebVersion.Bullseye) + (PipelineMode.Type.Stable) + ) + in pipelineType.pipeline + +let verify_artifacts = + \(debians: List Package.Type) -> + \(dockers: List Artifact.Type) -> + \(new_version: Text ) -> + \(profile: Profile.Type) -> + \(network: Network.Type) -> + \(codenames: List DebianVersions.DebVersion ) -> + \(to_channel: DebianChannel.Type ) -> + \(tag: Text ) -> + \(remove_profile_from_name: Bool) -> + \(publish: Bool) -> + + let debians_spec = + List/map + Package.Type + (List PromotePackage.PromoteDebianSpec.Type) + (\(debian: Package.Type) -> + List/map + DebianVersions.DebVersion + PromotePackage.PromoteDebianSpec.Type + (\(codename: DebianVersions.DebVersion) -> + PromotePackage.PromoteDebianSpec::{ + profile = profile + , package = debian + , new_version = new_version + , network = network + , codename = codename + , to_channel = to_channel + , remove_profile_from_name = remove_profile_from_name + , step_key = "verify-promote-debian-${Package.lowerName debian}-${DebianVersions.lowerName codename}-${DebianChannel.lowerName to_channel}" + } + ) + codenames + + ) + debians + in + + let debians_spec = + Prelude.List.fold + (List PromotePackage.PromoteDebianSpec.Type) + debians_spec + (List PromotePackage.PromoteDebianSpec.Type) + (\(a : List PromotePackage.PromoteDebianSpec.Type) -> \(b : List PromotePackage.PromoteDebianSpec.Type) -> a # b) + ([] : List PromotePackage.PromoteDebianSpec.Type) + + in + + let dockers_spec = + List/map + Artifact.Type + (List PromotePackage.PromoteDockerSpec.Type) + (\(docker: Artifact.Type) -> + List/map + DebianVersions.DebVersion + PromotePackage.PromoteDockerSpec.Type + (\(codename: DebianVersions.DebVersion) -> + PromotePackage.PromoteDockerSpec::{ + profile = profile + , name = docker + , codename = codename + , new_tag = new_version + , network = network + , publish = publish + , remove_profile_from_name = remove_profile_from_name + , step_key = "verify-tag-${Artifact.lowerName docker}-${DebianVersions.lowerName codename}-docker" + } + ) + codenames + ) + dockers + + in + + let dockers_spec = + Prelude.List.fold + (List PromotePackage.PromoteDockerSpec.Type) + dockers_spec + (List PromotePackage.PromoteDockerSpec.Type) + (\(a : List PromotePackage.PromoteDockerSpec.Type) -> \(b : List PromotePackage.PromoteDockerSpec.Type) -> a # b) + ([] : List PromotePackage.PromoteDockerSpec.Type) + + in + + let pipelineType = Pipeline.build + ( + PromotePackage.verifyPipeline (debians_spec) (dockers_spec) (DebianVersions.DebVersion.Bullseye) @@ -113,5 +207,6 @@ let promote_artifacts = in pipelineType.pipeline in { - promote_artifacts = promote_artifacts + promote_artifacts = promote_artifacts, + verify_artifacts = verify_artifacts } \ No newline at end of file diff --git a/buildkite/src/Jobs/Lint/Merge.dhall b/buildkite/src/Jobs/Lint/Merge.dhall index 44be58216ed..f02904fddae 100644 --- a/buildkite/src/Jobs/Lint/Merge.dhall +++ b/buildkite/src/Jobs/Lint/Merge.dhall @@ -48,10 +48,9 @@ Pipeline.build }, Command.build Command.Config::{ - commands = [ Cmd.run "buildkite/scripts/merges-cleanly.sh berkeley"] - , label = "Check merges cleanly into berkeley" - , key = "clean-merge-berkeley" - , soft_fail = Some (B/SoftFail.Boolean True) + commands = [ Cmd.run "buildkite/scripts/merges-cleanly.sh master"] + , label = "Check merges cleanly into master" + , key = "clean-merge-master" , target = Size.Small , docker = Some Docker::{ image = (../../Constants/ContainerImages.dhall).toolchainBase diff --git a/scripts/debian/verify.sh b/scripts/debian/verify.sh new file mode 100755 index 00000000000..65fce185d12 --- /dev/null +++ b/scripts/debian/verify.sh @@ -0,0 +1,48 @@ +#!/usr/bin/env bash +set -eox pipefail + +CHANNEL=umt-mainnet +VERSION=3.0.0-f872d85 +CODENAME=bullseye + +while [[ "$#" -gt 0 ]]; do case $1 in + -c|--channel) CHANNEL="$2"; shift;; + -v|--version) VERSION="$2"; shift;; + -p|--package) PACKAGE="$2"; shift;; + -m|--codename) CODENAME="$2"; shift;; + *) echo "Unknown parameter passed: $1"; exit 1;; +esac; shift; done + +if [ -z $PACKAGE ]; then + echo "No package defined. exiting.."; exit 1; +fi + +case $PACKAGE in + mina-archive) COMMAND="mina-archive --version && mina-archive --help" ;; + mina-logproc) COMMAND="echo skipped execution for mina-logproc" ;; + mina-*) COMMAND="mina --version && mina --help" ;; + *) echo "Unknown package passed: $PACKAGE"; exit 1;; +esac + +SCRIPT=' set -x \ + && export DEBIAN_FRONTEND=noninteractive TZ=Etc/UTC \ + && echo installing mina \ + && apt-get update > /dev/null \ + && apt-get install -y lsb-release ca-certificates > /dev/null \ + && echo "deb [trusted=yes] http://packages.o1test.net '$CODENAME' '$CHANNEL'" > /etc/apt/sources.list.d/mina.list \ + && apt-get update > /dev/null \ + && apt list -a '$PACKAGE' \ + && apt-get install -y --allow-downgrades '$PACKAGE'='$VERSION' \ + && '$COMMAND' + ' + +case $CODENAME in + buster) DOCKER_IMAGE="debian:buster" ;; + bullseye) DOCKER_IMAGE="debian:bullseye" ;; + focal) DOCKER_IMAGE="ubuntu:focal" ;; + *) echo "Unknown codename passed: $CODENAME"; exit 1;; +esac + +echo "Testing packages on all images" \ + && docker run --rm $DOCKER_IMAGE bash -c "$SCRIPT" \ + && echo 'OK: ALL WORKED FINE!' || (echo 'KO: ERROR!!!' && exit 1) diff --git a/scripts/docker/verify.sh b/scripts/docker/verify.sh new file mode 100755 index 00000000000..97f068c9c1d --- /dev/null +++ b/scripts/docker/verify.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set +x + +REPO=gcr.io/o1labs-192920 +VERSION=3.0.0-f872d85 + +while [[ "$#" -gt 0 ]]; do case $1 in + -p|--package) PACKAGE="$2"; shift;; + -c|--codename) CODENAME="$2"; shift;; + -s|--suffix) SUFFIX="$2"; shift;; + -r|--repo) REPO="$2"; shift;; + -v|--version) VERSION="$2"; shift;; + *) echo "Unknown parameter passed: $1"; exit 1;; +esac; shift; done + +docker pull $REPO/$PACKAGE:$VERSION-${CODENAME}${SUFFIX} + +if [ ?$ != 0 ]; then + echo "Docker verification for $_codename $_package failed" + exit 1 +fi diff --git a/scripts/release-docker.sh b/scripts/release-docker.sh index edc74fb9771..aaa0955701e 100755 --- a/scripts/release-docker.sh +++ b/scripts/release-docker.sh @@ -73,6 +73,7 @@ IMAGE="--build-arg image=${IMAGE}" case "${DEB_BUILD_FLAGS}" in *instrumented) DOCKER_DEB_SUFFIX="--build-arg deb_suffix=instrumented" + BUILD_FLAG_SUFFIX="-instrumented" ;; *) ;; @@ -82,6 +83,7 @@ IMAGE="--build-arg image=${IMAGE}" case "${DEB_BUILD_FLAGS}" in *instrumented) DOCKER_DEB_SUFFIX="--build-arg deb_suffix=${DEB_PROFILE}-instrumented" + BUILD_FLAG_SUFFIX="-instrumented" ;; *) DOCKER_DEB_SUFFIX="--build-arg deb_suffix=${DEB_PROFILE}" @@ -168,10 +170,10 @@ if [[ -z "${MINA_REPO}" ]]; then fi DOCKER_REGISTRY="gcr.io/o1labs-192920" -TAG="${DOCKER_REGISTRY}/${SERVICE}:${VERSION}" +TAG="${DOCKER_REGISTRY}/${SERVICE}:${VERSION}${BUILD_FLAG_SUFFIX}" # friendly, predictable tag GITHASH=$(git rev-parse --short=7 HEAD) -HASHTAG="${DOCKER_REGISTRY}/${SERVICE}:${GITHASH}-${DEB_CODENAME##*=}-${NETWORK##*=}" +HASHTAG="${DOCKER_REGISTRY}/${SERVICE}:${GITHASH}-${DEB_CODENAME##*=}-${NETWORK##*=}${BUILD_FLAG_SUFFIX}" BUILD_NETWORK="--network=host" # If DOCKER_CONTEXT is not specified, assume none and just pipe the dockerfile into docker build diff --git a/src/lib/merkle_ledger_tests/dune b/src/lib/merkle_ledger_tests/dune index 04d6b989897..878d9bebeca 100644 --- a/src/lib/merkle_ledger_tests/dune +++ b/src/lib/merkle_ledger_tests/dune @@ -2,41 +2,54 @@ (name merkle_ledger_tests) (public_name merkle_ledger_tests) (library_flags -linkall) + (flags + (:standard -warn-error +a) + -open Core_kernel ) + (modules (:standard \ "main")) + (preprocess (pps ppx_version ppx_jane ppx_compare ppx_deriving.show ppx_deriving_yojson)) (libraries - ;; opam libraries - core - sexplib0 - bin_prot.shape + ; Opam + alcotest + async + async_kernel + async_unix base.base_internalhash_types base.caml - core_kernel.uuid + bin_prot.shape + core core.uuid - ppx_inline_test.config - result - async_kernel - async_unix - async core_kernel - ;; local libraries + core_kernel.uuid + result + sexplib0 + ; Mina + base58_check bounded_types + codable + currency + data_hash_lib + direction + key_value_database + merkle_address merkle_ledger merkle_mask mina_base - signature_lib - currency - base58_check - direction - codable mina_base.import mina_numbers mina_stdlib - data_hash_lib - key_value_database - merkle_address ppx_version.runtime - ) - (preprocess - (pps ppx_version ppx_jane ppx_compare ppx_deriving.show ppx_deriving_yojson)) + signature_lib ) + (instrumentation (backend bisect_ppx)) ) + +(tests + (names main) + (flags + (:standard -warn-error +a) + -open Merkle_ledger_tests ) + (modules main) + (libraries + alcotest + merkle_ledger_tests ) + (action (run %{test})) (instrumentation (backend bisect_ppx)) - (inline_tests (flags -verbose -show-counts)) - (synopsis "Testing account databases")) + ) diff --git a/src/lib/merkle_ledger_tests/main.ml b/src/lib/merkle_ledger_tests/main.ml new file mode 100644 index 00000000000..2c688ec9b82 --- /dev/null +++ b/src/lib/merkle_ledger_tests/main.ml @@ -0,0 +1,11 @@ +(* Testing + ------- + + Component: Merkle ledger tests + Subject: Run all Merkle ledger tests + Invocation: dune exec src/lib/merkle_ledger_tests/main.exe +*) + +let () = + let tests = Test_database.tests @ Test.tests @ Test_mask.tests in + Alcotest.run "Merkle ledger" tests diff --git a/src/lib/merkle_ledger_tests/test.ml b/src/lib/merkle_ledger_tests/test.ml index 5e8b8517bfc..ce6b5f7ee14 100644 --- a/src/lib/merkle_ledger_tests/test.ml +++ b/src/lib/merkle_ledger_tests/test.ml @@ -1,76 +1,83 @@ +(* Testing + ------- + + Component: Merkle ledger + Subject: Database integration testing + Invocation: dune exec src/lib/merkle_ledger_tests/main.exe -- test "Databases" +*) + open Core open Test_stubs module Database = Merkle_ledger.Database -let%test_module "Database integration test" = - ( module struct - module Depth = struct - let depth = 4 - end +module Depth = struct + let depth = 4 +end - module Location = Merkle_ledger.Location.T +module Location = Merkle_ledger.Location.T - module Location_binable = struct - module Arg = struct - type t = Location.t = - | Generic of Merkle_ledger.Location.Bigstring.Stable.Latest.t - | Account of Location.Addr.Stable.Latest.t - | Hash of Location.Addr.Stable.Latest.t - [@@deriving bin_io_unversioned, hash, sexp, compare] - end +module Location_binable = struct + module Arg = struct + type t = Location.t = + | Generic of Merkle_ledger.Location.Bigstring.Stable.Latest.t + | Account of Location.Addr.Stable.Latest.t + | Hash of Location.Addr.Stable.Latest.t + [@@deriving bin_io_unversioned, hash, sexp, compare] + end - type t = Arg.t = - | Generic of Merkle_ledger.Location.Bigstring.t - | Account of Location.Addr.t - | Hash of Location.Addr.t - [@@deriving hash, sexp, compare] + type t = Arg.t = + | Generic of Merkle_ledger.Location.Bigstring.t + | Account of Location.Addr.t + | Hash of Location.Addr.t + [@@deriving hash, sexp, compare] - include Hashable.Make_binable (Arg) [@@deriving - sexp, compare, hash, yojson] - end + include Hashable.Make_binable (Arg) [@@deriving sexp, compare, hash, yojson] +end - module Inputs = struct - include Test_stubs.Base_inputs - module Location = Location - module Location_binable = Location_binable - module Kvdb = In_memory_kvdb - module Storage_locations = Storage_locations - end +module Inputs = struct + include Test_stubs.Base_inputs + module Location = Location + module Location_binable = Location_binable + module Kvdb = In_memory_kvdb + module Storage_locations = Storage_locations +end - module DB = Database.Make (Inputs) - module Binary_tree = Binary_tree.Make (Account) (Hash) (Depth) +module DB = Database.Make (Inputs) +module Binary_tree = Binary_tree.Make (Account) (Hash) (Depth) - let%test_unit "databases have equivalent hash values" = - let num_accounts = (1 lsl Depth.depth) - 1 in - let gen_non_zero_balances = - let open Quickcheck.Generator in - list_with_length num_accounts Balance.gen - in - Quickcheck.test ~trials:5 ~sexp_of:[%sexp_of: Balance.t list] - gen_non_zero_balances ~f:(fun balances -> - let account_ids = Account_id.gen_accounts num_accounts in - let accounts = List.map2_exn account_ids balances ~f:Account.create in - DB.with_ledger ~depth:Depth.depth ~f:(fun db -> - let enumerate_dir_combinations max_depth = - Sequence.range 0 (max_depth - 1) - |> Sequence.fold ~init:[ [] ] ~f:(fun acc _ -> - acc - @ List.map acc ~f:(List.cons Direction.Left) - @ List.map acc ~f:(List.cons Direction.Right) ) +let test_db () = + let num_accounts = (1 lsl Depth.depth) - 1 in + let gen_non_zero_balances = + let open Quickcheck.Generator in + list_with_length num_accounts Balance.gen + in + Quickcheck.test ~trials:5 ~sexp_of:[%sexp_of: Balance.t list] + gen_non_zero_balances ~f:(fun balances -> + let account_ids = Account_id.gen_accounts num_accounts in + let accounts = List.map2_exn account_ids balances ~f:Account.create in + DB.with_ledger ~depth:Depth.depth ~f:(fun db -> + let enumerate_dir_combinations max_depth = + Sequence.range 0 (max_depth - 1) + |> Sequence.fold ~init:[ [] ] ~f:(fun acc _ -> + acc + @ List.map acc ~f:(List.cons Direction.Left) + @ List.map acc ~f:(List.cons Direction.Right) ) + in + List.iter accounts ~f:(fun account -> + let account_id = Account.identifier account in + ignore @@ DB.get_or_create_account db account_id account ) ; + let binary_tree = Binary_tree.set_accounts accounts in + Sequence.iter + (enumerate_dir_combinations Depth.depth |> Sequence.of_list) + ~f:(fun dirs -> + let db_hash = + DB.get_inner_hash_at_addr_exn db (DB.Addr.of_directions dirs) in - List.iter accounts ~f:(fun account -> - let account_id = Account.identifier account in - ignore @@ DB.get_or_create_account db account_id account ) ; - let binary_tree = Binary_tree.set_accounts accounts in - Sequence.iter - (enumerate_dir_combinations Depth.depth |> Sequence.of_list) - ~f:(fun dirs -> - let db_hash = - DB.get_inner_hash_at_addr_exn db - (DB.Addr.of_directions dirs) - in - let binary_hash = - Binary_tree.get_inner_hash_at_addr_exn binary_tree dirs - in - assert (Hash.equal binary_hash db_hash) ) ) ) - end ) + let binary_hash = + Binary_tree.get_inner_hash_at_addr_exn binary_tree dirs + in + assert (Hash.equal binary_hash db_hash) ) ) ) + +let tests = + [ ("Databases", [ Alcotest.test_case "equivalent hash values" `Quick test_db ]) + ] diff --git a/src/lib/merkle_ledger_tests/test_database.ml b/src/lib/merkle_ledger_tests/test_database.ml index e6ac59a406f..a4014301b8e 100644 --- a/src/lib/merkle_ledger_tests/test_database.ml +++ b/src/lib/merkle_ledger_tests/test_database.ml @@ -1,60 +1,80 @@ -open Core -open Test_stubs - -let%test_module "test functor on in memory databases" = - ( module struct - module Intf = Merkle_ledger.Intf - module Database = Merkle_ledger.Database - - module type DB = - Intf.Ledger.DATABASE - with type key := Key.t - and type token_id := Token_id.t - and type token_id_set := Token_id.Set.t - and type account_id := Account_id.t - and type account_id_set := Account_id.Set.t - and type account := Account.t - and type root_hash := Hash.t - and type hash := Hash.t - - module type Test_intf = sig - val depth : int - - module Location : Merkle_ledger.Location_intf.S - - module MT : - DB with module Location = Location and module Addr = Location.Addr - - val with_instance : (MT.t -> 'a) -> 'a - end - - module Make (Test : Test_intf) = struct - module MT = Test.MT - - let%test_unit "getting a non existing account returns None" = - Test.with_instance (fun mdb -> - Quickcheck.test - (MT.For_tests.gen_account_location ~ledger_depth:(MT.depth mdb)) - ~f:(fun location -> assert (Option.is_none (MT.get mdb location))) ) +(* Testing + ------- - let create_new_account_exn mdb account = - let public_key = Account.identifier account in - let action, location = - MT.get_or_create_account mdb public_key account |> Or_error.ok_exn - in - match action with - | `Existed -> - failwith "Expected to allocate a new account" - | `Added -> - location + Component: In memory database + Subject: Merkle ledger tests for in-memory database + Invocation: \ + dune exec src/lib/merkle_ledger_tests/main.exe -- test "In-memory db" +*) - let%test "add and retrieve an account" = +open Core +open Test_stubs +module Intf = Merkle_ledger.Intf +module Database = Merkle_ledger.Database + +module type DB = + Intf.Ledger.DATABASE + with type key := Key.t + and type token_id := Token_id.t + and type token_id_set := Token_id.Set.t + and type account_id := Account_id.t + and type account_id_set := Account_id.Set.t + and type account := Account.t + and type root_hash := Hash.t + and type hash := Hash.t + +module type Test_intf = sig + val depth : int + + module Location : Merkle_ledger.Location_intf.S + + module MT : DB with module Location = Location and module Addr = Location.Addr + + val with_instance : (MT.t -> 'a) -> 'a +end + +module Make (Test : Test_intf) = struct + module MT = Test.MT + + let test_section_name = Printf.sprintf "In-memory db (depth %d)" Test.depth + + let test_stack = Stack.create () + + let add_test ?(speed = `Quick) name f = + Alcotest.test_case name speed f |> Stack.push test_stack + + let test_non_existing_account_is_none () = + Test.with_instance (fun mdb -> + Quickcheck.test + (MT.For_tests.gen_account_location ~ledger_depth:(MT.depth mdb)) + ~f:(fun location -> assert (Option.is_none (MT.get mdb location))) ) + + let () = + add_test "getting a non existing account returns None" + test_non_existing_account_is_none + + let create_new_account_exn mdb account = + let public_key = Account.identifier account in + let action, location = + MT.get_or_create_account mdb public_key account |> Or_error.ok_exn + in + match action with + | `Existed -> + failwith "Expected to allocate a new account" + | `Added -> + location + + let () = + add_test "add and retrieve an account" (fun () -> Test.with_instance (fun mdb -> let account = Quickcheck.random_value Account.gen in let location = create_new_account_exn mdb account in - Account.equal (Option.value_exn (MT.get mdb location)) account ) + [%test_eq: Account.t] + (Option.value_exn (MT.get mdb location)) + account ) ) - let%test "accounts are atomic" = + let () = + add_test "accounts are atomic" (fun () -> Test.with_instance (fun mdb -> let account = Quickcheck.random_value Account.gen in let location = create_new_account_exn mdb account in @@ -63,21 +83,23 @@ let%test_module "test functor on in memory databases" = MT.location_of_account mdb (Account.identifier account) |> Option.value_exn in - MT.Location.equal location location' - && - match (MT.get mdb location, MT.get mdb location') with - | Some acct, Some acct' -> - Account.equal acct acct' - | _, _ -> - false ) - - let dedup_accounts accounts = - List.dedup_and_sort accounts ~compare:(fun account1 account2 -> - Account_id.compare - (Account.identifier account1) - (Account.identifier account2) ) - - let%test_unit "length" = + assert ( + MT.Location.equal location location' + && + match (MT.get mdb location, MT.get mdb location') with + | Some acct, Some acct' -> + Account.equal acct acct' + | _, _ -> + false ) ) ) + + let dedup_accounts accounts = + List.dedup_and_sort accounts ~compare:(fun account1 account2 -> + Account_id.compare + (Account.identifier account1) + (Account.identifier account2) ) + + let () = + add_test "length" (fun () -> Test.with_instance (fun mdb -> let open Quickcheck.Generator in let max_accounts = Int.min (1 lsl MT.depth mdb) (1 lsl 5) in @@ -97,10 +119,11 @@ let%test_module "test functor on in memory databases" = List.iter accounts ~f:(fun account -> ignore @@ create_new_account_exn mdb account ) ; let result = MT.num_accounts mdb in - [%test_eq: int] result num_initial_accounts ) + [%test_eq: int] result num_initial_accounts ) ) - let%test "get_or_create_acount does not update an account if key already \ - exists" = + let () = + add_test "no update on get_or_create_acount if key already exists" + (fun () -> Test.with_instance (fun mdb -> let account_id = Quickcheck.random_value Account_id.gen in let balance = @@ -118,15 +141,17 @@ let%test_module "test functor on in memory databases" = MT.get_or_create_account mdb account_id account' |> Or_error.ok_exn in - [%equal: Test.Location.t] location location' - && (match action with `Existed -> true | `Added -> false) - && not - (Mina_base.Account.equal - (Option.value_exn (MT.get mdb location)) - account' ) ) - - let%test_unit "get_or_create_account t account = location_of_account \ - account.key" = + assert ( + [%equal: Test.Location.t] location location' + && (match action with `Existed -> true | `Added -> false) + && not + (Mina_base.Account.equal + (Option.value_exn (MT.get mdb location)) + account' ) ) ) ) + + let () = + add_test "get_or_create_account t account = location_of_account account.key" + (fun () -> Test.with_instance (fun mdb -> let accounts_gen = let open Quickcheck.Let_syntax in @@ -145,10 +170,12 @@ let%test_module "test functor on in memory databases" = let location' = MT.location_of_account mdb account_id |> Option.value_exn in - assert ([%equal: Test.Location.t] location location') ) ) + assert ([%equal: Test.Location.t] location location') ) ) ) - let%test_unit "set_inner_hash_at_addr_exn(address,hash); \ - get_inner_hash_at_addr_exn(address) = hash" = + let () = + add_test + "set_inner_hash_at_addr_exn(address,hash); \ + get_inner_hash_at_addr_exn(address) = hash" (fun () -> let random_hash = Hash.hash_account @@ Quickcheck.random_value Account.gen in @@ -160,33 +187,30 @@ let%test_module "test functor on in memory databases" = let address = MT.Addr.of_directions direction in MT.set_inner_hash_at_addr_exn mdb address random_hash ; let result = MT.get_inner_hash_at_addr_exn mdb address in - assert (Hash.equal result random_hash) ) ) - - let random_accounts max_height = - let num_accounts = 1 lsl max_height in - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts Account.gen) - - let populate_db mdb max_height = - random_accounts max_height - |> List.iter ~f:(fun account -> - let action, location = - MT.get_or_create_account mdb - (Account.identifier account) - account - |> Or_error.ok_exn - in - match action with - | `Added -> - () - | `Existed -> - MT.set mdb location account ) - - let%test_unit "If the entire database is full, let \ - addresses_and_accounts = \ - get_all_accounts_rooted_at_exn(address) in \ - set_batch_accounts(addresses_and_accounts) won't cause \ - any changes" = + assert (Hash.equal result random_hash) ) ) ) + + let random_accounts max_height = + let num_accounts = 1 lsl max_height in + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts Account.gen) + + let populate_db mdb max_height = + random_accounts max_height + |> List.iter ~f:(fun account -> + let action, location = + MT.get_or_create_account mdb (Account.identifier account) account + |> Or_error.ok_exn + in + match action with + | `Added -> + () + | `Existed -> + MT.set mdb location account ) + + let () = + add_test + "set_batch_accounts all_accounts doesn't change already full database " + (fun () -> Test.with_instance (fun mdb -> let depth = MT.depth mdb in let max_height = Int.min depth 5 in @@ -204,9 +228,10 @@ let%test_module "test functor on in memory databases" = in MT.set_batch_accounts mdb addresses_and_accounts ; let new_merkle_root = MT.merkle_root mdb in - assert (Hash.equal old_merkle_root new_merkle_root) ) ) + assert (Hash.equal old_merkle_root new_merkle_root) ) ) ) - let%test_unit "set_batch_accounts would change the merkle root" = + let () = + add_test "set_batch_accounts would change the merkle root" (fun () -> Test.with_instance (fun mdb -> let depth = MT.depth mdb in let max_height = Int.min 5 depth in @@ -252,10 +277,11 @@ let%test_module "test functor on in memory databases" = let old_merkle_root = MT.merkle_root mdb in MT.set_batch_accounts mdb new_addresses_and_accounts ; let new_merkle_root = MT.merkle_root mdb in - assert (not @@ Hash.equal old_merkle_root new_merkle_root) ) ) ) + assert (not @@ Hash.equal old_merkle_root new_merkle_root) ) ) ) ) - let%test_unit "We can retrieve accounts by their by key after using \ - set_batch_accounts" = + let () = + add_test "key by key account retrieval after set_batch_accounts works" + (fun () -> Test.with_instance (fun mdb -> (* We want to add accounts to a nonempty database *) let max_height = Int.min (MT.depth mdb - 1) 3 in @@ -294,11 +320,13 @@ let%test_module "test functor on in memory databases" = actual_last_location ~message: (sprintf "(expected_location: %i) (actual_location: %i)" - expected_last_location actual_last_location ) ) + expected_last_location actual_last_location ) ) ) - let%test_unit "If the entire database is full, \ - set_all_accounts_rooted_at_exn(address,accounts);get_all_accounts_rooted_at_exn(address) \ - = accounts" = + let () = + add_test + "when database is full, \ + set_all_accounts_rooted_at_exn(address,accounts);get_all_accounts_rooted_at_exn(address) \ + = accounts " (fun () -> Test.with_instance (fun mdb -> let max_height = Int.min (MT.depth mdb) 5 in populate_db mdb max_height ; @@ -323,9 +351,10 @@ let%test_module "test functor on in memory databases" = List.map ~f:snd @@ MT.get_all_accounts_rooted_at_exn mdb address in - assert (List.equal Account.equal accounts result) ) ) + assert (List.equal Account.equal accounts result) ) ) ) - let%test_unit "create_empty doesn't modify the hash" = + let () = + add_test "create_empty doesn't modify the hash" (fun () -> Test.with_instance (fun ledger -> let open MT in let key = Quickcheck.random_value Account_id.gen in @@ -337,38 +366,43 @@ let%test_module "test functor on in memory databases" = failwith "create_empty with empty ledger somehow already has that key?" | `Added, _ -> - [%test_eq: Hash.t] start_hash (merkle_root ledger) ) + [%test_eq: Hash.t] start_hash (merkle_root ledger) ) ) - let%test "get_at_index_exn t (index_of_account_exn t public_key) = \ - account" = + let () = + add_test "get_at_index_exn t (index_of_account_exn t public_key) = account" + (fun () -> Test.with_instance (fun mdb -> let max_height = Int.min (MT.depth mdb) 5 in let accounts = random_accounts max_height |> dedup_accounts in List.iter accounts ~f:(fun account -> ignore @@ create_new_account_exn mdb account ) ; - Sequence.of_list accounts - |> Sequence.for_all ~f:(fun account -> - let indexed_account = - MT.index_of_account_exn mdb (Account.identifier account) - |> MT.get_at_index_exn mdb - in - Account.equal account indexed_account ) ) - - let test_subtree_range mdb ~f max_height = - populate_db mdb max_height ; - Sequence.range 0 (1 lsl max_height) |> Sequence.iter ~f - - let%test_unit "set_at_index_exn t index account; get_at_index_exn t \ - index = account" = + assert ( + Sequence.of_list accounts + |> Sequence.for_all ~f:(fun account -> + let indexed_account = + MT.index_of_account_exn mdb (Account.identifier account) + |> MT.get_at_index_exn mdb + in + Account.equal account indexed_account ) ) ) ) + + let test_subtree_range mdb ~f max_height = + populate_db mdb max_height ; + Sequence.range 0 (1 lsl max_height) |> Sequence.iter ~f + + let () = + add_test + "set_at_index_exn t index account; get_at_index_exn t index = account" + (fun () -> Test.with_instance (fun mdb -> let max_height = Int.min (MT.depth mdb) 5 in test_subtree_range mdb max_height ~f:(fun index -> let account = Quickcheck.random_value Account.gen in MT.set_at_index_exn mdb index account ; let result = MT.get_at_index_exn mdb index in - assert (Account.equal account result) ) ) + assert (Account.equal account result) ) ) ) - let%test_unit "implied_root(account) = root_hash" = + let () = + add_test "implied_root(account) = root_hash" (fun () -> Test.with_instance (fun mdb -> let depth = MT.depth mdb in let max_height = Int.min depth 5 in @@ -383,9 +417,10 @@ let%test_module "test functor on in memory databases" = let path = MT.merkle_path_at_addr_exn mdb address in let leaf_hash = MT.get_inner_hash_at_addr_exn mdb address in let root_hash = MT.merkle_root mdb in - assert (MT.Path.check_path path leaf_hash root_hash) ) ) + assert (MT.Path.check_path path leaf_hash root_hash) ) ) ) - let%test_unit "implied_root(index) = root_hash" = + let () = + add_test "implied_root(index) = root_hash" (fun () -> Test.with_instance (fun mdb -> let depth = MT.depth mdb in let max_height = Int.min depth 5 in @@ -396,30 +431,31 @@ let%test_module "test functor on in memory databases" = (MT.Addr.of_int_exn ~ledger_depth:depth index) in let root_hash = MT.merkle_root mdb in - assert (MT.Path.check_path path leaf_hash root_hash) ) ) + assert (MT.Path.check_path path leaf_hash root_hash) ) ) ) - let%test_unit "iter" = + let () = + add_test "iter" (fun () -> Test.with_instance (fun mdb -> let max_height = Int.min (MT.depth mdb) 5 in let accounts = random_accounts max_height |> dedup_accounts in List.iter accounts ~f:(fun account -> ignore (create_new_account_exn mdb account : Test.Location.t) ) ; let expect = MT.to_list_sequential mdb in - [%test_result: Account.t list] accounts ~expect ) - - let%test_unit "Add 2^d accounts (for testing, d is small)" = - if Test.depth <= 8 then + [%test_result: Account.t list] accounts ~expect ) ) + + let () = + if Test.depth <= 8 then + (* d needs to be small enough *) + let name = Printf.sprintf "add 2^%d accounts" Test.depth in + add_test name (fun () -> + let num_accounts = 1 lsl Test.depth in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts Balance.gen) + in + let accounts = List.map2_exn account_ids balances ~f:Account.create in Test.with_instance (fun mdb -> - let num_accounts = 1 lsl Test.depth in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts - Balance.gen ) - in - let accounts = - List.map2_exn account_ids balances ~f:Account.create - in List.iter accounts ~f:(fun account -> ignore @@ create_new_account_exn mdb account ) ; let retrieved_accounts = @@ -428,9 +464,10 @@ let%test_module "test functor on in memory databases" = in assert ( Stdlib.List.compare_lengths accounts retrieved_accounts = 0 ) ; - assert (List.equal Account.equal accounts retrieved_accounts) ) + assert (List.equal Account.equal accounts retrieved_accounts) ) ) - let%test_unit "fold over account balances" = + let () = + add_test "fold over account balances" (fun () -> Test.with_instance (fun mdb -> let num_accounts = 5 in let account_ids = Account_id.gen_accounts num_accounts in @@ -451,9 +488,10 @@ let%test_module "test functor on in memory databases" = MT.foldi mdb ~init:0 ~f:(fun _addr total account -> Balance.to_nanomina_int (Account.balance account) + total ) in - assert (Int.equal retrieved_total total) ) + assert (Int.equal retrieved_total total) ) ) - let%test_unit "fold_until over account balances" = + let () = + add_test "fold_until over account balances" (fun () -> Async_unix.Thread_safe.block_on_async_exn (fun () -> Test.with_instance (fun mdb -> let num_accounts = 5 in @@ -488,61 +526,65 @@ let%test_module "test functor on in memory databases" = else Continue new_total ) ~finish:(fun total -> total) in - assert (Int.equal retrieved_total total) ) ) + assert (Int.equal retrieved_total total) ) ) ) + + let tests = + let actual_tests = Stack.fold test_stack ~f:(fun l t -> t :: l) ~init:[] in + (test_section_name, actual_tests) +end + +module Make_db (Depth : sig + val depth : int +end) = +Make (struct + let depth = Depth.depth + + module Location = Merkle_ledger.Location.T + + module Location_binable = struct + module Arg = struct + type t = Location.t = + | Generic of Merkle_ledger.Location.Bigstring.Stable.Latest.t + | Account of Location.Addr.Stable.Latest.t + | Hash of Location.Addr.Stable.Latest.t + [@@deriving bin_io_unversioned, hash, sexp, compare] end - module Make_db (Depth : sig - val depth : int - end) = - Make (struct - let depth = Depth.depth - - module Location = Merkle_ledger.Location.T - - module Location_binable = struct - module Arg = struct - type t = Location.t = - | Generic of Merkle_ledger.Location.Bigstring.Stable.Latest.t - | Account of Location.Addr.Stable.Latest.t - | Hash of Location.Addr.Stable.Latest.t - [@@deriving bin_io_unversioned, hash, sexp, compare] - end - - type t = Arg.t = - | Generic of Merkle_ledger.Location.Bigstring.Stable.Latest.t - | Account of Location.Addr.Stable.Latest.t - | Hash of Location.Addr.Stable.Latest.t - [@@deriving hash, sexp, compare] - - include Hashable.Make_binable (Arg) [@@deriving - sexp, compare, hash, yojson] - end - - module Inputs = struct - include Test_stubs.Base_inputs - module Location = Location - module Location_binable = Location_binable - module Kvdb = In_memory_kvdb - module Storage_locations = Storage_locations - end - - module MT = Database.Make (Inputs) - - (* TODO: maybe this function should work with dynamic modules *) - let with_instance (f : MT.t -> 'a) = - let mdb = MT.create ~depth () in - f mdb - end) - - module Depth_4 = struct - let depth = 4 - end + type t = Arg.t = + | Generic of Merkle_ledger.Location.Bigstring.Stable.Latest.t + | Account of Location.Addr.Stable.Latest.t + | Hash of Location.Addr.Stable.Latest.t + [@@deriving hash, sexp, compare] - module Mdb_d4 = Make_db (Depth_4) + include Hashable.Make_binable (Arg) [@@deriving sexp, compare, hash, yojson] + end - module Depth_30 = struct - let depth = 30 - end + module Inputs = struct + include Test_stubs.Base_inputs + module Location = Location + module Location_binable = Location_binable + module Kvdb = In_memory_kvdb + module Storage_locations = Storage_locations + end + + module MT = Database.Make (Inputs) + + (* TODO: maybe this function should work with dynamic modules *) + let with_instance (f : MT.t -> 'a) = + let mdb = MT.create ~depth () in + f mdb +end) + +module Depth_4 = struct + let depth = 4 +end + +module Mdb_d4 = Make_db (Depth_4) + +module Depth_30 = struct + let depth = 30 +end + +module Mdb_d30 = Make_db (Depth_30) - module Mdb_d30 = Make_db (Depth_30) - end ) +let tests = [ Mdb_d4.tests; Mdb_d30.tests ] diff --git a/src/lib/merkle_ledger_tests/test_mask.ml b/src/lib/merkle_ledger_tests/test_mask.ml index a7455679115..76c661c0da1 100644 --- a/src/lib/merkle_ledger_tests/test_mask.ml +++ b/src/lib/merkle_ledger_tests/test_mask.ml @@ -1,4 +1,12 @@ -(* test_mask.ml -- tests Merkle mask connected to underlying Merkle tree *) +(* Testing + ------- + + Component: Merkle masks + Subject: Test Merkle mask connected to underlying Merkle tree + Invocation: \ + dune exec src/lib/merkle_ledger_tests/main.exe -- \ + test "Mask with underlying Merkle tree" +*) open Core open Test_stubs @@ -78,6 +86,14 @@ module Make (Test : Test_intf) = struct in add_direction 0 false [] + let test_section_name = + Printf.sprintf "Mask with underlying Merkle tree (depth:%d)" Test.depth + + let test_stack = Stack.create () + + let add_test name f_test = + Alcotest.test_case name `Quick f_test |> Stack.push test_stack + let dummy_address = Test.Location.Addr.of_directions directions let dummy_location = Test.Location.Account dummy_address @@ -123,19 +139,19 @@ module Make (Test : Test_intf) = struct | `Added -> location - let%test "parent, mask agree on set" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - Maskable.set maskable dummy_location dummy_account ; - Mask.Attached.set attached_mask dummy_location dummy_account ; - let maskable_result = Maskable.get maskable dummy_location in - let mask_result = Mask.Attached.get attached_mask dummy_location in - Option.is_some maskable_result - && Option.is_some mask_result - && - let maskable_account = Option.value_exn maskable_result in - let mask_account = Option.value_exn mask_result in - Account.equal maskable_account mask_account ) + let () = + add_test "parent, mask agree on set" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + Maskable.set maskable dummy_location dummy_account ; + Mask.Attached.set attached_mask dummy_location dummy_account ; + let maskable_result = Maskable.get maskable dummy_location in + let mask_result = Mask.Attached.get attached_mask dummy_location in + assert (Option.is_some maskable_result) ; + assert (Option.is_some mask_result) ; + let maskable_account = Option.value_exn maskable_result in + let mask_account = Option.value_exn mask_result in + [%test_eq: Account.t] maskable_account mask_account ) ) let compare_maskable_mask_hashes ?(check_hash_in_mask = false) maskable mask addr = @@ -156,477 +172,504 @@ module Make (Test : Test_intf) = struct in test_hashes_at_address addr - let%test "parent, mask agree on set" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - Maskable.set maskable dummy_location dummy_account ; - Mask.Attached.set attached_mask dummy_location dummy_account ; - let maskable_result = Maskable.get maskable dummy_location in - let mask_result = Mask.Attached.get attached_mask dummy_location in - Option.is_some maskable_result - && Option.is_some mask_result - && - let maskable_account = Option.value_exn maskable_result in - let mask_account = Option.value_exn mask_result in - Account.equal maskable_account mask_account ) - - let%test "parent, mask agree on hashes; set in both mask and parent" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - (* set in both parent and mask *) - Maskable.set maskable dummy_location dummy_account ; - Mask.Attached.set attached_mask dummy_location dummy_account ; - (* verify all hashes to root are same in mask and parent *) - compare_maskable_mask_hashes ~check_hash_in_mask:true maskable - attached_mask dummy_address ) - - let%test "parent, mask agree on hashes; set only in parent" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - (* set only in parent *) - Maskable.set maskable dummy_location dummy_account ; - (* verify all hashes to root are same in mask and parent *) - compare_maskable_mask_hashes maskable attached_mask dummy_address ) - - let%test "mask prune after parent notification" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - (* set to mask *) - Mask.Attached.set attached_mask dummy_location dummy_account ; - (* verify account is in mask *) - if - Mask.Attached.For_testing.location_in_mask attached_mask - dummy_location - then ( - Maskable.set maskable dummy_location dummy_account ; - (* verify account pruned from mask *) - not - (Mask.Attached.For_testing.location_in_mask attached_mask - dummy_location ) ) - else false ) - - let%test "commit puts mask contents in parent, flushes mask" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - (* set to mask *) - Mask.Attached.set attached_mask dummy_location dummy_account ; - (* verify account is in mask *) - if - Mask.Attached.For_testing.location_in_mask attached_mask - dummy_location - then ( - Mask.Attached.commit attached_mask ; - (* verify account no longer in mask but is in parent *) - (not - (Mask.Attached.For_testing.location_in_mask attached_mask - dummy_location ) ) - && Option.is_some (Maskable.get maskable dummy_location) ) - else false ) - - let%test_unit "commit at layer2, dumps to layer1, not in base" = - Test.with_chain (fun base ~mask:level1 ~mask_as_base:_ ~mask2:level2 -> - Mask.Attached.set level2 dummy_location dummy_account ; - (* verify account is in the layer2 mask *) - assert (Mask.Attached.For_testing.location_in_mask level2 dummy_location) ; - Mask.Attached.commit level2 ; - (* account is no longer in layer2 *) - assert ( - not (Mask.Attached.For_testing.location_in_mask level2 dummy_location) ) ; - (* account is still not in base *) - assert (Option.is_none @@ Maskable.get base dummy_location) ; - (* account is present in layer1 *) - assert (Mask.Attached.For_testing.location_in_mask level1 dummy_location) ) - - let%test "register and unregister mask" = - Test.with_instances (fun maskable mask -> - let (attached_mask : Mask.Attached.t) = - Maskable.register_mask maskable mask - in - try - let (_unattached_mask : Mask.t) = - Maskable.unregister_mask_exn ~loc:__LOC__ attached_mask - in - true - with Failure _ -> false ) - - let%test_unit "root hash invariant if interior changes but not accounts" = + let () = + add_test "parent, mask agree on hashes; set in both mask and parent" + (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + (* set in both parent and mask *) + Maskable.set maskable dummy_location dummy_account ; + Mask.Attached.set attached_mask dummy_location dummy_account ; + (* verify all hashes to root are same in mask and parent *) + assert ( + compare_maskable_mask_hashes ~check_hash_in_mask:true maskable + attached_mask dummy_address ) ) ) + + let () = + add_test "parent, mask agree on hashes; set only in parent" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + (* set only in parent *) + Maskable.set maskable dummy_location dummy_account ; + (* verify all hashes to root are same in mask and parent *) + assert ( + compare_maskable_mask_hashes maskable attached_mask dummy_address ) ) ) + + let () = + add_test "mask prune after parent notification" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + (* set to mask *) + Mask.Attached.set attached_mask dummy_location dummy_account ; + (* verify account is in mask *) + if + Mask.Attached.For_testing.location_in_mask attached_mask + dummy_location + then ( + Maskable.set maskable dummy_location dummy_account ; + (* verify account pruned from mask *) + assert ( + not + (Mask.Attached.For_testing.location_in_mask attached_mask + dummy_location ) ) ) + else assert false ) ) + + let () = + add_test "commit puts mask contents in parent, flushes mask" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + (* set to mask *) + Mask.Attached.set attached_mask dummy_location dummy_account ; + (* verify account is in mask *) + assert ( + Mask.Attached.For_testing.location_in_mask attached_mask + dummy_location ) ; + Mask.Attached.commit attached_mask ; + assert ( + (* verify account no longer in mask but is in parent *) + not + (Mask.Attached.For_testing.location_in_mask attached_mask + dummy_location ) ) ; + assert (Option.is_some (Maskable.get maskable dummy_location)) ) ) + + let () = + add_test "commit at layer2, dumps to layer1, not in base" (fun () -> + Test.with_chain (fun base ~mask:level1 ~mask_as_base:_ ~mask2:level2 -> + Mask.Attached.set level2 dummy_location dummy_account ; + (* verify account is in the layer2 mask *) + assert ( + Mask.Attached.For_testing.location_in_mask level2 dummy_location ) ; + Mask.Attached.commit level2 ; + (* account is no longer in layer2 *) + assert ( + not + (Mask.Attached.For_testing.location_in_mask level2 + dummy_location ) ) ; + (* account is still not in base *) + assert (Option.is_none @@ Maskable.get base dummy_location) ; + (* account is present in layer1 *) + assert ( + Mask.Attached.For_testing.location_in_mask level1 dummy_location ) ) ) + + let () = + add_test "register and unregister mask" (fun () -> + Test.with_instances (fun maskable mask -> + let (attached_mask : Mask.Attached.t) = + Maskable.register_mask maskable mask + in + let _m = Maskable.unregister_mask_exn ~loc:__LOC__ attached_mask in + () ) ) + + let () = if Test.depth <= 8 then - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let loc0 = - Test.Location.Addr.of_directions - (List.init Test.depth ~f:(fun _ -> Direction.Left)) - in - Mask.Attached.set attached_mask (Test.Location.Account loc0) - dummy_account ; - (* Make some accounts *) - let num_accounts = (1 lsl Test.depth) - 1 in - let gen_values gen = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts gen) - in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = gen_values Balance.gen in - let accounts = - List.map2_exn account_ids balances ~f:(fun public_key balance -> - Account.create public_key balance ) - in - List.iter accounts ~f:(fun account -> - ignore @@ create_new_account_exn attached_mask account ) ; - (* Set some inner hashes *) - let reset_hash_of_parent_of_index i = - let a1 = List.nth_exn accounts i in - let aid = Account.identifier a1 in - let location = - Mask.Attached.location_of_account attached_mask aid - |> Option.value_exn + add_test "root hash invariant if interior changes but not accounts" + (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let loc0 = + Test.Location.Addr.of_directions + (List.init Test.depth ~f:(fun _ -> Direction.Left)) + in + Mask.Attached.set attached_mask (Test.Location.Account loc0) + dummy_account ; + (* Make some accounts *) + let num_accounts = (1 lsl Test.depth) - 1 in + let gen_values gen = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts gen) + in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = gen_values Balance.gen in + let accounts = + List.map2_exn account_ids balances ~f:(fun public_key balance -> + Account.create public_key balance ) + in + List.iter accounts ~f:(fun account -> + ignore @@ create_new_account_exn attached_mask account ) ; + (* Set some inner hashes *) + let reset_hash_of_parent_of_index i = + let a1 = List.nth_exn accounts i in + let aid = Account.identifier a1 in + let location = + Mask.Attached.location_of_account attached_mask aid + |> Option.value_exn + in + let addr = Test.Location.to_path_exn location in + let parent_addr = + Test.Location.Addr.parent addr |> Or_error.ok_exn + in + Mask.Attached.set_inner_hash_at_addr_exn attached_mask + parent_addr Hash.empty_account + in + let root_hash = Mask.Attached.merkle_root attached_mask in + reset_hash_of_parent_of_index 0 ; + reset_hash_of_parent_of_index 3 ; + let root_hash' = Mask.Attached.merkle_root attached_mask in + assert (Hash.equal root_hash root_hash') ) ) + + let () = + add_test "mask and parent agree on Merkle path" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + Mask.Attached.set attached_mask dummy_location dummy_account ; + (* set affects hashes along the path P from location to the root, while the Merkle path for the location + contains the siblings of P elements; to observe a hash in the Merkle path changed by the set, choose an + address that is a sibling of an element in P; the Merkle path for that address will include a P element + *) + let address = + dummy_address |> Maskable.Addr.parent_exn |> Maskable.Addr.sibling in - let addr = Test.Location.to_path_exn location in - let parent_addr = - Test.Location.Addr.parent addr |> Or_error.ok_exn + let mask_merkle_path = + Mask.Attached.merkle_path_at_addr_exn attached_mask address in - Mask.Attached.set_inner_hash_at_addr_exn attached_mask parent_addr - Hash.empty_account - in - let root_hash = Mask.Attached.merkle_root attached_mask in - reset_hash_of_parent_of_index 0 ; - reset_hash_of_parent_of_index 3 ; - let root_hash' = Mask.Attached.merkle_root attached_mask in - assert (Hash.equal root_hash root_hash') ) - - let%test "mask and parent agree on Merkle path" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - Mask.Attached.set attached_mask dummy_location dummy_account ; - (* set affects hashes along the path P from location to the root, while the Merkle path for the location - contains the siblings of P elements; to observe a hash in the Merkle path changed by the set, choose an - address that is a sibling of an element in P; the Merkle path for that address will include a P element - *) - let address = - dummy_address |> Maskable.Addr.parent_exn |> Maskable.Addr.sibling - in - let mask_merkle_path = - Mask.Attached.merkle_path_at_addr_exn attached_mask address - in - Maskable.set maskable dummy_location dummy_account ; - let maskable_merkle_path = - Maskable.merkle_path_at_addr_exn maskable address - in - [%equal: Mask.Attached.Path.t] mask_merkle_path maskable_merkle_path ) - - let%test "mask and parent agree on Merkle root before set" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let mask_merkle_root = Mask.Attached.merkle_root attached_mask in - let maskable_merkle_root = Maskable.merkle_root maskable in - Hash.equal mask_merkle_root maskable_merkle_root ) - - let%test "mask and parent agree on Merkle root after set" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - (* the order of sets matters here; if we set in the mask first, - the set in the maskable notifies the mask, which then removes - the account, changing the Merkle root to what it was before the set - *) - Maskable.set maskable dummy_location dummy_account ; - Mask.Attached.set attached_mask dummy_location dummy_account ; - let mask_merkle_root = Mask.Attached.merkle_root attached_mask in - let maskable_merkle_root = Maskable.merkle_root maskable in - (* verify root address in mask *) - Mask.Attached.For_testing.address_in_mask attached_mask - (Mask.Addr.root ()) - && Hash.equal mask_merkle_root maskable_merkle_root ) - - let%test_unit "add and retrieve a block of accounts" = - (* see similar test in test_database *) + Maskable.set maskable dummy_location dummy_account ; + let maskable_merkle_path = + Maskable.merkle_path_at_addr_exn maskable address + in + assert ( + Mask.Attached.Path.equal mask_merkle_path maskable_merkle_path ) ) ) + + let () = + add_test "mask and parent agree on Merkle root before set" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let mask_merkle_root = Mask.Attached.merkle_root attached_mask in + let maskable_merkle_root = Maskable.merkle_root maskable in + [%test_eq: Hash.t] mask_merkle_root maskable_merkle_root ) ) + + let () = + add_test "mask and parent agree on Merkle root after set" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + (* the order of sets matters here; if we set in the mask first, + the set in the maskable notifies the mask, which then removes + the account, changing the Merkle root to what it was before the set + *) + Maskable.set maskable dummy_location dummy_account ; + Mask.Attached.set attached_mask dummy_location dummy_account ; + let mask_merkle_root = Mask.Attached.merkle_root attached_mask in + let maskable_merkle_root = Maskable.merkle_root maskable in + (* verify root address in mask *) + assert ( + Mask.Attached.For_testing.address_in_mask attached_mask + (Mask.Addr.root ()) + && Hash.equal mask_merkle_root maskable_merkle_root ) ) ) + + let () = if Test.depth <= 8 then - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let num_accounts = 1 lsl Test.depth in - let gen_values gen = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts gen) - in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = gen_values Balance.gen in - let accounts = - List.map2_exn account_ids balances ~f:(fun public_key balance -> - Account.create public_key balance ) - in - List.iter accounts ~f:(fun account -> - ignore @@ create_new_account_exn attached_mask account ) ; - let retrieved_accounts = - List.map ~f:snd - @@ Mask.Attached.get_all_accounts_rooted_at_exn attached_mask - (Mask.Addr.root ()) - in - assert (Stdlib.List.compare_lengths accounts retrieved_accounts = 0) ; - assert (List.equal Account.equal accounts retrieved_accounts) ) - - let%test_unit "get_all_accounts should preserve the ordering of accounts by \ - location with noncontiguous updates of accounts on the mask" = - (* see similar test in test_database *) + add_test "add and retrieve a block of accounts" (fun () -> + (* see similar test in test_database *) + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let num_accounts = 1 lsl Test.depth in + let gen_values gen = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts gen) + in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = gen_values Balance.gen in + let accounts = + List.map2_exn account_ids balances ~f:(fun public_key balance -> + Account.create public_key balance ) + in + List.iter accounts ~f:(fun account -> + ignore @@ create_new_account_exn attached_mask account ) ; + let retrieved_accounts = + List.map ~f:snd + @@ Mask.Attached.get_all_accounts_rooted_at_exn attached_mask + (Mask.Addr.root ()) + in + assert ( + Stdlib.List.compare_lengths accounts retrieved_accounts = 0 ) ; + assert (List.equal Account.equal accounts retrieved_accounts) ) ) + + let () = if Test.depth <= 8 then - Test.with_chain (fun _ ~mask:mask1 ~mask_as_base:_ ~mask2 -> - let num_accounts = 1 lsl Test.depth in - let gen_values gen list_length = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length list_length gen) - in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = gen_values Balance.gen num_accounts in - let base_accounts = - List.map2_exn account_ids balances ~f:(fun public_key balance -> - Account.create public_key balance ) - in - List.iter base_accounts ~f:(fun account -> - ignore @@ create_new_account_exn mask1 account ) ; - let num_subset = - Quickcheck.random_value (Int.gen_incl 3 num_accounts) - in - let subset_indices, subset_accounts = - List.permute - (List.mapi base_accounts ~f:(fun index account -> - (index, account) ) ) - |> (Fn.flip List.take) num_subset - |> List.unzip - in - let subset_balances = gen_values Balance.gen num_subset in - let subset_updated_accounts = - List.map2_exn subset_accounts subset_balances - ~f:(fun account balance -> - let updated_account = { account with balance } in - ignore - ( create_existing_account_exn mask2 updated_account - : Test.Location.t ) ; - updated_account ) - in - let updated_accounts_map = - Int.Map.of_alist_exn - (List.zip_exn subset_indices subset_updated_accounts) - in - let expected_accounts = - List.mapi base_accounts ~f:(fun index base_account -> - Option.value - (Map.find updated_accounts_map index) - ~default:base_account ) - in - let retrieved_accounts = - List.map ~f:snd - @@ Mask.Attached.get_all_accounts_rooted_at_exn mask2 - (Mask.Addr.root ()) - in - assert ( - Stdlib.List.compare_lengths base_accounts retrieved_accounts = 0 ) ; - assert (List.equal Account.equal expected_accounts retrieved_accounts) ) - - let%test_unit "fold of addition over account balances in parent and mask" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let num_accounts_parent = 5 in - let num_accounts_mask = 5 in - let num_accounts = num_accounts_parent + num_accounts_mask in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts Balance.gen) - in - let accounts = List.map2_exn account_ids balances ~f:Account.create in - let total = - List.fold balances ~init:0 ~f:(fun accum balance -> - Balance.to_nanomina_int balance + accum ) - in - let parent_accounts, mask_accounts = - List.split_n accounts num_accounts_parent - in - (* add accounts to parent *) - List.iter parent_accounts ~f:(fun account -> - ignore @@ parent_create_new_account_exn maskable account ) ; - (* add accounts to mask *) - List.iter mask_accounts ~f:(fun account -> - ignore @@ create_new_account_exn attached_mask account ) ; - (* folding over mask also folds over maskable *) - let retrieved_total = - Mask.Attached.foldi attached_mask ~init:0 - ~f:(fun _addr total account -> - Balance.to_nanomina_int (Account.balance account) + total ) - in - assert (Int.equal retrieved_total total) ) - - let%test_unit "masking in to_list" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let num_accounts = 10 in - let account_ids = Account_id.gen_accounts num_accounts in - (* parent balances all non-zero *) - let balances = - List.init num_accounts ~f:(fun n -> - Balance.of_nanomina_int_exn (n + 1) ) - in - let parent_accounts = - List.map2_exn account_ids balances ~f:Account.create - in - (* add accounts to parent *) - List.iter parent_accounts ~f:(fun account -> - ignore @@ parent_create_new_account_exn maskable account ) ; - (* all accounts in parent to_list *) - let parent_list = Maskable.to_list_sequential maskable in - let zero_balance account = - Account.update_balance account Balance.zero - in - (* put same accounts in mask, but with zero balance *) - let mask_accounts = List.map parent_accounts ~f:zero_balance in - List.iter mask_accounts ~f:(fun account -> - ignore @@ create_existing_account_exn attached_mask account ) ; - let mask_list = Mask.Attached.to_list_sequential attached_mask in - (* same number of accounts after adding them to mask *) - assert (Stdlib.List.compare_lengths parent_list mask_list = 0) ; - (* should only see the zero balances in mask list *) - let is_in_same_order = - List.for_all2_exn parent_list mask_list - ~f:(fun parent_account mask_account -> - Account_id.equal - (Account.identifier parent_account) - (Account.identifier mask_account) ) - in - assert is_in_same_order ; - assert ( - List.for_all mask_list ~f:(fun account -> - Balance.equal (Account.balance account) Balance.zero ) ) ) - - let%test_unit "masking in foldi" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let num_accounts = 10 in - let account_ids = Account_id.gen_accounts num_accounts in - (* parent balances all non-zero *) - let balances = - List.init num_accounts ~f:(fun n -> - Balance.of_nanomina_int_exn (n + 1) ) - in - let parent_accounts = - List.map2_exn account_ids balances ~f:Account.create - in - (* add accounts to parent *) - List.iter parent_accounts ~f:(fun account -> - ignore @@ parent_create_new_account_exn maskable account ) ; - let balance_summer _addr accum acct = - accum + Balance.to_nanomina_int (Account.balance acct) - in - let parent_sum = Maskable.foldi maskable ~init:0 ~f:balance_summer in - (* non-zero sum of parent account balances *) - assert (Int.equal parent_sum 55) (* HT Gauss *) ; - let zero_balance account = - Account.update_balance account Balance.zero - in - (* put same accounts in mask, but with zero balance *) - let mask_accounts = List.map parent_accounts ~f:zero_balance in - List.iter mask_accounts ~f:(fun account -> - ignore @@ create_existing_account_exn attached_mask account ) ; - let mask_sum = - Mask.Attached.foldi attached_mask ~init:0 ~f:balance_summer - in - (* sum should not include any parent balances *) - assert (Int.equal mask_sum 0) ) - - let%test_unit "create_empty doesn't modify the hash" = - Test.with_instances (fun maskable mask -> - let open Mask.Attached in - let ledger = Maskable.register_mask maskable mask in - let key = List.nth_exn (Account_id.gen_accounts 1) 0 in - let start_hash = merkle_root ledger in - match - get_or_create_account ledger key Account.empty |> Or_error.ok_exn - with - | `Existed, _ -> - failwith - "create_empty with empty ledger somehow already has that key?" - | `Added, _new_loc -> - [%test_eq: Hash.t] start_hash (merkle_root ledger) ) - - let%test_unit "num_accounts for unique keys in mask and parent" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let num_accounts = 5 in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts Balance.gen) - in - let accounts = List.map2_exn account_ids balances ~f:Account.create in - (* add accounts to mask *) - List.iter accounts ~f:(fun account -> - ignore @@ create_new_account_exn attached_mask account ) ; - let mask_num_accounts_before = - Mask.Attached.num_accounts attached_mask - in - (* add same accounts to parent *) - List.iter accounts ~f:(fun account -> - ignore @@ parent_create_new_account_exn maskable account ) ; - let parent_num_accounts = Maskable.num_accounts maskable in - (* should not change number of accounts in mask, since they have the same keys *) - let mask_num_accounts_after = - Mask.Attached.num_accounts attached_mask - in - (* the number of accounts in parent, mask should agree *) - assert ( - Mina_stdlib.List.Length.Compare.(accounts = parent_num_accounts) - && Int.equal parent_num_accounts mask_num_accounts_before - && Int.equal parent_num_accounts mask_num_accounts_after ) ) - - let%test_unit "Mask reparenting works" = - Test.with_chain (fun base ~mask:m1 ~mask_as_base ~mask2:m2 -> - let num_accounts = 3 in - let account_ids = Account_id.gen_accounts num_accounts in - let balances = - Quickcheck.random_value - (Quickcheck.Generator.list_with_length num_accounts Balance.gen) - in - let accounts = List.map2_exn account_ids balances ~f:Account.create in - match accounts with - | [ a1; a2; a3 ] -> - let loc1 = parent_create_new_account_exn base a1 in - let loc2 = create_new_account_exn m1 a2 in - let loc3 = create_new_account_exn m2 a3 in - let locs = [ (loc1, a1); (loc2, a2); (loc3, a3) ] in - (* all accounts are here *) - List.iter locs ~f:(fun (loc, a) -> - [%test_result: Account.t option] - ~message:"All accounts are accessible from m2" - ~expect:(Some a) (Mask.Attached.get m2 loc) ) ; - [%test_result: Account.t option] ~message:"a1 is in base" - ~expect:(Some a1) (Test.Base.get base loc1) ; - Mask.Attached.commit m1 ; - [%test_result: Account.t option] ~message:"a2 is in base" - ~expect:(Some a2) (Test.Base.get base loc2) ; - Maskable.remove_and_reparent_exn mask_as_base m1 ; - [%test_result: Account.t option] ~message:"a1 is in base" - ~expect:(Some a1) (Test.Base.get base loc1) ; - [%test_result: Account.t option] ~message:"a2 is in base" - ~expect:(Some a2) (Test.Base.get base loc2) ; - (* all accounts are still here *) - List.iter locs ~f:(fun (loc, a) -> - [%test_result: Account.t option] - ~message:"All accounts are accessible from m2" - ~expect:(Some a) (Mask.Attached.get m2 loc) ) - | _ -> - failwith "unexpected" ) - - let%test_unit "setting an account in the parent doesn't remove the masked \ - copy if the mask is still dirty for that account" = - Test.with_instances (fun maskable mask -> - let attached_mask = Maskable.register_mask maskable mask in - let k = Account_id.gen_accounts 1 |> List.hd_exn in - let acct1 = Account.create k (Balance.of_nanomina_int_exn 10) in - let loc = - Mask.Attached.get_or_create_account attached_mask k acct1 - |> Or_error.ok_exn |> snd - in - let acct2 = Account.create k (Balance.of_nanomina_int_exn 5) in - Maskable.set maskable loc acct2 ; - [%test_result: Account.t] ~message:"account in mask should be unchanged" - ~expect:acct1 - (Mask.Attached.get attached_mask loc |> Option.value_exn) ) + add_test + "get_all_accounts should preserve the ordering of accounts by location \ + with noncontiguous updates of accounts on the mask" (fun () -> + (* see similar test in test_database *) + Test.with_chain (fun _ ~mask:mask1 ~mask_as_base:_ ~mask2 -> + let num_accounts = 1 lsl Test.depth in + let gen_values gen list_length = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length list_length gen) + in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = gen_values Balance.gen num_accounts in + let base_accounts = + List.map2_exn account_ids balances ~f:Account.create + in + List.iter base_accounts ~f:(fun account -> + ignore @@ create_new_account_exn mask1 account ) ; + let num_subset = + Quickcheck.random_value (Int.gen_incl 3 num_accounts) + in + let subset_indices, subset_accounts = + List.permute + (List.mapi base_accounts ~f:(fun index account -> + (index, account) ) ) + |> (Fn.flip List.take) num_subset + |> List.unzip + in + let subset_balances = gen_values Balance.gen num_subset in + let subset_updated_accounts = + List.map2_exn subset_accounts subset_balances + ~f:(fun account balance -> + let updated_account = { account with balance } in + ignore + ( create_existing_account_exn mask2 updated_account + : Test.Location.t ) ; + updated_account ) + in + let updated_accounts_map = + Int.Map.of_alist_exn + (List.zip_exn subset_indices subset_updated_accounts) + in + let expected_accounts = + List.mapi base_accounts ~f:(fun index base_account -> + Option.value + (Map.find updated_accounts_map index) + ~default:base_account ) + in + let retrieved_accounts = + List.map ~f:snd + @@ Mask.Attached.get_all_accounts_rooted_at_exn mask2 + (Mask.Addr.root ()) + in + assert ( + Stdlib.List.compare_lengths base_accounts retrieved_accounts = 0 ) ; + assert ( + List.equal Account.equal expected_accounts retrieved_accounts ) ) ) + + let () = + add_test "fold of addition over account balances in parent and mask" + (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let num_accounts_parent = 5 in + let num_accounts_mask = 5 in + let num_accounts = num_accounts_parent + num_accounts_mask in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts Balance.gen) + in + let accounts = + List.map2_exn account_ids balances ~f:Account.create + in + let total = + List.fold balances ~init:0 ~f:(fun accum balance -> + Balance.to_nanomina_int balance + accum ) + in + let parent_accounts, mask_accounts = + List.split_n accounts num_accounts_parent + in + (* add accounts to parent *) + List.iter parent_accounts ~f:(fun account -> + ignore @@ parent_create_new_account_exn maskable account ) ; + (* add accounts to mask *) + List.iter mask_accounts ~f:(fun account -> + ignore @@ create_new_account_exn attached_mask account ) ; + (* folding over mask also folds over maskable *) + let retrieved_total = + Mask.Attached.foldi attached_mask ~init:0 + ~f:(fun _addr total account -> + Balance.to_nanomina_int (Account.balance account) + total ) + in + assert (Int.equal retrieved_total total) ) ) + + let () = + add_test "masking in to_list" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let num_accounts = 10 in + let account_ids = Account_id.gen_accounts num_accounts in + (* parent balances all non-zero *) + let balances = + List.init num_accounts ~f:(fun n -> + Balance.of_nanomina_int_exn (n + 1) ) + in + let parent_accounts = + List.map2_exn account_ids balances ~f:Account.create + in + (* add accounts to parent *) + List.iter parent_accounts ~f:(fun account -> + ignore @@ parent_create_new_account_exn maskable account ) ; + (* all accounts in parent to_list *) + let parent_list = Maskable.to_list_sequential maskable in + let zero_balance account = + Account.update_balance account Balance.zero + in + (* put same accounts in mask, but with zero balance *) + let mask_accounts = List.map parent_accounts ~f:zero_balance in + List.iter mask_accounts ~f:(fun account -> + ignore @@ create_existing_account_exn attached_mask account ) ; + let mask_list = Mask.Attached.to_list_sequential attached_mask in + (* same number of accounts after adding them to mask *) + assert (Stdlib.List.compare_lengths parent_list mask_list = 0) ; + (* should only see the zero balances in mask list *) + let is_in_same_order = + List.for_all2_exn parent_list mask_list + ~f:(fun parent_account mask_account -> + Account_id.equal + (Account.identifier parent_account) + (Account.identifier mask_account) ) + in + assert is_in_same_order ; + assert ( + List.for_all mask_list ~f:(fun account -> + Balance.equal (Account.balance account) Balance.zero ) ) ) ) + + let () = + add_test "masking in foldi" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let num_accounts = 10 in + let account_ids = Account_id.gen_accounts num_accounts in + (* parent balances all non-zero *) + let balances = + List.init num_accounts ~f:(fun n -> + Balance.of_nanomina_int_exn (n + 1) ) + in + let parent_accounts = + List.map2_exn account_ids balances ~f:Account.create + in + (* add accounts to parent *) + List.iter parent_accounts ~f:(fun account -> + ignore @@ parent_create_new_account_exn maskable account ) ; + let balance_summer _addr accum acct = + accum + Balance.to_nanomina_int (Account.balance acct) + in + let parent_sum = + Maskable.foldi maskable ~init:0 ~f:balance_summer + in + (* non-zero sum of parent account balances *) + assert (Int.equal parent_sum 55) (* HT Gauss *) ; + let zero_balance account = + Account.update_balance account Balance.zero + in + (* put same accounts in mask, but with zero balance *) + let mask_accounts = List.map parent_accounts ~f:zero_balance in + List.iter mask_accounts ~f:(fun account -> + ignore @@ create_existing_account_exn attached_mask account ) ; + let mask_sum = + Mask.Attached.foldi attached_mask ~init:0 ~f:balance_summer + in + (* sum should not include any parent balances *) + assert (Int.equal mask_sum 0) ) ) + + let () = + add_test "create_empty doesn't modify the hash" (fun () -> + Test.with_instances (fun maskable mask -> + let open Mask.Attached in + let ledger = Maskable.register_mask maskable mask in + let key = List.nth_exn (Account_id.gen_accounts 1) 0 in + let start_hash = merkle_root ledger in + match + get_or_create_account ledger key Account.empty |> Or_error.ok_exn + with + | `Existed, _ -> + failwith + "create_empty with empty ledger somehow already has that key?" + | `Added, _new_loc -> + [%test_eq: Hash.t] start_hash (merkle_root ledger) ) ) + + let () = + add_test "num_accounts for unique keys in mask and parent" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let num_accounts = 5 in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts Balance.gen) + in + let accounts = + List.map2_exn account_ids balances ~f:Account.create + in + (* add accounts to mask *) + List.iter accounts ~f:(fun account -> + ignore @@ create_new_account_exn attached_mask account ) ; + let mask_num_accounts_before = + Mask.Attached.num_accounts attached_mask + in + (* add same accounts to parent *) + List.iter accounts ~f:(fun account -> + ignore @@ parent_create_new_account_exn maskable account ) ; + let parent_num_accounts = Maskable.num_accounts maskable in + (* should not change number of accounts in mask, since they have the same keys *) + let mask_num_accounts_after = + Mask.Attached.num_accounts attached_mask + in + (* the number of accounts in parent, mask should agree *) + assert ( + Mina_stdlib.List.Length.Compare.(accounts = parent_num_accounts) + && Int.equal parent_num_accounts mask_num_accounts_before + && Int.equal parent_num_accounts mask_num_accounts_after ) ) ) + + let () = + add_test "mask reparenting works" (fun () -> + Test.with_chain (fun base ~mask:m1 ~mask_as_base ~mask2:m2 -> + let num_accounts = 3 in + let account_ids = Account_id.gen_accounts num_accounts in + let balances = + Quickcheck.random_value + (Quickcheck.Generator.list_with_length num_accounts Balance.gen) + in + let accounts = + List.map2_exn account_ids balances ~f:Account.create + in + match accounts with + | [ a1; a2; a3 ] -> + let loc1 = parent_create_new_account_exn base a1 in + let loc2 = create_new_account_exn m1 a2 in + let loc3 = create_new_account_exn m2 a3 in + let locs = [ (loc1, a1); (loc2, a2); (loc3, a3) ] in + (* all accounts are here *) + List.iter locs ~f:(fun (loc, a) -> + [%test_result: Account.t option] + ~message:"All accounts are accessible from m2" + ~expect:(Some a) (Mask.Attached.get m2 loc) ) ; + [%test_result: Account.t option] ~message:"a1 is in base" + ~expect:(Some a1) (Test.Base.get base loc1) ; + Mask.Attached.commit m1 ; + [%test_result: Account.t option] ~message:"a2 is in base" + ~expect:(Some a2) (Test.Base.get base loc2) ; + Maskable.remove_and_reparent_exn mask_as_base m1 ; + [%test_result: Account.t option] ~message:"a1 is in base" + ~expect:(Some a1) (Test.Base.get base loc1) ; + [%test_result: Account.t option] ~message:"a2 is in base" + ~expect:(Some a2) (Test.Base.get base loc2) ; + (* all accounts are still here *) + List.iter locs ~f:(fun (loc, a) -> + [%test_result: Account.t option] + ~message:"All accounts are accessible from m2" + ~expect:(Some a) (Mask.Attached.get m2 loc) ) + | _ -> + failwith "unexpected" ) ) + + let () = + add_test + "setting account in parent doesn't remove masked copy if mask is still \ + dirty for said account" (fun () -> + Test.with_instances (fun maskable mask -> + let attached_mask = Maskable.register_mask maskable mask in + let k = Account_id.gen_accounts 1 |> List.hd_exn in + let acct1 = Account.create k (Balance.of_nanomina_int_exn 10) in + let loc = + Mask.Attached.get_or_create_account attached_mask k acct1 + |> Or_error.ok_exn |> snd + in + let acct2 = Account.create k (Balance.of_nanomina_int_exn 5) in + Maskable.set maskable loc acct2 ; + [%test_result: Account.t] + ~message:"account in mask should be unchanged" ~expect:acct1 + (Mask.Attached.get attached_mask loc |> Option.value_exn) ) ) + + let tests = + let actual_tests = Stack.fold test_stack ~init:[] ~f:(fun l e -> e :: l) in + (test_section_name, actual_tests) end module type Depth_S = sig @@ -753,17 +796,16 @@ end module Make_maskable_and_mask (Depth : Depth_S) = Make (Make_maskable_and_mask_with_depth (Depth)) -let%test_module "Test mask connected to underlying Merkle tree" = - ( module struct - module Depth_4 = struct - let depth = 4 - end +module Depth_4 = struct + let depth = 4 +end - module Mdb_d4 = Make_maskable_and_mask (Depth_4) +module Mdb_d4 = Make_maskable_and_mask (Depth_4) - module Depth_30 = struct - let depth = 30 - end +module Depth_30 = struct + let depth = 30 +end + +module Mdb_d30 = Make_maskable_and_mask (Depth_30) - module Mdb_d30 = Make_maskable_and_mask (Depth_30) - end ) +let tests = [ Mdb_d4.tests; Mdb_d30.tests ] diff --git a/src/lib/merkle_ledger_tests/test_stubs.ml b/src/lib/merkle_ledger_tests/test_stubs.ml index 61d26b19d0a..00592d56d59 100644 --- a/src/lib/merkle_ledger_tests/test_stubs.ml +++ b/src/lib/merkle_ledger_tests/test_stubs.ml @@ -59,12 +59,12 @@ module Hash = struct * important impossible to create an account such that (merge a b = hash_account account) *) let hash_account account = - Md5.digest_string ("0" ^ Format.sprintf !"%{sexp: Account.t}" account) + Md5.digest_string (Format.sprintf !"0%{sexp: Account.t}" account) let merge ~height a b = let res = Md5.digest_string - (sprintf "test_ledger_%d:" height ^ Md5.to_hex a ^ Md5.to_hex b) + (sprintf "test_ledger_%d:%s%s" height (Md5.to_hex a) (Md5.to_hex b)) in res diff --git a/src/lib/mina_net2/multiaddr.ml b/src/lib/mina_net2/multiaddr.ml index 8efeff34fc1..ed5710fe635 100644 --- a/src/lib/mina_net2/multiaddr.ml +++ b/src/lib/mina_net2/multiaddr.ml @@ -39,6 +39,7 @@ let valid_as_peer t = let of_file_contents contents : t list = String.split ~on:'\n' contents + |> List.map ~f:String.strip |> List.filter ~f:(fun s -> if valid_as_peer s then true else if String.is_empty s then false