diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index acdb6ff143469b4e1cb736221c110b3b1de43b84..c24a6fba3a623ba34c7960cf75c030297cb932f4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -15,8 +15,8 @@ include: - .gitlab/ci/test-doc-scripts.yml variables: - ## Please update `scripts/version.sh` accordingly - build_deps_image_version: ecb12b00769179e6022ad1547b69950781a45061 + ## This value MUST be the same as `opam_repository_tag` in `scripts/version.sh` + build_deps_image_version: 17ecd6f7b4585fdc38b28542523abd9b9b53fde0 build_deps_image_name: registry.gitlab.com/tezos/opam-repository public_docker_image_name: docker.io/${CI_PROJECT_PATH} GIT_STRATEGY: fetch diff --git a/.gitlab/ci/opam.yml b/.gitlab/ci/opam.yml index 3005a5f5850c5459eb8594d872ff564c8373e8b0..50d2f378a51c8372d64a31ddcd47c93d36e27dd3 100644 --- a/.gitlab/ci/opam.yml +++ b/.gitlab/ci/opam.yml @@ -61,6 +61,11 @@ opam:ledgerwallet-tezos: variables: package: ledgerwallet-tezos +opam:lib-test: + extends: .opam_template + variables: + package: lib-test + opam:numerics: extends: .opam_template variables: diff --git a/docs/developer/testing.rst b/docs/developer/testing.rst index cbe09a7ad9dc1ebc78107eca9df6be6c28c46c1a..5ed41d9bd5304f11ed1220c9f048ec0a9c24a7f0 100644 --- a/docs/developer/testing.rst +++ b/docs/developer/testing.rst @@ -84,13 +84,13 @@ in more detail. .. csv-table:: Testing frameworks and their applications in Tezos. PT: - :ref:`Python testing and execution framework `, AT: :ref:`alcotest_section`, CB: :ref:`crowbar_test`, FT: :ref:`flextesa_section`, TZ: :ref:`tezt_section` + :ref:`Python testing and execution framework `, AT: :ref:`alcotest_section`, PBT: :ref:`property_based_test`, FT: :ref:`flextesa_section`, TZ: :ref:`tezt_section` :header: "Component","Unit","Property","Integration","System","Regression" - "Node",":ref:`AT `",":ref:`CB `",":ref:`AT `",":ref:`PT `, :ref:`FT `, :ref:`TZ `" - "-- Protocol",":ref:`AT `","","" + "Node",":ref:`AT `",":ref:`PBT `",":ref:`AT `",":ref:`PT `, :ref:`FT `, :ref:`TZ `" + "-- Protocol",":ref:`AT `",":ref:`PBT `","" "-- -- Michelson interpreter",":ref:`AT `","","",":ref:`PT `",":ref:`PT `" - "Client","","","",":ref:`PT `, :ref:`FT `, :ref:`TZ `" + "Client","",":ref:`PBT `","",":ref:`PT `, :ref:`FT `, :ref:`TZ `" "Networked nodes","--","",":ref:`PT `, :ref:`FT `","", "" "Endorser","","","",":ref:`FT `" "Baker","","","",":ref:`FT `" @@ -132,13 +132,29 @@ Example tests: References: - `Alcotest README `_. -.. _crowbar_test: +.. _property_based_test: + +QCheck +~~~~~~~ +`QCheck `_ is a library for +property-based testing in OCaml. + +Typical use cases: + - Verifying input-output invariants for functions with + randomized inputs. + +Example test: + - QCheck is used in :src:`src/lib_base/test/test_time.ml` to test the :src:`Tezos_base.Time` module. For instance, subtracting and then adding a random amount of seconds to a random time should give back the original time: this tests that ``add`` and ``diff`` are consistent (and the inverse of each other). To run this test, you need to run ``dune exec src/lib_base/test/test_time.exe``. + +References: + - `QCheck README `_ + - `QCheck module documentation `_ Crowbar ~~~~~~~ `Crowbar `_ is a library for -property-based testing in OCaml. It also interfaces with `afl +property-based testing and fuzzing in OCaml. It also interfaces with `afl `_ to enable fuzzing. Typical use cases: diff --git a/scripts/version.sh b/scripts/version.sh index 3c8622b25539c12c634c10437f7bf3173374928c..3ef4724c08be6467fec241f5b1eaeb948a4ecdda 100755 --- a/scripts/version.sh +++ b/scripts/version.sh @@ -7,13 +7,13 @@ ocaml_version=4.10.2 opam_version=2.0 recommended_rust_version=1.44.0 -## Please update `.gitlab-ci.yml` accordingly ## full_opam_repository is a commit hash of the public OPAM repository, i.e. ## https://github.com/ocaml/opam-repository -full_opam_repository_tag=eb6f20daffff6dc5c67b4b55b87bf6b0e600c4d7 +full_opam_repository_tag=b1124400e2d4f93a8becf1315a8e8d205fe0082e ## opam_repository is an additional, tezos-specific opam repository. -opam_repository_tag=ecb12b00769179e6022ad1547b69950781a45061 +## This value MUST be the same as `build_deps_image_version` in `.gitlab-ci.yml +opam_repository_tag=17ecd6f7b4585fdc38b28542523abd9b9b53fde0 opam_repository_url=https://gitlab.com/tezos/opam-repository.git opam_repository=$opam_repository_url\#$opam_repository_tag diff --git a/src/lib_base/test/dune b/src/lib_base/test/dune index 30d4c9628db6101eb4b46e4eb8e34258a60ed5bd..dd903e2890b12ea916577fc424291552bcd53c50 100644 --- a/src/lib_base/test/dune +++ b/src/lib_base/test/dune @@ -7,6 +7,8 @@ tezos-base data-encoding crowbar + qcheck-alcotest + lib-test ) (flags (:standard -open Tezos_base diff --git a/src/lib_base/test/test_time.ml b/src/lib_base/test/test_time.ml index 78c381b6e18f648e1f29ddff8e0c8156155a8ce8..ac306163510a78217d7f0e2b68809ebcfb80d32b 100644 --- a/src/lib_base/test/test_time.ml +++ b/src/lib_base/test/test_time.ml @@ -23,214 +23,232 @@ (* *) (*****************************************************************************) +(* Testing + ------- + Component: Base + Invocation: dune exec src/lib_base/test/test_time.exe + Subject: Check that the Protocol and System times behave correctly + regarding addition and encoding (binary and JSON) +*) + open Time +open Lib_test.Qcheck_helpers module Protocol = struct - open Protocol + include Protocol + + let max_rfc3339_seconds = to_seconds max_rfc3339 + + let min_rfc3339_seconds = to_seconds min_rfc3339 + + let t_arb = QCheck.map ~rev:to_seconds of_seconds QCheck.int64 - let t = Crowbar.map [Crowbar.int64] of_seconds + let rfc3339_compatible_t_arb = + let within_rfc3339 = + QCheck.map + ~rev:to_seconds + of_seconds + (int64_range min_rfc3339_seconds max_rfc3339_seconds) + in + QCheck.frequency + [ (97, within_rfc3339); + (1, QCheck.always max_rfc3339); + (1, QCheck.always min_rfc3339); + (1, QCheck.always epoch) ] let pp fmt t = Format.fprintf fmt "%Lx" (to_seconds t) - let () = - Crowbar.add_test - (* Property: - forall [t]: [Protocol.t], forall [delta]: [int64]: - [(t + delta) - t = delta] *) - ~name:"Base.Time.Protocol.add-diff" - [t; Crowbar.int64] - (fun some_time delta -> + let add_diff_roundtrip = + QCheck.Test.make + ~name:"Protocol.[add|diff] roundtrip" + (QCheck.pair t_arb QCheck.int64) + (fun (some_time, delta) -> let other_time = add some_time delta in - let same_delta = diff other_time some_time in - Crowbar.check_eq + let actual = diff other_time some_time in + qcheck_eq' ~pp:(fun fmt i64 -> Format.fprintf fmt "%Lx" i64) ~eq:Int64.equal - delta - same_delta) - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [Protocol.t], forall [tb]: [Protocol.t]: - [(tb - ta) + ta = tb] *) - ~name:"Base.Time.Protocol.diff-add" - [t; t] - (fun some_time other_time -> + ~expected:delta + ~actual + ()) + + let diff_add_roundtrip = + QCheck.Test.make + ~name:"Protocol.[diff|add] roundtrip" + (QCheck.pair t_arb t_arb) + (fun (some_time, other_time) -> let delta = diff other_time some_time in - let same_other_time = add some_time delta in - Crowbar.check_eq ~pp ~eq:equal other_time same_other_time) - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [Protocol.encoding] roundtrips in binary *) - ~name:"Base.Time.Protocol.encoding-binary" - [t] + let actual = add some_time delta in + qcheck_eq' ~pp ~eq:equal ~expected:other_time ~actual ()) + + let encoding_binary_roundtrip = + QCheck.Test.make + ~name:"Protocol.encoding roundtrips in binary" + t_arb (fun t -> let b = Data_encoding.Binary.to_bytes_exn encoding t in - let tt = Data_encoding.Binary.of_bytes_exn encoding b in - Crowbar.check_eq ~pp ~eq:equal t tt) - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [Protocol.encoding] roundtrips in json *) - ~name:"Base.Time.Protocol.encoding-json" - [t] + let actual = Data_encoding.Binary.of_bytes_exn encoding b in + qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) + + let encoding_json_roundtrip = + QCheck.Test.make + ~name:"Protocol.encoding roundtrips in JSON" + t_arb (fun t -> let j = Data_encoding.Json.construct encoding t in - let tt = Data_encoding.Json.destruct encoding j in - Crowbar.check_eq ~pp ~eq:equal t tt) - - let () = - Crowbar.add_test - ~name:"Base.Time.Protocol.to_notation roundtrip" - [Crowbar.range 1000] - (fun i -> - let close_to_epoch = add epoch (Int64.neg @@ Int64.of_int i) in - let s = to_notation close_to_epoch in - match of_notation s with + let actual = Data_encoding.Json.destruct encoding j in + qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) + + let encoding_to_notation_roundtrip = + QCheck.Test.make + ~name:"Protocol.[to|of]_notation roundtrip in RFC3339 range" + rfc3339_compatible_t_arb + (fun t -> + to_notation t |> of_notation + |> function | None -> - Crowbar.fail "Failed to roundtrip notation" - | Some after_roundtrip -> - Crowbar.check_eq ~pp ~eq:equal close_to_epoch after_roundtrip) + QCheck.Test.fail_report "Failed to roundtrip notation" + | Some actual -> + qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) + + let tests = + [ add_diff_roundtrip; + diff_add_roundtrip; + encoding_binary_roundtrip; + encoding_json_roundtrip; + encoding_to_notation_roundtrip ] end module System = struct open System - let t_ymdhms = - let open Crowbar in - map - [ range 10000; - range ~min:01 12; - range ~min:01 31; - range 24; - range 60; - range 60 ] - (fun year month day hour minute second -> - match - Ptime.of_date_time ((year, month, day), ((hour, minute, second), 0)) - with - | None -> - (* when the day of the month overflows for the month *) - bad_test () - | Some p -> - p) - - let min_day = Ptime.min |> Ptime.to_span |> Ptime.Span.to_d_ps |> fst - - let max_day = Ptime.max |> Ptime.to_span |> Ptime.Span.to_d_ps |> fst - - let day_range = max_day - min_day - - let t_dps = - let open Crowbar in - (* to avoid generating lots of out-of-range ps, we assume we're on a 64-bit - machine and we clip the range to acceptable ps inputs *) - map - [range (day_range + 2); range 86_400_000_000_000_000] - (fun d ps -> - let d = d + min_day - 1 in - let ps = Int64.of_int ps in - match Ptime.Span.of_d_ps (d, ps) with - | None -> - assert false - | Some span -> ( - match Ptime.of_span span with - | None -> - bad_test () (* range issue *) - | Some p -> - p )) - - let t = - let open Crowbar in - choose [t_ymdhms; t_dps] - - let () = - Crowbar.add_test - (* Property: - forall [t]: [System.t], - [of_protocol_opt (to_protocol t)] is [Some _] *) - ~name:"Base.Time.System.to-protocol" - [t] + (** Arbitrary of {!t} from usual time fragments year-month-day hour-minute-second, parsed through {!Ptime.of_date_time}. *) + let t_ymdhms_arb : t QCheck.arbitrary = + let open QCheck in + let rev t = + Option.get t |> Ptime.to_date_time + |> fun (date, (time, _)) -> (date, time) + in + of_option_arb + ( pair + (triple (0 -- 9999) (1 -- 12) (1 -- 31)) + (triple (0 -- 23) (0 -- 59) (0 -- 60)) + |> map ~rev (fun (date, time) -> Ptime.of_date_time (date, (time, 0))) ) + |> set_print (Format.asprintf "%a" pp_hum) + + let (min_day, min_ps) = Ptime.min |> Ptime.to_span |> Ptime.Span.to_d_ps + + let (max_day, max_ps) = Ptime.max |> Ptime.to_span |> Ptime.Span.to_d_ps + + (** Arbitrary of {!t} from days + picoseconds, parsed through {!Ptime.Span.of_d_ps}. *) + let t_dps_arb : t QCheck.arbitrary = + let open QCheck in + let rev t = Ptime.to_span t |> Ptime.Span.to_d_ps in + pair (min_day -- max_day) (int64_range min_ps max_ps) + |> map ~rev (fun (d, ps) -> + Ptime.Span.of_d_ps (d, ps) + |> Option.get |> Ptime.of_span |> Option.get) + (* But please keep using a nice pretty printer... We can probably write in the future a generic function that mixes features of [map ~rev] and [map_keep_input ~print] to only pass the monotonic transformation and the pretty printer, instead of manually writing [rev]. *) + |> set_print (Format.asprintf "%a" pp_hum) + + let t_arb = QCheck.choose [t_ymdhms_arb; t_dps_arb] + + (** Check that the span is smaller than 1 second (useful for Protocol time roundtrips as Protocol time precision is the second). *) + let is_small delta = + Stdlib.( < ) + (Ptime.Span.compare delta (Ptime.Span.v (0, 1_000_000_000_000L))) + 0 + + let to_protocol_of_protocol_roundtrip = + QCheck.Test.make + ~name:"System.[to|of]_protocol roundtrip modulo option" + t_arb (fun t -> - let protocol_time = to_protocol t in - match of_protocol_opt protocol_time with + match to_protocol t |> of_protocol_opt with | None -> - Crowbar.check false - | Some _ -> - Crowbar.check true) - - let () = - Crowbar.add_test - (* Property: - forall [t]: [Protocol.t], - [to_protocol]/[of_protocol_opt] roundtrip modulo option. *) - ~name:"Base.Time.System.to-protocol-of-protocol" - [Protocol.t] + QCheck.Test.fail_report "Failed roundtrip" + | Some actual -> + let delta = Ptime.Span.abs @@ Ptime.diff t actual in + is_small delta) + + (** Since Protocol time domain is (vastly) bigger than System time domain, + converting a Protocol time to a System time: + - either succeeds, in which case we can roundtrip back to the original + Protocol time + - or the Protocol time must be out of the System time range (i.e. out + of the RFC3339 time range) + *) + let of_protocol_to_protocol_roundtrip_or_outside_rfc3339 = + QCheck.Test.make + ~name:"System.[of|to]_protocol roundtrip or outside RFC3339 range" + (* Use both generators, otherwise statistically, we will almost + never hit the RFC3339 time range. *) + (QCheck.choose [Protocol.t_arb; Protocol.rfc3339_compatible_t_arb]) (fun protocol_time -> match of_protocol_opt protocol_time with | None -> - Crowbar.check true + Protocol.( + protocol_time < min_rfc3339 || max_rfc3339 < protocol_time) | Some system_time -> - let same_protocol_time = to_protocol system_time in - Crowbar.check_eq - ~pp:Time.Protocol.pp_hum + let actual = to_protocol system_time in + qcheck_eq' + ~pp:Time.Protocol.pp ~eq:Time.Protocol.equal - protocol_time - same_protocol_time) - - let is_small delta = - Stdlib.( < ) - (Ptime.Span.compare delta (Ptime.Span.v (0, 1_000_000_000_000L))) - 0 - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [System.rfc_encoding] roundtrips in binary modulo precision *) - ~name:"Base.Time.Protocol.rfc-encoding-binary" - [t] + ~expected:protocol_time + ~actual + ()) + + let rfc_encoding_binary_roundtrip = + QCheck.Test.make + ~name:"System.rfc_encoding roundtrips in binary modulo precision" + t_arb (fun t -> let b = Data_encoding.Binary.to_bytes_exn rfc_encoding t in let tt = Data_encoding.Binary.of_bytes_exn rfc_encoding b in let delta = Ptime.Span.abs @@ Ptime.diff t tt in - Crowbar.check @@ is_small delta) - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [System.rfc_encoding] roundtrips in json modulo precision *) - ~name:"Base.Time.Protocol.rfc-encoding-json" - [t] + is_small delta) + + let rfc_encoding_json_roundtrip = + QCheck.Test.make + ~name:"System.rfc_encoding roundtrips in JSON modulo precision" + t_arb (fun t -> let j = Data_encoding.Json.construct rfc_encoding t in let tt = Data_encoding.Json.destruct rfc_encoding j in let delta = Ptime.Span.abs @@ Ptime.diff t tt in - Crowbar.check @@ is_small delta) - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [System.encoding] roundtrips in binary modulo precision *) - ~name:"Base.Time.Protocol.encoding-binary" - [t] + is_small delta) + + let encoding_binary_roundtrip = + QCheck.Test.make + ~name:"System.encoding roundtrips in binary modulo precision" + t_arb (fun t -> let b = Data_encoding.Binary.to_bytes_exn encoding t in let tt = Data_encoding.Binary.of_bytes_exn encoding b in let delta = Ptime.Span.abs @@ Ptime.diff t tt in - Crowbar.check @@ is_small delta) - - let () = - Crowbar.add_test - (* Property: - forall [ta]: [System.encoding] roundtrips in json modulo precision *) - ~name:"Base.Time.Protocol.encoding-json" - [t] + is_small delta) + + let encoding_json_roundtrip = + QCheck.Test.make + ~name:"System.encoding roundtrips in JSON modulo precision" + t_arb (fun t -> let j = Data_encoding.Json.construct encoding t in let tt = Data_encoding.Json.destruct encoding j in let delta = Ptime.Span.abs @@ Ptime.diff t tt in - Crowbar.check @@ is_small delta) + is_small delta) + + let tests = + [ to_protocol_of_protocol_roundtrip; + of_protocol_to_protocol_roundtrip_or_outside_rfc3339; + rfc_encoding_binary_roundtrip; + rfc_encoding_json_roundtrip; + encoding_binary_roundtrip; + encoding_json_roundtrip ] end + +let () = + Alcotest.run + "Time" + [ ("Protocol", qcheck_wrap Protocol.tests); + ("System", qcheck_wrap System.tests) ] diff --git a/src/lib_base/tezos-base.opam b/src/lib_base/tezos-base.opam index d147edffde1ad0e23dae23ffe6b9651a35ceeae2..cf4fab939fc7f8cf2436e66871bdc6673239cefc 100644 --- a/src/lib_base/tezos-base.opam +++ b/src/lib_base/tezos-base.opam @@ -19,6 +19,8 @@ depends: [ "ezjsonm" { >= "0.5.0" } "ipaddr" {>= "5.0.0" & < "6.0.0"} "crowbar" { with-test } + "lib-test" { with-test } + "qcheck-alcotest" { with-test } ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_base/time.mli b/src/lib_base/time.mli index cd3c08da362ed5c6503c16a3096da265ad56ded2..209929bee46f79e429b1e8f0f0a1462e0a0a8632 100644 --- a/src/lib_base/time.mli +++ b/src/lib_base/time.mli @@ -65,9 +65,15 @@ module Protocol : sig (** The type of protocol times *) type t - (** Unix epoch is 1970-01-01 00:00:00 +0000 (UTC) *) + (** Unix epoch is 1970-01-01 00:00:00 +0000 (UTC). *) val epoch : t + (** The first instant supported by RFC 3339, corresponds to 0000-01-01 00:00:00 +0000 (UTC). *) + val min_rfc3339 : t + + (** The last instant supported by RFC 3339, corresponds to 9999-12-31 23:59:59 +0000 (UTC). *) + val max_rfc3339 : t + include Compare.S with type t := t (** [add t s] is [s] seconds later than [t] *) diff --git a/src/lib_test/.ocamlformat b/src/lib_test/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_test/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_test/dune b/src/lib_test/dune new file mode 100644 index 0000000000000000000000000000000000000000..c8736d554d1c4c77030af19047141cf6237fac51 --- /dev/null +++ b/src/lib_test/dune @@ -0,0 +1,6 @@ +(library + (name lib_test) + (public_name lib-test) + (libraries qcheck-alcotest alcotest alcotest-lwt) + (flags + (:standard -linkall))) diff --git a/src/lib_test/dune-project b/src/lib_test/dune-project new file mode 100644 index 0000000000000000000000000000000000000000..7db0abf93f66bc8acb968808b14c520e999300d5 --- /dev/null +++ b/src/lib_test/dune-project @@ -0,0 +1,3 @@ +(lang dune 2.0) +(formatting (enabled_for ocaml)) +(name lib-test) diff --git a/src/lib_test/lib-test.opam b/src/lib_test/lib-test.opam new file mode 100644 index 0000000000000000000000000000000000000000..5b19076e98b7cb4398f9e3b2353e6a5788005f1f --- /dev/null +++ b/src/lib_test/lib-test.opam @@ -0,0 +1,18 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "qcheck-alcotest" + "alcotest" + "alcotest-lwt" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] { with-test } +] +synopsis: "Tezos-agnostic test helpers" diff --git a/src/lib_test/qcheck_helpers.ml b/src/lib_test/qcheck_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..7e68d29cf86c620f51bd25a081e7481c0418a9fa --- /dev/null +++ b/src/lib_test/qcheck_helpers.ml @@ -0,0 +1,84 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +let qcheck_wrap = List.map QCheck_alcotest.to_alcotest + +let qcheck_eq ?pp ?cmp ?eq expected actual = + let pass = + match (eq, cmp) with + | (Some eq, _) -> + eq expected actual + | (None, Some cmp) -> + cmp expected actual = 0 + | (None, None) -> + Stdlib.compare expected actual = 0 + in + if pass then true + else + match pp with + | None -> + QCheck.Test.fail_reportf + "@[Values are not equal, but no pretty printer was provided.@]" + | Some pp -> + QCheck.Test.fail_reportf + "@[Equality check failed!@,expected:@,%a@,actual:@,%a@]" + pp + expected + pp + actual + +let qcheck_eq' ?pp ?cmp ?eq ~expected ~actual () = + qcheck_eq ?pp ?cmp ?eq expected actual + +let int64_range a b = + let int64_range_gen st = + let range = Int64.sub b a in + let raw_val = Random.State.int64 st range in + let res = Int64.add a raw_val in + assert (a <= res && res <= b) ; + res + in + QCheck.int64 |> QCheck.set_gen int64_range_gen + +let rec of_option_gen gen random = + match gen random with None -> of_option_gen gen random | Some a -> a + +let of_option_arb QCheck.{gen; print; small; shrink; collect; stats} = + let gen = of_option_gen gen in + let print = Option.map (fun print_opt a -> print_opt (Some a)) print in + let small = Option.map (fun small_opt a -> small_opt (Some a)) small in + (* Only shrink if the optional value is non-empty. *) + let shrink = + Option.map + (fun shrink_opt a f -> shrink_opt (Some a) (Option.iter f)) + shrink + in + let collect = + Option.map (fun collect_opt a -> collect_opt (Some a)) collect + in + let stats = + List.map (fun (s, f_opt) -> (s, fun a -> f_opt (Some a))) stats + in + QCheck.make ?print ?small ?shrink ?collect ~stats gen diff --git a/src/lib_test/qcheck_helpers.mli b/src/lib_test/qcheck_helpers.mli new file mode 100644 index 0000000000000000000000000000000000000000..fe81a73e4c20bb36ab7eba53587a66f233cf60d8 --- /dev/null +++ b/src/lib_test/qcheck_helpers.mli @@ -0,0 +1,80 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Wrap QCheck tests into Alcotests. *) +val qcheck_wrap : QCheck.Test.t list -> unit Alcotest.test_case list + +(** [qcheck_eq pp cmp eq a b] evaluates whether [a] and [b] are equal, and if they + are not, raises a failure and prints an error message. + Equality is evaluated as follows: + - use a provided [eq] + - if no [eq] is provided, use a provided [cmp] + - if neither [eq] nor [cmp] is provided, use {!Stdlib.compare} + + If [pp] is provided, use this to print [x] and [y] if they are not equal. *) +val qcheck_eq : + ?pp:(Format.formatter -> 'a -> unit) -> + ?cmp:('a -> 'a -> int) -> + ?eq:('a -> 'a -> bool) -> + 'a -> + 'a -> + bool + +(** Labeled variant of {!qcheck_eq}. The [unit] argument is necessary as OCaml + requires at least one positional (non-labeled) argument in case of optional + arguments. *) +val qcheck_eq' : + ?pp:(Format.formatter -> 'a -> unit) -> + ?cmp:('a -> 'a -> int) -> + ?eq:('a -> 'a -> bool) -> + expected:'a -> + actual:'a -> + unit -> + bool + +(** [int64_range a b] generates an [int64] between [a] inclusive and [b] inclusive. + + Poorman's implementation until https://github.com/c-cube/qcheck/issues/105 is done. + + This probably spectacularly crashes if [(b - a) > Int64.max_int]. *) +val int64_range : int64 -> int64 -> int64 QCheck.arbitrary + +(** [of_option_gen gen] converts a generator [gen] of optional values into a + generator of values by rerunning the generator if the generated value + was a [None] until a [Some] is generated. + + Be careful: if [None] is always returned, this hangs forever! *) +val of_option_gen : 'a option QCheck.Gen.t -> 'a QCheck.Gen.t + +(** [of_option_arb arb] converts an arbitrary [arb] of optional values into + an arbitrary of values. + + - Generation of values is delegated to {!of_option_gen} (retries on + [None] values until a [Some] is generated). + - Shrinking uses the input shrinker but ignores [None] values. + + Be careful: if [None] is always returned, this hangs forever! +*) +val of_option_arb : 'a option QCheck.arbitrary -> 'a QCheck.arbitrary diff --git a/src/proto_alpha/lib_protocol/test/dune b/src/proto_alpha/lib_protocol/test/dune index 87b7e95ceff7fb0a23cccd5ff949fdb5a0020ed8..cd3c53e70af9ead7bb3fb5a24eccaf86c323dbe5 100644 --- a/src/proto_alpha/lib_protocol/test/dune +++ b/src/proto_alpha/lib_protocol/test/dune @@ -1,9 +1,11 @@ (executables - (names main saturation_fuzzing) + (names main saturation_fuzzing test_gas_properties) (libraries tezos-base tezos-micheline tezos-protocol-environment alcotest-lwt + lib-test + qcheck-alcotest crowbar tezos-alpha-test-helpers tezos-stdlib-unix diff --git a/src/proto_alpha/lib_protocol/test/main.ml b/src/proto_alpha/lib_protocol/test/main.ml index 3dfbf30e1f0fc2c1679b868d0e157f02a54853c0..7f70d29a11b9b8c54b9e6ada7bf6c72fc358b5ac 100644 --- a/src/proto_alpha/lib_protocol/test/main.ml +++ b/src/proto_alpha/lib_protocol/test/main.ml @@ -49,7 +49,6 @@ let () = ("voting", Test_voting.tests); ("interpretation", Test_interpretation.tests); ("typechecking", Test_typechecking.tests); - ("gas properties", Test_gas_properties.tests); ("fixed point computation", Test_fixed_point.tests); ("gas levels", Test_gas_levels.tests); ("saturation arithmetic", Test_saturation.tests); diff --git a/src/proto_alpha/lib_protocol/test/test_gas_properties.ml b/src/proto_alpha/lib_protocol/test/test_gas_properties.ml index ae72c19d4d6703086d48badfdf5a85b59026ff6f..202d438eed570576250ce529cbd87d32464260c7 100644 --- a/src/proto_alpha/lib_protocol/test/test_gas_properties.ml +++ b/src/proto_alpha/lib_protocol/test/test_gas_properties.ml @@ -26,147 +26,119 @@ (** Testing ------- Component: Protocol (gas properties) - Invocation: dune exec src/proto_alpha/lib_protocol/test/main.exe -- test "^gas properties$" + Invocation: dune exec src/proto_alpha/lib_protocol/test/test_gas_properties.exe Subject: Arithmetic properties around gas. *) open Protocol -module S = Saturation_repr +open Lib_test.Qcheck_helpers -type cost_kind = - | Atomic_step - | Step - | Alloc - | Alloc_bytes - | Alloc_mbytes - | Read_bytes - | Write_bytes +(** Extract a Tezos result for compatibility with QCheck. *) +let extract_qcheck_result = function + | Ok pure_result -> + pure_result + | Error err -> + Format.printf "@\n%a@." Environment.Error_monad.pp_trace err ; + false -let random_cost_kind () = - let i = Random.int 7 in - match i with - | 0 -> - Atomic_step - | 1 -> - Step - | 2 -> - Alloc - | 3 -> - Alloc_bytes - | 4 -> - Alloc_mbytes - | 5 -> - Read_bytes - | 6 -> - Write_bytes - | _ -> - assert false - -let random_cost_of_kind (cost_kind : cost_kind) = - let open Alpha_context.Gas in - let rand = Random.int 1000 in - match cost_kind with - | Atomic_step -> - atomic_step_cost (S.safe_int rand) - | Step -> - step_cost (S.safe_int rand) - | Alloc -> - alloc_cost (S.safe_int rand) - | Alloc_bytes -> - alloc_bytes_cost rand - | Alloc_mbytes -> - alloc_mbytes_cost rand - | Read_bytes -> - read_bytes_cost rand - | Write_bytes -> - write_bytes_cost rand - -let random_cost () = random_cost_of_kind (random_cost_kind ()) +(** [Gas.free] is the neutral element of gas addition: [any_cost +@ Gas.free = Gas.free +@ any_cost = any_cost]. *) +let test_free_neutral (start, any_cost) = + let open Alpha_context in + extract_qcheck_result + ( Gas.consume start Gas.free + >>? fun free_first -> + Gas.consume free_first any_cost + >>? fun branch1 -> + Gas.consume start any_cost + >>? fun cost_first -> + Gas.consume cost_first Gas.free + >|? fun branch2 -> + let equal_consumption_from_start t1 t2 = + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:t1) + (Gas.consumed ~since:start ~until:t2)) + in + equal_consumption_from_start branch1 branch2 + && equal_consumption_from_start branch1 cost_first ) (** Consuming [Gas.free] is equivalent to consuming nothing. *) -let test_free_neutral since = +let test_free_consumption start = let open Alpha_context in - let open Environment.Error_monad in - let cost = random_cost () in - Gas.consume since cost - >>? fun ctxt -> - Gas.consume ctxt Gas.free - >>? fun branch1 -> - Gas.consume since cost - >>? fun branch2 -> - if + extract_qcheck_result + ( Gas.consume start Gas.free + >|? fun after_empty_consumption -> Gas.Arith.( - Gas.consumed ~since:ctxt ~until:branch1 - = Gas.consumed ~since:ctxt ~until:branch2) - then ok_none - else Ok (Some (cost, Gas.free)) + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:after_empty_consumption) + zero) ) (** Consuming [cost1] then [cost2] is equivalent to consuming [Gas.(cost1 +@ cost2)]. *) -let test_consume_commutes since = +let test_consume_commutes (start, cost1, cost2) = let open Alpha_context in - let open Environment.Error_monad in - let cost1 = random_cost () in - let cost2 = random_cost () in - Gas.consume since cost1 - >>? fun ctxt -> - Gas.consume ctxt cost2 - >>? fun branch1 -> - Gas.consume since Gas.(cost1 +@ cost2) - >>? fun branch2 -> - if + extract_qcheck_result + ( Gas.consume start cost1 + >>? fun after_cost1 -> + Gas.consume after_cost1 cost2 + >>? fun branch1 -> + Gas.consume start Gas.(cost1 +@ cost2) + >|? fun branch2 -> Gas.Arith.( - Gas.consumed ~since:ctxt ~until:branch1 - = Gas.consumed ~since:ctxt ~until:branch2) - then ok_none - else Ok (Some (cost1, cost2)) + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:branch1) + (Gas.consumed ~since:start ~until:branch2)) ) -let rec loop_check check n ctxt = - let open Environment.Error_monad in - if n = 0 then ok_none - else - check ctxt - >>? function - | None -> - loop_check check (n - 1) ctxt - | counterexample -> - Ok counterexample +(** Arbitrary context with a gas limit of 100_000_000. *) +let context_arb : Alpha_context.t QCheck.arbitrary = + QCheck.always + ( Lwt_main.run + ( Context.init 1 + >>=? fun (b, _contracts) -> + Incremental.begin_construction b + >|=? fun inc -> + let state = Incremental.validation_state inc in + Alpha_context.Gas.set_limit + state.ctxt + Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000)) ) + |> function Ok a -> a | Error _ -> assert false ) -let check_property prop () = - Random.init 89809344 ; - Context.init 1 - >>=? fun (b, _contracts) -> - Incremental.begin_construction b - >>=? fun inc -> - let state = Incremental.validation_state inc in - let ctxt = - Alpha_context.Gas.set_limit - state.ctxt - Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000)) - in - let result = prop ctxt in - match result with - | Ok None -> - return_unit - | Ok (Some (cost1, cost2)) -> - let msg = - Format.asprintf - "gas consume commutation falsified for %a ; %a" - Alpha_context.Gas.pp_cost - cost1 - Alpha_context.Gas.pp_cost - cost2 - in - failwith "%s" msg - | Error _err -> - failwith "gas_consume_commutes: protocol error" +(** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) +let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = + let open Alpha_context.Gas in + let open QCheck in + let rand = 0 -- 1000 in + let safe_rand = map Saturation_repr.safe_int rand in + choose + [ map atomic_step_cost safe_rand; + map step_cost safe_rand; + map alloc_cost safe_rand; + map alloc_bytes_cost rand; + map alloc_mbytes_cost rand; + map read_bytes_cost rand; + map write_bytes_cost rand ] let tests = - [ Test_services.tztest - "Gas.free is a neutral element" - `Quick - (check_property (loop_check test_free_neutral 1000)); - Test_services.tztest - "Gas.consume commutes" - `Quick - (check_property (loop_check test_consume_commutes 1000)) ] + [ QCheck.Test.make + ~count:1000 + ~name:"Consuming commutes" + QCheck.(triple context_arb gas_cost_arb gas_cost_arb) + test_consume_commutes; + QCheck.Test.make + ~count:1000 + ~name:"Consuming [free] consumes nothing" + context_arb + test_free_consumption; + QCheck.Test.make + ~count:1000 + ~name:"[free] is the neutral element of Gas addition" + QCheck.(pair context_arb gas_cost_arb) + test_free_neutral ] + +let () = Alcotest.run "gas properties" [("gas properties", qcheck_wrap tests)] diff --git a/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam b/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam index b3255b429f7a5d05ca4b0257059340c86c09d7d5..06a0f8b32833190167786d0f85166433c3f6ae06 100644 --- a/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam +++ b/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam @@ -11,6 +11,8 @@ depends: [ "alcotest-lwt" { with-test & >= "1.1.0" } "astring" { with-test } "crowbar" { with-test } + "lib-test" { with-test } + "qcheck-alcotest" { with-test } "tezos-alpha-test-helpers" { with-test } "tezos-stdlib-unix" { with-test } "tezos-protocol-environment" { with-test }