diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index eb4fe047..314a9e46 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -18,6 +18,8 @@ jobs: ghc-version: '8.10' - name: Build run: | + sudo apt-get update + sudo apt-get install -y libsecp256k1-0 libsecp256k1-dev cabal --version ghc --version cabal update diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index fb329c80..039bddb0 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -11,37 +11,20 @@ jobs: matrix: os: - ubuntu-latest - - # TODO: nixbuild.net currently does not have x86_64-darwin nor aarch64-darwin support but they're working on it: - # - # | I do have another question: do you support x86_64-darwin builds and - # | ideally aarch64-darwin as well (I just got a new M1 MacBook)? - # - # Our long-term goal is to support x86_64-darwin and aarch64-darwin, but - # we don't do it today. The reason is that we really like all builds to - # run inside our virtualized sandbox (with our own virtual file system), - # since it gives us full control and also lots of insights about the - # builds. We have not yet ported this sandbox to MacOS, but it is - # definitely something we want to do. - # - # We actually _have_ aarch64-darwin machines in our build cluster, - # running build sandboxes for aarch64-linux. We use a mix of Hetzner - # instances (https://www.hetzner.com/dedicated-rootserver/mac-mini-m1) - # and self-hosted M1 machines for this. The aarch64-linux support is EA - # in nixbuild.net, so we are still experimenting a bit. - # - # - macos-latest + - macos-latest fail-fast: false runs-on: ${{ matrix.os }} env: - SSH_KEY_FOR_NIXBUILD: secrets.SSH_KEY_FOR_NIXBUILD + SSH_KEY_FOR_NIXBUILD: ${{ secrets.SSH_KEY_FOR_NIXBUILD }} steps: - uses: actions/checkout@v2 - - uses: nixbuild/nix-quick-install-action@v13 + - if: matrix.os == 'macos-latest' + uses: cachix/install-nix-action@v16 + - if: matrix.os == 'ubuntu-latest' + uses: nixbuild/nix-quick-install-action@v13 with: nix_conf: experimental-features = nix-command - - name: Configure Nix to use nixbuild.net as a remote builder - if: env.SSH_KEY_FOR_NIXBUILD != '' + - if: matrix.os == 'ubuntu-latest' && env.SSH_KEY_FOR_NIXBUILD != '' uses: nixbuild/nixbuild-action@v10 with: nixbuild_ssh_key: ${{ secrets.SSH_KEY_FOR_NIXBUILD }} diff --git a/cabal.project.freeze b/cabal.project.freeze index 5bf2bf2d..698ef7a9 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -22,19 +22,21 @@ constraints: any.FloatingHex ==0.5, any.base-compat-batteries ==0.11.2, any.base-orphans ==0.8.6, any.base-unicode-symbols ==0.2.4.2, + any.base16 ==0.3.0.2, any.base16-bytestring ==1.0.2.0, any.base32 ==0.2.1.0, any.base64-bytestring ==1.1.0.0, any.basement ==0.0.12, any.bifunctors ==5.5.11, any.binary ==0.8.8.0, - any.bindings-DSL ==1.0.25, + any.binary-orphans ==1.0.1, any.blaze-builder ==0.4.2.2, any.blaze-html ==0.9.1.2, any.blaze-markup ==0.8.2.8, any.bsb-http-chunked ==0.0.0.4, any.byte-order ==0.1.2.0, any.byteorder ==1.0.4, + any.bytes ==0.17.1, any.bytestring ==0.10.12.0, any.call-stack ==0.3.0, any.candid ==0.2, @@ -44,6 +46,7 @@ constraints: any.FloatingHex ==0.5, any.clock ==0.8.2, any.colour ==2.3.6, any.comonad ==5.0.8, + any.conduit ==1.3.4.2, any.connection ==0.3.1, any.constraints ==0.13.1, any.containers ==0.6.5.1, @@ -59,6 +62,8 @@ constraints: any.FloatingHex ==0.5, any.dlist ==1.0, any.easy-file ==0.2.2, any.ed25519 ==0.0.5.0, + any.either ==5.0.1.1, + any.entropy ==0.4.1.7, any.exceptions ==0.10.4, any.fast-logger ==3.0.5, any.file-embed ==0.0.15.0, @@ -71,14 +76,19 @@ constraints: any.FloatingHex ==0.5, any.ghc-prim ==0.6.1, any.half ==0.3.1, any.hashable ==1.3.0.0, + any.haskoin-core ==0.20.5, any.hex-text ==0.1.0.4, any.hourglass ==0.2.12, + any.hspec ==2.7.10, + any.hspec-core ==2.7.10, + any.hspec-discover ==2.7.10, + any.hspec-expectations ==0.8.2, any.http-client ==0.7.11, any.http-client-tls ==0.3.5.3, any.http-date ==0.0.11, any.http-types ==0.12.3, any.http2 ==3.0.2, - ic-hs +library -release, + ic-hs +library, any.indexed-profunctors ==0.1.1, any.indexed-traversable ==0.1.2, any.integer-gmp ==1.0.3.0, @@ -95,7 +105,9 @@ constraints: any.FloatingHex ==0.5, any.microlens-th ==0.4.3.10, any.mime-types ==0.1.0.9, any.monad-control ==1.0.3.1, + any.mono-traversable ==1.0.15.3, any.mtl ==2.2.2, + any.murmur3 ==1.0.5, any.nats ==1.1.2, any.network ==3.1.1.1, any.network-byte-order ==0.1.6, @@ -119,9 +131,13 @@ constraints: any.FloatingHex ==0.5, any.resourcet ==1.2.4.3, any.row-types ==1.0.1.2, any.rts ==1.0.1, + any.safe ==0.3.19, any.scientific ==0.3.7.0, + any.secp256k1-haskell ==0.6.0, + any.semigroupoids ==5.3.6, any.semigroups ==0.19.2, any.serialise ==0.2.4.0, + any.setenv ==0.1.1.3, any.simple-sendfile ==0.2.30, any.socks ==0.6.1, any.split ==0.2.3.4, @@ -129,6 +145,7 @@ constraints: any.FloatingHex ==0.5, any.stm ==2.5.0.1, any.streaming-commons ==0.2.2.1, any.strict ==0.4.0.1, + any.string-conversions ==0.4.0.1, any.tagged ==0.8.6.1, any.tasty ==1.4.2, any.tasty-ant-xml ==1.1.8, @@ -140,6 +157,7 @@ constraints: any.FloatingHex ==0.5, any.temporary ==1.3, any.text ==1.2.4.1, any.text-short ==0.1.3, + any.tf-random ==0.5, any.th-abstraction ==0.4.3.0, any.th-compat ==0.1.3, any.these ==1.1.1.1, @@ -163,6 +181,8 @@ constraints: any.FloatingHex ==0.5, any.uuid-types ==1.0.5, any.vault ==0.3.1.5, any.vector ==0.12.3.1, + any.vector-algorithms ==0.8.0.4, + any.void ==0.7.3, any.wai ==3.2.3, any.wai-cors ==0.2.7, any.wai-extra ==3.1.7, diff --git a/default.nix b/default.nix index 068b6bc7..ecd6ab62 100644 --- a/default.nix +++ b/default.nix @@ -32,9 +32,68 @@ let haskellPackages = nixpkgs.haskellPackages.override { # the downgrade of cborg in nix/generated.nix makes cborgs test suite depend on # older versions of stuff, so let’s ignore the test suite. cborg = nixpkgs.haskell.lib.dontCheck generated.cborg; - # here more adjustments can be made if needed, e.g. # crc = nixpkgs.haskell.lib.markUnbroken (nixpkgs.haskell.lib.dontCheck super.crc); + murmur3 = nixpkgs.haskell.lib.markUnbroken super.murmur3; + secp256k1-haskell = nixpkgs.haskell.lib.markUnbroken super.secp256k1-haskell_0_6_0; + haskoin-core = nixpkgs.haskell.lib.dontCheck super.haskoin-core; + }; +}; in + +let staticHaskellPackages = nixpkgs.pkgsStatic.haskell.packages.integer-simple.ghc8107.override { + # We override GHC such that TemplateHaskell doesn't require shared libraries + # which are not available in pkgsStatic. + # See: https://github.com/NixOS/nixpkgs/issues/61575#issuecomment-879403341 + ghc = (nixpkgs.pkgsStatic.buildPackages.haskell.compiler.integer-simple.ghc8107.override { + enableRelocatedStaticLibs = true; + enableShared = false; + }).overrideAttrs (oldAttr: { preConfigure = '' + ${oldAttr.preConfigure or ""} + echo "GhcLibHcOpts += -fPIC -fexternal-dynamic-refs" >> mk/build.mk + echo "GhcRtsHcOpts += -fPIC -fexternal-dynamic-refs" >> mk/build.mk + ''; + }); + overrides = self: super: + let generated = import nix/generated/all.nix self super; in + generated // + { + # the downgrade of cborg in nix/generated.nix makes cborgs test suite depend on + # older versions of stuff, so let’s ignore the test suite. + cborg = nixpkgs.haskell.lib.dontCheck ( + nixpkgs.haskell.lib.appendConfigureFlag generated.cborg "-f-optimize-gmp" + ); + + murmur3 = nixpkgs.haskell.lib.markUnbroken super.murmur3; + + secp256k1-haskell = + nixpkgs.haskell.lib.addBuildTool + (nixpkgs.haskell.lib.markUnbroken super.secp256k1-haskell_0_6_0) + nixpkgs.pkg-config; + + haskoin-core = nixpkgs.haskell.lib.dontCheck super.haskoin-core; + + cryptonite = nixpkgs.haskell.lib.dontCheck ( + nixpkgs.haskell.lib.appendConfigureFlag super.cryptonite "-f-integer-gmp" + ); + + # more test suites too slow withour integer-gmp + scientific = nixpkgs.haskell.lib.dontCheck super.scientific; + math-functions = nixpkgs.haskell.lib.dontCheck super.math-functions; + + # We disable haddock to prevent the error: + # + # Haddock coverage: + # haddock: panic! (the 'impossible' happened) + # (GHC version 8.10.7: + # lookupGlobal + # + # Failed to load interface for ‘GHC.Integer.Type’ + # Perhaps you haven't installed the "dyn" libraries for package ‘integer-simple-0.1.2.0’? + cmdargs = nixpkgs.haskell.lib.dontHaddock super.cmdargs; + file-embed = nixpkgs.haskell.lib.dontHaddock super.file-embed; + QuickCheck = nixpkgs.haskell.lib.dontHaddock super.QuickCheck; + candid = nixpkgs.haskell.lib.dontHaddock super.candid; + winter = nixpkgs.haskell.lib.dontHaddock generated.winter; }; }; in @@ -91,47 +150,42 @@ let # (once we can use ghc-9.0 we can maybe use ghc-bignum native, which should be faster) else let - muslHaskellPackages = nixpkgs.pkgsMusl.haskell.packages.integer-simple.ghc8107.override { - overrides = self: super: - let generated = import nix/generated/all.nix self super; in - generated // - { - # the downgrade of cborg in nix/generated.nix makes cborgs test suite depend on - # older versions of stuff, so let’s ignore the test suite. - cborg = nixpkgs.haskell.lib.dontCheck ( - generated.cborg.overrideAttrs(old: { - configureFlags = ["-f-optimize-gmp"]; - })); - - cryptonite = super.cryptonite.overrideAttrs(old: { - configureFlags = "-f-integer-gmp"; - doCheck = false; # test suite too slow without integer-gmp - }); - - # more test suites too slow withour integer-gmp - scientific = nixpkgs.haskell.lib.dontCheck super.scientific; - math-functions = nixpkgs.haskell.lib.dontCheck super.math-functions; - - }; - }; - ic-hs-musl = - muslHaskellPackages.ic-hs.overrideAttrs ( - old: { - configureFlags = [ - "-frelease" - "-f-library" - "--ghc-option=-optl=-static" - "--extra-lib-dirs=${nixpkgs.pkgsMusl.zlib.static}/lib" - "--extra-lib-dirs=${nixpkgs.pkgsMusl.libffi.overrideAttrs (old: { dontDisableStatic = true; })}/lib" - ]; - } - ); - in nixpkgs.runCommandNoCC "ic-ref-dist" { - allowedRequisites = []; - } '' - mkdir -p $out/bin - cp ${ic-hs-musl}/bin/ic-ref $out/bin - ''; + ic-hs-static = + nixpkgs.haskell.lib.justStaticExecutables + (nixpkgs.haskell.lib.failOnAllWarnings + staticHaskellPackages.ic-hs); + in nixpkgs.runCommandNoCC "ic-ref-dist" { + allowedReferences = []; + nativeBuildInputs = [ nixpkgs.removeReferencesTo ]; + } '' + mkdir -p $out/bin + cp ${ic-hs-static}/bin/ic-ref $out/bin + + # The Paths_warp module in warp contains references to warp's /nix/store path like: + # + # warp_bindir="/nix/store/...-warp-static-x86_64-unknown-linux-musl-3.3.17/bin" + # warp_libdir="/nix/store/...-warp-static-x86_64-unknown-linux-musl-3.3.17/lib/ghc-8.10.7/x86_64-linux-ghc-8.10.7/warp-3.3.17-LFuiV3JNZfpKQMWWUSmbjd" + # warp_dynlibdir="/nix/store/...-warp-static-x86_64-unknown-linux-musl-3.3.17/lib/ghc-8.10.7/x86_64-linux-ghc-8.10.7" + # warp_datadir"/nix/store/...-warp-static-x86_64-unknown-linux-musl-3.3.17/share/x86_64-linux-ghc-8.10.7/warp-3.3.17" + # warp_libexecdir"/nix/store/...-warp-static-x86_64-unknown-linux-musl-3.3.17/libexec/x86_64-linux-ghc-8.10.7/warp-3.3.17" + # warp_sysconfdir"/nix/store/...-warp-static-x86_64-unknown-linux-musl-3.3.17/etc" + # + # These paths end up in the statically compiled $out/bin/ic-ref which + # will fail the `allowedReferences = []` check. + # + # Fortunatley warp doesn't use these `warp_*` paths: + # + # /tmp/warp-3.3.19 $ grep -r -w Paths_warp + # warp.cabal: Paths_warp + # warp.cabal: Paths_warp + # Network/Wai/Handler/Warp/Response.hs:import qualified Paths_warp + # Network/Wai/Handler/Warp/Response.hs:warpVersion = showVersion Paths_warp.version + # Network/Wai/Handler/Warp/Settings.hs:import qualified Paths_warp + # Network/Wai/Handler/Warp/Settings.hs: , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version + # + # So we can safely remove the references to warp: + remove-references-to -t ${staticHaskellPackages.warp} $out/bin/ic-ref + ''; # We run the unit test suite only as part of coverage checking. @@ -149,6 +203,8 @@ rec { inherit ic-hs-coverage; inherit universal-canister; + haskoin-core = haskellPackages.haskoin-core; + ic-ref-test = nixpkgs.runCommandNoCC "ic-ref-test" { nativeBuildInputs = [ ic-hs ]; } '' @@ -166,6 +222,9 @@ rec { coverage = nixpkgs.runCommandNoCC "ic-ref-test" { nativeBuildInputs = [ haskellPackages.ghc ic-hs-coverage ]; + # Prevent rebuilds whenever non-Haskell related files (like .nix) change. + srcdir = nixpkgs.lib.sourceByRegex (nixpkgs.subpath ./.) + [ "^src.*" "^ic-hs.cabal" "^cbits.*" "^LICENSE" "^ic.did" ]; } '' function kill_ic_ref () { kill %1; } ic-ref --pick-port --write-port-to port & @@ -178,7 +237,7 @@ rec { sleep 5 # wait for ic-ref.tix to be written find - LANG=C.UTF8 hpc markup ic-ref.tix --hpcdir=${ic-hs-coverage}/share/hpc/vanilla/mix/ic-ref --srcdir=${subpath ./.} --destdir $out + LANG=C.UTF8 hpc markup ic-ref.tix --hpcdir=${ic-hs-coverage}/share/hpc/vanilla/mix/ic-ref --srcdir=$srcdir --destdir $out mkdir -p $out/nix-support echo "report coverage $out hpc_index.html" >> $out/nix-support/hydra-build-products @@ -264,12 +323,11 @@ rec { # include shell in default.nix so that the nix cache will have pre-built versions # of all the dependencies that are only depended on by nix-shell. ic-hs-shell = - let extra-pkgs = [ - nixpkgs.cabal-install - nixpkgs.ghcid - ]; in - - haskellPackages.ic-hs.env.overrideAttrs (old: { - propagatedBuildInputs = (old.propagatedBuildInputs or []) ++ extra-pkgs ; - }); + haskellPackages.shellFor { + packages = p: [ p.ic-hs ]; + buildInputs = [ + nixpkgs.cabal-install + nixpkgs.ghcid + ]; + }; } diff --git a/ic-hs.cabal b/ic-hs.cabal index ed948381..856d5489 100644 --- a/ic-hs.cabal +++ b/ic-hs.cabal @@ -7,10 +7,6 @@ license-file: LICENSE build-type: Simple extra-source-files: cbits/*.h ic.did -flag release - default: False - description: Release build, warnings are errors - flag library default: True description: Build library (useful to disable in musl builds) @@ -65,8 +61,6 @@ common ghc-flags hs-source-dirs: src ghc-options: -rtsopts ghc-options: -Wall -Wno-name-shadowing - if flag(release) - ghc-options: -Werror executable ic-ref import: cbits, ghc-flags @@ -79,7 +73,6 @@ executable ic-ref build-depends: base >=4.12 && <5 build-depends: base64-bytestring >= 1.1 build-depends: binary - build-depends: bindings-DSL build-depends: bytestring build-depends: candid build-depends: case-insensitive @@ -93,6 +86,7 @@ executable ic-ref build-depends: ed25519 build-depends: filepath build-depends: hashable + build-depends: haskoin-core build-depends: hex-text build-depends: http-client >= 0.7.11 build-depends: http-client-tls @@ -126,6 +120,7 @@ executable ic-ref build-depends: uglymemo build-depends: warp build-depends: zlib + build-depends: either other-modules: IC.Canister other-modules: IC.Canister.Imp other-modules: IC.Canister.Snapshot @@ -139,6 +134,7 @@ executable ic-ref other-modules: IC.Certificate.Value other-modules: IC.Constants other-modules: IC.Crypto + other-modules: IC.Crypto.Bitcoin other-modules: IC.Crypto.BLS other-modules: IC.Crypto.CanisterSig other-modules: IC.Crypto.DER @@ -186,7 +182,6 @@ executable ic-ref-run build-depends: base >=4.12 && <5 build-depends: base64-bytestring >= 1.1 build-depends: binary - build-depends: bindings-DSL build-depends: bytestring build-depends: candid build-depends: case-insensitive @@ -199,6 +194,7 @@ executable ic-ref-run build-depends: ed25519 build-depends: filepath build-depends: hashable + build-depends: haskoin-core build-depends: hex-text build-depends: http-client >= 0.7.11 build-depends: http-types @@ -223,6 +219,7 @@ executable ic-ref-run build-depends: winter build-depends: uglymemo build-depends: zlib + build-depends: either other-modules: IC.Canister other-modules: IC.Canister.Imp other-modules: IC.Canister.Snapshot @@ -235,6 +232,7 @@ executable ic-ref-run other-modules: IC.Certificate.Validate other-modules: IC.Certificate.Value other-modules: IC.Constants + other-modules: IC.Crypto.Bitcoin other-modules: IC.Crypto other-modules: IC.Crypto.BLS other-modules: IC.Crypto.CanisterSig @@ -278,7 +276,6 @@ executable ic-ref-test build-depends: base >=4.12 && <5 build-depends: base64-bytestring >= 1.1 build-depends: binary - build-depends: bindings-DSL build-depends: bytestring build-depends: candid build-depends: case-insensitive @@ -291,6 +288,7 @@ executable ic-ref-test build-depends: ed25519 build-depends: filepath build-depends: hashable + build-depends: haskoin-core build-depends: hex-text build-depends: http-client >= 0.7.11 build-depends: http-client-tls @@ -318,6 +316,7 @@ executable ic-ref-test build-depends: wai build-depends: warp build-depends: zlib + build-depends: either other-modules: IC.CBOR.Parser other-modules: IC.CBOR.Patterns other-modules: IC.CBOR.Utils @@ -325,6 +324,7 @@ executable ic-ref-test other-modules: IC.Certificate.CBOR other-modules: IC.Certificate.Validate other-modules: IC.Certificate.Value + other-modules: IC.Crypto.Bitcoin other-modules: IC.Crypto other-modules: IC.Crypto.BLS other-modules: IC.Crypto.CanisterSig @@ -346,8 +346,11 @@ executable ic-ref-test other-modules: IC.Management other-modules: IC.Ref.IO other-modules: IC.Test.Agent + other-modules: IC.Test.Agent.Calls other-modules: IC.Test.Options other-modules: IC.Test.Spec + other-modules: IC.Test.Spec.TECDSA + other-modules: IC.Test.Spec.Utils other-modules: IC.Test.Universal other-modules: IC.Types other-modules: IC.Version @@ -374,6 +377,7 @@ executable ic-request-id build-depends: template-haskell build-depends: text build-depends: unordered-containers + build-depends: either other-modules: IC.CBOR.Utils other-modules: IC.Hash other-modules: IC.HTTP.CBOR @@ -399,7 +403,6 @@ test-suite unit-test build-depends: base >= 4 && < 5 build-depends: base64-bytestring >= 1.1 build-depends: binary - build-depends: bindings-DSL build-depends: bytestring build-depends: candid build-depends: case-insensitive @@ -414,6 +417,7 @@ test-suite unit-test build-depends: ed25519 build-depends: filepath build-depends: hashable + build-depends: haskoin-core build-depends: hex-text build-depends: http-client >= 0.7.11 build-depends: http-types @@ -442,6 +446,7 @@ test-suite unit-test build-depends: winter build-depends: uglymemo build-depends: zlib + build-depends: either other-modules: IC.Canister other-modules: IC.Canister.Imp other-modules: IC.Canister.Snapshot @@ -455,6 +460,7 @@ test-suite unit-test other-modules: IC.Certificate.Value other-modules: IC.Constants other-modules: IC.Crypto + other-modules: IC.Crypto.Bitcoin other-modules: IC.Crypto.BLS other-modules: IC.Crypto.CanisterSig other-modules: IC.Crypto.DER @@ -506,7 +512,6 @@ library build-depends: base >= 4 && < 5 build-depends: base64-bytestring >= 1.1 build-depends: binary - build-depends: bindings-DSL build-depends: bytestring build-depends: candid build-depends: case-insensitive @@ -520,6 +525,7 @@ library build-depends: ed25519 build-depends: filepath build-depends: hashable + build-depends: haskoin-core build-depends: hex-text build-depends: http-client >= 0.7.11 build-depends: http-client-tls @@ -562,6 +568,7 @@ library build-depends: winter build-depends: uglymemo build-depends: zlib + build-depends: either exposed-modules: IC.Canister exposed-modules: IC.Canister.Imp exposed-modules: IC.Canister.Snapshot @@ -575,6 +582,7 @@ library exposed-modules: IC.Certificate.Value exposed-modules: IC.Constants exposed-modules: IC.Crypto + exposed-modules: IC.Crypto.Bitcoin exposed-modules: IC.Crypto.BLS exposed-modules: IC.Crypto.CanisterSig exposed-modules: IC.Crypto.DER @@ -605,12 +613,15 @@ library exposed-modules: IC.Serialise exposed-modules: IC.StateFile exposed-modules: IC.Test.Agent + exposed-modules: IC.Test.Agent.Calls exposed-modules: IC.Test.BLS exposed-modules: IC.Test.ECDSA exposed-modules: IC.Test.HashTree exposed-modules: IC.Test.Options exposed-modules: IC.Test.Secp256k1 exposed-modules: IC.Test.Spec + exposed-modules: IC.Test.Spec.TECDSA + exposed-modules: IC.Test.Spec.Utils exposed-modules: IC.Test.Universal exposed-modules: IC.Test.WebAuthn exposed-modules: IC.Types diff --git a/ic.did b/ic.did index 7d80a0f6..4c265161 100644 --- a/ic.did +++ b/ic.did @@ -34,6 +34,8 @@ type error = variant { transform_error; }; +type ecdsa_curve = variant { secp256k1; }; + service ic : { http_request : (record { url : text; @@ -78,4 +80,17 @@ service ic : { }) -> (record {canister_id : canister_id}); provisional_top_up_canister : (record { canister_id: canister_id; amount: nat }) -> (); + +// Threshold ECDSA signature + ecdsa_public_key : (record { + canister_id : opt canister_id; + derivation_path : vec blob; + key_id : record { curve: ecdsa_curve; name: text }; + }) -> (record { public_key : blob; chain_code : blob; }); + sign_with_ecdsa : (record { + message_hash : blob; + derivation_path : vec blob; + key_id : record { curve: ecdsa_curve; name: text }; + }) -> (record { signature : blob }); + } diff --git a/nix/default.nix b/nix/default.nix index 56119cf1..0f06734b 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -47,6 +47,13 @@ let url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/d4d63b04cd9f6ed263db8df4cdd6dcc667f96ccd.tar.gz"; sha256 = "0pd9zfy8wwbwqg0qkgi28kfi2q3kwl1lwkq2k7b50wm5pb3nngrm"; }; + + # We override secp256k1 since the version in nixpkgs doesn't provide a + # .a library needed for a static build of ic-hs. + # + # TODO: We can probably remove this override once we upgrade nixpkgs + # to release-22.05. + secp256k1 = super.callPackage ./secp256k1 {}; }) ]; }; diff --git a/nix/generated/ic-hs.nix b/nix/generated/ic-hs.nix index ba82fe7d..3919f68c 100644 --- a/nix/generated/ic-hs.nix +++ b/nix/generated/ic-hs.nix @@ -11,7 +11,6 @@ , base32 , base64-bytestring , binary -, bindings-DSL , bytestring , candid , case-insensitive @@ -23,8 +22,10 @@ , data-default-class , directory , ed25519 +, either , filepath , hashable +, haskoin-core , hex-text , http-client , http-client-tls @@ -83,7 +84,6 @@ mkDerivation { base32 base64-bytestring binary - bindings-DSL bytestring candid case-insensitive @@ -95,8 +95,10 @@ mkDerivation { data-default-class directory ed25519 + either filepath hashable + haskoin-core hex-text http-client http-client-tls @@ -147,7 +149,6 @@ mkDerivation { base32 base64-bytestring binary - bindings-DSL bytestring candid case-insensitive @@ -159,8 +160,10 @@ mkDerivation { data-default-class directory ed25519 + either filepath hashable + haskoin-core hex-text http-client http-client-tls @@ -208,7 +211,6 @@ mkDerivation { base32 base64-bytestring binary - bindings-DSL bytestring candid case-insensitive @@ -220,8 +222,10 @@ mkDerivation { data-default-class directory ed25519 + either filepath hashable + haskoin-core hex-text http-client http-types diff --git a/nix/secp256k1/default.nix b/nix/secp256k1/default.nix new file mode 100644 index 00000000..fd17b5f8 --- /dev/null +++ b/nix/secp256k1/default.nix @@ -0,0 +1,47 @@ +{ lib +, stdenv +, fetchFromGitHub +, autoreconfHook +}: + +stdenv.mkDerivation { + pname = "secp256k1"; + + version = "unstable-2022-05-19"; + + src = fetchFromGitHub { + owner = "bitcoin-core"; + repo = "secp256k1"; + rev = "44c2452fd387f7ca604ab42d73746e7d3a44d8a2"; + sha256 = "sha256-VXs4hwErka+E29r2d4DwJ4Fdtmrpy0vM3mShfNxxgEM"; + }; + + nativeBuildInputs = [ autoreconfHook ]; + + configureFlags = [ + "--enable-benchmark=no" + "--enable-exhaustive-tests=no" + "--enable-experimental" + "--enable-module-ecdh" + "--enable-module-recovery" + "--enable-module-schnorrsig" + "--enable-tests=yes" + ]; + + doCheck = true; + + checkPhase = "./tests"; + + meta = with lib; { + description = "Optimized C library for EC operations on curve secp256k1"; + longDescription = '' + Optimized C library for EC operations on curve secp256k1. Part of + Bitcoin Core. This library is a work in progress and is being used + to research best practices. Use at your own risk. + ''; + homepage = "https://github.com/bitcoin-core/secp256k1"; + license = with licenses; [ mit ]; + maintainers = with maintainers; [ ]; + platforms = with platforms; all; + }; +} diff --git a/src/IC/.Ref.hs.swp b/src/IC/.Ref.hs.swp new file mode 100644 index 00000000..8edf5690 Binary files /dev/null and b/src/IC/.Ref.hs.swp differ diff --git a/src/IC/Crypto/BLS.hsc b/src/IC/Crypto/BLS.hsc index d8e0a4c4..b7fe10ce 100644 --- a/src/IC/Crypto/BLS.hsc +++ b/src/IC/Crypto/BLS.hsc @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-imports -Wno-unused-top-binds #-} {-# LANGUAGE DeriveGeneric #-} -#include #include module IC.Crypto.BLS ( init @@ -15,28 +14,38 @@ import Prelude hiding (init) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString as BSS import Control.Monad +import Foreign import Foreign.Ptr import Foreign.Marshal.Alloc +import GHC.Generics (Generic) import System.IO.Unsafe -import GHC.Generics - -#strict_import - - -{- typedef struct { - int len; int max; char * val; - } octet; -} -#starttype octet -#field len , CInt -#field max , CInt -#field val , CString -#stoptype - - -#ccall BLS_BLS12381_INIT , IO CInt -#ccall BLS_BLS12381_KEY_PAIR_GENERATE , Ptr -> Ptr -> Ptr -> IO CInt -#ccall BLS_BLS12381_CORE_SIGN , Ptr -> Ptr -> Ptr -> IO CInt -#ccall BLS_BLS12381_CORE_VERIFY , Ptr -> Ptr -> Ptr -> IO CInt +import Foreign.C.String +import Foreign.C.Types + +data C'octet = C'octet CInt CInt CString + +instance Storable C'octet where + sizeOf _ = (#size octet) + alignment _ = alignment (undefined :: CInt) + peek ptr = do + len <- (#peek octet, len) ptr + max <- (#peek octet, max) ptr + val <- (#peek octet, val) ptr + return (C'octet len max val) + poke ptr (C'octet len max val) = do + (#poke octet, len) ptr len + (#poke octet, max) ptr max + (#poke octet, val) ptr val + + +foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_INIT" + c'BLS_BLS12381_INIT :: IO CInt +foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_KEY_PAIR_GENERATE" + c'BLS_BLS12381_KEY_PAIR_GENERATE :: Ptr C'octet -> Ptr C'octet -> Ptr C'octet -> IO CInt +foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_CORE_SIGN" + c'BLS_BLS12381_CORE_SIGN :: Ptr C'octet -> Ptr C'octet -> Ptr C'octet -> IO CInt +foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_CORE_VERIFY" + c'BLS_BLS12381_CORE_VERIFY :: Ptr C'octet -> Ptr C'octet -> Ptr C'octet -> IO CInt init :: IO () init = do diff --git a/src/IC/Crypto/Bitcoin.hs b/src/IC/Crypto/Bitcoin.hs new file mode 100644 index 00000000..9dff2086 --- /dev/null +++ b/src/IC/Crypto/Bitcoin.hs @@ -0,0 +1,67 @@ +module IC.Crypto.Bitcoin + ( ExtendedSecretKey(..) + , createExtendedKey + , derivePrivateKey + , derivePublicKey + , extractChainCode + , publicKeyToDER + , sign + , toHash256 + , toWord32 + ) where + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Short as BSS +import qualified Data.Binary as Get +import qualified Data.Binary.Get as Get +import qualified Data.Vector as Vec +import qualified Haskoin.Keys.Common as Haskoin +import qualified Haskoin.Keys.Extended as Haskoin +import qualified Haskoin.Crypto.Signature as Haskoin +import qualified Haskoin.Crypto.Hash as Haskoin +import Data.Either.Combinators +import Data.Word + +newtype ExtendedSecretKey = ExtendedSecretKey Haskoin.XPrvKey + deriving Show + +createExtendedKey :: BS.ByteString -> ExtendedSecretKey +createExtendedKey seed = ExtendedSecretKey $ Haskoin.makeXPrvKey $ BS.toStrict seed + +derivePrivateKey :: ExtendedSecretKey -> Vec.Vector BS.ByteString -> Either String Haskoin.XPrvKey +derivePrivateKey (ExtendedSecretKey sk) path = mapRight (\p -> Haskoin.derivePath p sk) $ parseSoftDerivationPath $ Vec.toList path + +derivePublicKey :: ExtendedSecretKey -> Vec.Vector BS.ByteString -> Either String Haskoin.XPubKey +derivePublicKey (ExtendedSecretKey sk) path = mapRight (\p -> Haskoin.derivePubPath p (Haskoin.deriveXPubKey sk)) $ parseSoftDerivationPath $ Vec.toList path + +sign :: Haskoin.XPrvKey -> Haskoin.Hash256 -> BS.ByteString +sign key msg = BS.fromStrict $ Haskoin.exportSig $ Haskoin.signHash (Haskoin.xPrvKey key) msg + +parseSoftDerivationPath :: [BS.ByteString] -> Either String Haskoin.SoftPath +parseSoftDerivationPath l = + case raw_path of + Left err -> Left $ "Could not parse derivation path: " ++ err + Right rp -> case Haskoin.toSoft $ Haskoin.listToPath rp of + Nothing -> Left $ "Could not soften derivation path" + Just p -> Right p + where + raw_path = sequence $ map toWord32 l + +publicKeyToDER :: Haskoin.XPubKey -> BS.ByteString +publicKeyToDER k = BS.fromStrict $ Haskoin.exportPubKey False $ Haskoin.xPubKey k + +extractChainCode :: Haskoin.XPubKey -> BS.ByteString +extractChainCode k = BS.fromStrict $ BSS.fromShort $ Haskoin.getHash256 $ Haskoin.xPubChain k + +toWord32 :: BS.ByteString -> Either String Word32 +toWord32 = convert Get.getWord32be + +toHash256 :: BS.ByteString -> Either String Haskoin.Hash256 +toHash256 = convert Get.get + +convert :: Get.Get a -> BS.ByteString -> Either String a +convert get bs = case (Get.runGetOrFail get bs) of + Left (_, _, err) -> Left err + Right (un, n, v) -> if un == BS.empty + then Right v + else Left $ "Input ByteString too long: " ++ show un ++ " " ++ show n diff --git a/src/IC/Debug/JSON.hs b/src/IC/Debug/JSON.hs index 1d009e93..38e9d455 100644 --- a/src/IC/Debug/JSON.hs +++ b/src/IC/Debug/JSON.hs @@ -195,3 +195,4 @@ instance ToJSON StdGen where instance ToJSON SecretKey where toJSON = placeholder "(secret key)" + diff --git a/src/IC/Ref.hs b/src/IC/Ref.hs index 9cf20c55..f94e7fd5 100644 --- a/src/IC/Ref.hs +++ b/src/IC/Ref.hs @@ -85,6 +85,7 @@ import IC.Certificate import IC.Certificate.Value import IC.Certificate.CBOR import IC.Crypto +import IC.Crypto.Bitcoin as Bitcoin import IC.Ref.IO (sendHttpRequest) -- Abstract HTTP Interface @@ -272,6 +273,9 @@ isCanisterRunning cid = getRunStatus cid >>= \case isCanisterEmpty :: ICM m => CanisterId -> m Bool isCanisterEmpty cid = isNothing . content <$> getCanister cid +getCanisterRootKey :: CanisterId -> Bitcoin.ExtendedSecretKey +getCanisterRootKey cid = Bitcoin.createExtendedKey $ rawEntityId cid + -- The following functions assume the canister does exist. -- It would be an internal error if they don't. @@ -457,15 +461,15 @@ handleReadState time (ReadStateRequest _sender paths) = do checkEffectiveCanisterID :: RequestValidation m => CanisterId -> CanisterId -> MethodName -> Blob -> m () checkEffectiveCanisterID ecid cid method arg - | cid == managementCanisterId = case method of - "provisional_create_canister_with_cycles" -> pure () - "raw_rand" -> throwError "raw_rand() cannot be invoked via ingress calls" - "http_request" -> throwError "http_request() cannot be invoked via ingress calls" - _ -> case Codec.Candid.decode @(R.Rec ("canister_id" R..== Principal)) arg of - Left err -> - throwError $ "call to management canister is not valid candid: " <> T.pack err - Right r -> - assertEffectiveCanisterId ecid (principalToEntityId (r .! #canister_id)) + | cid == managementCanisterId = + if | method == "provisional_create_canister_with_cycles" -> pure () + | method `elem` ["raw_rand", "http_request", "ecdsa_public_key", "sign_with_ecdsa"] -> + throwError $ T.pack method <> " cannot be invoked via ingress calls" + | otherwise -> case Codec.Candid.decode @(R.Rec ("canister_id" R..== Principal)) arg of + Left err -> + throwError $ "call to management canister is not valid candid: " <> T.pack err + Right r -> + assertEffectiveCanisterId ecid (principalToEntityId (r .! #canister_id)) | otherwise = assertEffectiveCanisterId ecid cid assertEffectiveCanisterId :: RequestValidation m => CanisterId -> CanisterId -> m () @@ -478,7 +482,7 @@ inspectIngress (CallRequest canister_id user_id method arg) | canister_id == managementCanisterId = if| method `elem` ["provisional_create_canister_with_cycles", "provisional_top_up_canister"] -> return () - | method `elem` [ "raw_rand", "deposit_cycles", "http_request" ] + | method `elem` [ "raw_rand", "deposit_cycles", "http_request", "ecdsa_public_key", "sign_with_ecdsa" ] -> throwError $ "Management method " <> T.pack method <> " cannot be invoked via an ingress call" | method `elem` managementMethods -> case decode @(R.Rec ("canister_id" R..== Principal)) arg of @@ -842,6 +846,8 @@ invokeManagementCanister caller ctxt_id (Public method_name arg) = "provisional_top_up_canister" -> atomic icTopUpCanister "raw_rand" -> atomic icRawRand "http_request" -> atomic $ icHttpRequest caller + "ecdsa_public_key" -> atomic $ icEcdsaPublicKey caller + "sign_with_ecdsa" -> atomic $ icSignWithEcdsa caller _ -> reject RC_DESTINATION_INVALID ("Unsupported management function " ++ method_name) (Just EC_METHOD_NOT_FOUND) where -- always responds @@ -1115,6 +1121,31 @@ runRandIC a = state $ \ic -> let (x, g) = runRand a (rng ic) in (x, ic { rng = g }) +icEcdsaPublicKey :: (ICM m, CanReject m) => EntityId -> ICManagement m .! "ecdsa_public_key" +icEcdsaPublicKey caller r = do + let cid = case r .! #canister_id of + Just cid -> principalToEntityId cid + Nothing -> caller + canisterMustExist cid + let key = getCanisterRootKey cid + case Bitcoin.derivePublicKey key (r .! #derivation_path) of + Left err -> reject RC_CANISTER_ERROR err (Just EC_INVALID_ENCODING) + Right k -> return $ R.empty + .+ #public_key .== (publicKeyToDER k) + .+ #chain_code .== (extractChainCode k) + +icSignWithEcdsa :: (ICM m, CanReject m) => EntityId -> ICManagement m .! "sign_with_ecdsa" +icSignWithEcdsa caller r = do + let key = getCanisterRootKey caller + case Bitcoin.derivePrivateKey key (r .! #derivation_path) of + Left err -> reject RC_CANISTER_ERROR err (Just EC_INVALID_ENCODING) + Right k -> do + case Bitcoin.toHash256 (r .! #message_hash) of + Left err -> reject RC_CANISTER_ERROR err (Just EC_INVALID_ENCODING) + Right h -> + return $ R.empty + .+ #signature .== (Bitcoin.sign k h) + invokeEntry :: ICM m => CallId -> WasmState -> CanisterModule -> Env -> EntryPoint -> m (TrapOr (WasmState, UpdateResult)) @@ -1309,4 +1340,3 @@ orElse a b = a >>= maybe b return onTrap :: Monad m => m (TrapOr a) -> (String -> m a) -> m a onTrap a b = a >>= \case { Trap msg -> b msg; Return x -> return x } - diff --git a/src/IC/Serialise.hs b/src/IC/Serialise.hs index a0ba4406..f643a8f2 100644 --- a/src/IC/Serialise.hs +++ b/src/IC/Serialise.hs @@ -22,7 +22,6 @@ import GHC.Generics import qualified IC.Wasm.Winter as W import qualified IC.Canister.StableMemory as Stable - import Control.Monad.Random.Lazy import System.Random.Internal (StdGen(..)) import System.Random.SplitMix @@ -138,3 +137,4 @@ instance Serialise SecretKey where encode (BLS sk) = encode sk encode _ = error "IC.Serialise SecretKey: Only BLS supported" decode = BLS <$> decode + diff --git a/src/IC/Test/Agent.hs b/src/IC/Test/Agent.hs index 2d0b1624..031a942a 100644 --- a/src/IC/Test/Agent.hs +++ b/src/IC/Test/Agent.hs @@ -27,7 +27,90 @@ This module can also be used in a REPL; see 'connect'. {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE DataKinds #-} -module IC.Test.Agent where +module IC.Test.Agent + ( + HTTPErrOr, + HasAgentConfig, + IC00, + ReqResponse(..), + ReqStatus(..), + AgentConfig(..), + addExpiry, + addNonce, + addNonceExpiryEnv, + anonymousUser, + as2Word64, + asHex, + asRight, + asWord128, + asWord32, + asWord64, + awaitCall', + awaitCall, + awaitStatus, + bothSame, + certValue, + certValueAbsent, + code202, + code202_or_4xx, + code2xx, + code4xx, + connect, + decodeCert', + defaultSK, + defaultUser, + delegationEnv, + doesn'tExist, + ecdsaSK, + ecdsaUser, + enum, + envelope, + envelopeFor, + extractCertData, + getRequestStatus, + getStateCert', + getStateCert, + ic00, + ic00as, + ingressDelay, + is2xx, + isErrOrReject, + isPendingOrProcessing, + isReject, + isReply, + okCBOR, + otherSK, + otherUser, + makeAgentConfig, + postCBOR, + postCallCBOR, + postQueryCBOR, + postReadStateCBOR, + preFlight, + queryCBOR, + queryResponse, + runGet, + secp256k1SK, + secp256k1User, + senderOf, + shorten, + submitCall, + textual, + validateStateCert, + verifySignature, + webAuthnECDSASK, + webAuthnECDSAUser, + webAuthnRSASK, + webAuthnRSAUser, + withAgentConfig, + + -- TODO: these are needed by IC.Test.Agent.Calls. Consider moving them to an Internal module + callIC, + callIC', + callIC'', + agentConfig, + ) + where import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -36,7 +119,6 @@ import qualified Text.Hex as H import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BS import qualified Data.HashMap.Lazy as HM -import qualified Data.Vector as Vec import Network.HTTP.Client import Network.HTTP.Client.TLS import Network.HTTP.Types @@ -54,14 +136,15 @@ import System.Random import System.Exit import Data.Time.Clock.POSIX import Codec.Candid (Principal(..), prettyPrincipal) +import qualified Data.Binary as Get import qualified Data.Binary.Get as Get import qualified Codec.Candid as Candid import Data.Bits import Data.Row -import qualified Data.Row.Records as R import qualified Data.Row.Variants as V -import qualified Data.Row.Internal as R -import qualified Data.Row.Dictionaries as R +import qualified Haskoin.Crypto.Signature as Haskoin +import qualified Haskoin.Crypto.Hash as Haskoin +import qualified Haskoin.Keys.Common as Haskoin import IC.Version import IC.HTTP.GenR @@ -145,9 +228,6 @@ endPoint = tc_endPoint agentConfig agentManager :: HasAgentConfig => Manager agentManager = tc_manager agentConfig -testPort :: HasAgentConfig => Int -testPort = tc_test_port agentConfig - -- * Test data for some hardcoded user names doesn'tExist :: Blob @@ -650,103 +730,6 @@ callIC ic00 ecid l x = do Left err -> assertFailure $ "Candid decoding error: " ++ err Right y -> pure y --- The following line noise is me getting out of my way --- to be able to use `ic_create` etc. by passing a record that contains --- a subset of settings, without Maybe -type family UnRec r where UnRec (R.Rec r) = r -type PartialSettings r = (R.Forall r R.Unconstrained1, R.Map Maybe r .// UnRec Settings ≈ UnRec Settings) -fromPartialSettings :: PartialSettings r => R.Rec r -> Settings -fromPartialSettings r = - R.map' Just r .// - R.default' @(R.IsA R.Unconstrained1 Maybe) @(UnRec Settings) d - where - d :: forall a. R.IsA R.Unconstrained1 Maybe a => a - d = case R.as @R.Unconstrained1 @Maybe @a of R.As -> Nothing - -ic_create :: (HasCallStack, HasAgentConfig, PartialSettings r) => IC00 -> Rec r -> IO Blob -ic_create ic00 ps = do - r <- callIC ic00 "" #create_canister $ empty - .+ #settings .== Just (fromPartialSettings ps) - return (rawPrincipal (r .! #canister_id)) - -ic_provisional_create :: - (HasCallStack, HasAgentConfig, PartialSettings r) => - IC00 -> Maybe Natural -> Rec r -> IO Blob -ic_provisional_create ic00 cycles ps = do - r <- callIC ic00 "" #provisional_create_canister_with_cycles $ empty - .+ #amount .== cycles - .+ #settings .== Just (fromPartialSettings ps) - return (rawPrincipal (r .! #canister_id)) - -ic_install :: (HasCallStack, HasAgentConfig) => IC00 -> InstallMode -> Blob -> Blob -> Blob -> IO () -ic_install ic00 mode canister_id wasm_module arg = do - callIC ic00 canister_id #install_code $ empty - .+ #mode .== mode - .+ #canister_id .== Principal canister_id - .+ #wasm_module .== wasm_module - .+ #arg .== arg - -ic_uninstall :: (HasCallStack, HasAgentConfig) => IC00 -> Blob -> IO () -ic_uninstall ic00 canister_id = do - callIC ic00 canister_id #uninstall_code $ empty - .+ #canister_id .== Principal canister_id - -ic_set_controllers :: HasAgentConfig => IC00 -> Blob -> [Blob] -> IO () -ic_set_controllers ic00 canister_id new_controllers = do - callIC ic00 canister_id #update_settings $ empty - .+ #canister_id .== Principal canister_id - .+ #settings .== fromPartialSettings (#controllers .== Vec.fromList (map Principal new_controllers)) - -ic_start_canister :: HasAgentConfig => IC00 -> Blob -> IO () -ic_start_canister ic00 canister_id = do - callIC ic00 canister_id #start_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_stop_canister :: HasAgentConfig => IC00 -> Blob -> IO () -ic_stop_canister ic00 canister_id = do - callIC ic00 canister_id #stop_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_canister_status :: - forall a b. (a -> IO b) ~ (ICManagement IO .! "canister_status") => - HasAgentConfig => IC00 -> Blob -> IO b -ic_canister_status ic00 canister_id = do - callIC ic00 canister_id #canister_status $ empty - .+ #canister_id .== Principal canister_id - -ic_deposit_cycles :: HasAgentConfig => IC00 -> Blob -> IO () -ic_deposit_cycles ic00 canister_id = do - callIC ic00 canister_id #deposit_cycles $ empty - .+ #canister_id .== Principal canister_id - -ic_top_up :: HasAgentConfig => IC00 -> Blob -> Natural -> IO () -ic_top_up ic00 canister_id amount = do - callIC ic00 canister_id #provisional_top_up_canister $ empty - .+ #canister_id .== Principal canister_id - .+ #amount .== amount - -ic_delete_canister :: HasAgentConfig => IC00 -> Blob -> IO () -ic_delete_canister ic00 canister_id = do - callIC ic00 canister_id #delete_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_raw_rand :: HasAgentConfig => IC00 -> IO Blob -ic_raw_rand ic00 = - callIC ic00 "" #raw_rand () - -ic_http_request :: - forall a b. (a -> IO b) ~ (ICManagement IO .! "http_request") => - HasAgentConfig => IC00 -> Blob -> Maybe String -> IO b -ic_http_request ic00 canister_id transform = - callIC ic00 "" #http_request $ empty - .+ #url .== (T.pack $ "http://localhost:" ++ show testPort) - .+ #method .== enum #get - .+ #headers .== Vec.empty - .+ #body .== Nothing - .+ #transform .== (wrap transform canister_id) - where - wrap Nothing _ = Nothing - wrap (Just name) cid = Just (V.IsJust #function (Candid.FuncRef (Principal cid) (T.pack name))) -- Primed variants return the response (reply or reject) callIC' :: forall s a b. HasAgentConfig => @@ -756,55 +739,6 @@ callIC' :: forall s a b. IC00 -> Blob -> Label s -> a -> IO ReqResponse callIC' ic00 ecid l x = ic00 ecid (T.pack (symbolVal l)) (Candid.encode x) -ic_create' :: - (HasCallStack, HasAgentConfig, PartialSettings r) => - IC00 -> Rec r -> IO ReqResponse -ic_create' ic00 ps = do - callIC' ic00 "" #create_canister $ empty - .+ #settings .== Just (fromPartialSettings ps) - -ic_provisional_create' :: - (HasCallStack, HasAgentConfig, PartialSettings r) => - IC00 -> Maybe Natural -> Rec r -> IO ReqResponse -ic_provisional_create' ic00 cycles ps = do - callIC' ic00 "" #provisional_create_canister_with_cycles $ empty - .+ #amount .== cycles - .+ #settings .== Just (fromPartialSettings ps) - -ic_install' :: HasAgentConfig => IC00 -> InstallMode -> Blob -> Blob -> Blob -> IO ReqResponse -ic_install' ic00 mode canister_id wasm_module arg = - callIC' ic00 canister_id #install_code $ empty - .+ #mode .== mode - .+ #canister_id .== Principal canister_id - .+ #wasm_module .== wasm_module - .+ #arg .== arg - -ic_update_settings' :: (HasAgentConfig, PartialSettings r) => IC00 -> Blob -> Rec r -> IO ReqResponse -ic_update_settings' ic00 canister_id r = do - callIC' ic00 canister_id #update_settings $ empty - .+ #canister_id .== Principal canister_id - .+ #settings .== fromPartialSettings r - -ic_set_controllers' :: HasAgentConfig => IC00 -> Blob -> [Blob] -> IO ReqResponse -ic_set_controllers' ic00 canister_id new_controllers = do - ic_update_settings' ic00 canister_id (#controllers .== Vec.fromList (map Principal new_controllers)) - -ic_delete_canister' :: HasAgentConfig => IC00 -> Blob -> IO ReqResponse -ic_delete_canister' ic00 canister_id = do - callIC' ic00 canister_id #delete_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_deposit_cycles' :: HasAgentConfig => IC00 -> Blob -> IO ReqResponse -ic_deposit_cycles' ic00 canister_id = do - callIC' ic00 canister_id #deposit_cycles $ empty - .+ #canister_id .== Principal canister_id - -ic_top_up' :: HasAgentConfig => IC00 -> Blob -> Natural -> IO ReqResponse -ic_top_up' ic00 canister_id amount = do - callIC' ic00 canister_id #provisional_top_up_canister $ empty - .+ #canister_id .== Principal canister_id - .+ #amount .== amount - -- Double primed variants are only for requests from users (so they take the user, -- not a generic ic00 thing), and return the HTTP error code or the response -- (reply or reject) @@ -817,63 +751,6 @@ callIC'' :: forall s a b. Blob -> Blob -> Label s -> a -> IO (HTTPErrOr ReqResponse) callIC'' user ecid l x = ic00as' user ecid (T.pack (symbolVal l)) (Candid.encode x) -ic_install'' :: (HasCallStack, HasAgentConfig) => Blob -> InstallMode -> Blob -> Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_install'' user mode canister_id wasm_module arg = - callIC'' user canister_id #install_code $ empty - .+ #mode .== mode - .+ #canister_id .== Principal canister_id - .+ #wasm_module .== wasm_module - .+ #arg .== arg - -ic_uninstall'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_uninstall'' user canister_id = - callIC'' user canister_id #uninstall_code $ empty - .+ #canister_id .== Principal canister_id - -ic_set_controllers'' :: HasAgentConfig => Blob -> Blob -> [Blob] -> IO (HTTPErrOr ReqResponse) -ic_set_controllers'' user canister_id new_controllers = do - callIC'' user canister_id #update_settings $ empty - .+ #canister_id .== Principal canister_id - .+ #settings .== fromPartialSettings (#controllers .== Vec.fromList (map Principal new_controllers)) - -ic_start_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_start_canister'' user canister_id = do - callIC'' user canister_id #start_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_stop_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_stop_canister'' user canister_id = do - callIC'' user canister_id #stop_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_canister_status'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_canister_status'' user canister_id = do - callIC'' user canister_id #canister_status $ empty - .+ #canister_id .== Principal canister_id - -ic_delete_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_delete_canister'' user canister_id = do - callIC'' user canister_id #delete_canister $ empty - .+ #canister_id .== Principal canister_id - -ic_deposit_cycles'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) -ic_deposit_cycles'' user canister_id = do - callIC'' user canister_id #deposit_cycles $ empty - .+ #canister_id .== Principal canister_id - -ic_raw_rand'' :: HasAgentConfig => Blob -> IO (HTTPErrOr ReqResponse) -ic_raw_rand'' user = do - callIC'' user "" #raw_rand () - -ic_http_request'' ::HasAgentConfig => Blob -> IO (HTTPErrOr ReqResponse) -ic_http_request'' user = - callIC'' user "" #http_request $ empty - .+ #url .== (T.pack $ "http://localhost:" ++ show testPort) - .+ #method .== enum #get - .+ #headers .== Vec.empty - .+ #body .== Nothing - .+ #transform .== Nothing - -- Convenience around Data.Row.Variants used as enums enum :: (AllUniqueLabels r, KnownSymbol l, (r .! l) ~ ()) => Label l -> Var r @@ -890,3 +767,11 @@ textual = T.unpack . prettyPrincipal . Principal shorten :: Int -> String -> String shorten n s = a ++ (if null b then "" else "…") where (a,b) = splitAt n s + +toHash256 :: Blob -> Haskoin.Hash256 +toHash256 = Get.runGet Get.get + +verifySignature :: Blob -> Blob -> Blob -> Bool +verifySignature msg sig key = Haskoin.verifyHashSig (toHash256 msg) s pk + where Just pk = Haskoin.importPubKey $ BS.toStrict key + Just s = Haskoin.decodeStrictSig $ BS.toStrict sig diff --git a/src/IC/Test/Agent/Calls.hs b/src/IC/Test/Agent/Calls.hs new file mode 100644 index 00000000..c9e45c6d --- /dev/null +++ b/src/IC/Test/Agent/Calls.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE DataKinds #-} + +module IC.Test.Agent.Calls + ( + ic_canister_status'', + ic_canister_status, + ic_create', + ic_create, + ic_delete_canister'', + ic_delete_canister', + ic_delete_canister, + ic_deposit_cycles'', + ic_deposit_cycles', + ic_deposit_cycles, + ic_ecdsa_public_key'', + ic_ecdsa_public_key', + ic_ecdsa_public_key, + ic_http_request'', + ic_http_request, + ic_install'', + ic_install', + ic_install, + ic_provisional_create, + ic_provisional_create', + ic_raw_rand'', + ic_raw_rand, + ic_set_controllers'', + ic_set_controllers', + ic_set_controllers, + ic_sign_with_ecdsa'', + ic_sign_with_ecdsa, + ic_start_canister'', + ic_start_canister, + ic_stop_canister'', + ic_stop_canister, + ic_top_up', + ic_top_up, + ic_uninstall'', + ic_uninstall, + ic_update_settings', + ) where + +import qualified Data.Vector as Vec +import qualified Data.Text as T +import Numeric.Natural +import Test.Tasty.HUnit +import Codec.Candid (Principal(..)) +import qualified Codec.Candid as Candid +import Data.Row +import qualified Data.Row.Records as R +import qualified Data.Row.Variants as V +import qualified Data.Row.Internal as R +import qualified Data.Row.Dictionaries as R + +import IC.Management +import IC.Id.Forms +import IC.Test.Agent + +ic_create :: (HasCallStack, HasAgentConfig, PartialSettings r) => IC00 -> Rec r -> IO Blob +ic_create ic00 ps = do + r <- callIC ic00 "" #create_canister $ empty + .+ #settings .== Just (fromPartialSettings ps) + return (rawPrincipal (r .! #canister_id)) + +ic_provisional_create :: + (HasCallStack, HasAgentConfig, PartialSettings r) => + IC00 -> Maybe Natural -> Rec r -> IO Blob +ic_provisional_create ic00 cycles ps = do + r <- callIC ic00 "" #provisional_create_canister_with_cycles $ empty + .+ #amount .== cycles + .+ #settings .== Just (fromPartialSettings ps) + return (rawPrincipal (r .! #canister_id)) + +ic_install :: (HasCallStack, HasAgentConfig) => IC00 -> InstallMode -> Blob -> Blob -> Blob -> IO () +ic_install ic00 mode canister_id wasm_module arg = do + callIC ic00 canister_id #install_code $ empty + .+ #mode .== mode + .+ #canister_id .== Principal canister_id + .+ #wasm_module .== wasm_module + .+ #arg .== arg + +ic_uninstall :: (HasCallStack, HasAgentConfig) => IC00 -> Blob -> IO () +ic_uninstall ic00 canister_id = do + callIC ic00 canister_id #uninstall_code $ empty + .+ #canister_id .== Principal canister_id + +ic_set_controllers :: HasAgentConfig => IC00 -> Blob -> [Blob] -> IO () +ic_set_controllers ic00 canister_id new_controllers = do + callIC ic00 canister_id #update_settings $ empty + .+ #canister_id .== Principal canister_id + .+ #settings .== fromPartialSettings (#controllers .== Vec.fromList (map Principal new_controllers)) + +ic_start_canister :: HasAgentConfig => IC00 -> Blob -> IO () +ic_start_canister ic00 canister_id = do + callIC ic00 canister_id #start_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_stop_canister :: HasAgentConfig => IC00 -> Blob -> IO () +ic_stop_canister ic00 canister_id = do + callIC ic00 canister_id #stop_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_canister_status :: + forall a b. (a -> IO b) ~ (ICManagement IO .! "canister_status") => + HasAgentConfig => IC00 -> Blob -> IO b +ic_canister_status ic00 canister_id = do + callIC ic00 canister_id #canister_status $ empty + .+ #canister_id .== Principal canister_id + +ic_deposit_cycles :: HasAgentConfig => IC00 -> Blob -> IO () +ic_deposit_cycles ic00 canister_id = do + callIC ic00 canister_id #deposit_cycles $ empty + .+ #canister_id .== Principal canister_id + +ic_top_up :: HasAgentConfig => IC00 -> Blob -> Natural -> IO () +ic_top_up ic00 canister_id amount = do + callIC ic00 canister_id #provisional_top_up_canister $ empty + .+ #canister_id .== Principal canister_id + .+ #amount .== amount + +ic_delete_canister :: HasAgentConfig => IC00 -> Blob -> IO () +ic_delete_canister ic00 canister_id = do + callIC ic00 canister_id #delete_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_raw_rand :: HasAgentConfig => IC00 -> IO Blob +ic_raw_rand ic00 = + callIC ic00 "" #raw_rand () + +ic_http_request :: + forall a b. (a -> IO b) ~ (ICManagement IO .! "http_request") => + HasAgentConfig => IC00 -> Blob -> Maybe String -> IO b +ic_http_request ic00 canister_id transform = + callIC ic00 "" #http_request $ empty + .+ #url .== (T.pack $ "http://localhost:" ++ show testPort) + .+ #method .== enum #get + .+ #headers .== Vec.empty + .+ #body .== Nothing + .+ #transform .== (wrap transform canister_id) + where + wrap Nothing _ = Nothing + wrap (Just name) cid = Just (V.IsJust #function (Candid.FuncRef (Principal cid) (T.pack name))) + +ic_ecdsa_public_key :: + forall a b. (a -> IO b) ~ (ICManagement IO .! "ecdsa_public_key") => + HasAgentConfig => IC00 -> Maybe Blob -> Vec.Vector Blob -> IO b +ic_ecdsa_public_key ic00 canister_id path = + callIC ic00 "" #ecdsa_public_key $ empty + .+ #derivation_path .== path + .+ #canister_id .== (fmap Principal canister_id) + .+ #key_id .== (empty + .+ #curve .== enum #secp256k1 + .+ #name .== (T.pack "0") + ) + +ic_sign_with_ecdsa :: + forall a b. (a -> IO b) ~ (ICManagement IO .! "sign_with_ecdsa") => + HasAgentConfig => IC00 -> Blob -> IO b +ic_sign_with_ecdsa ic00 msg = + callIC ic00 "" #sign_with_ecdsa $ empty + .+ #derivation_path .== Vec.empty + .+ #message_hash .== msg + .+ #key_id .== (empty + .+ #curve .== enum #secp256k1 + .+ #name .== (T.pack "0") + ) + + +ic_create' :: + (HasCallStack, HasAgentConfig, PartialSettings r) => + IC00 -> Rec r -> IO ReqResponse +ic_create' ic00 ps = do + callIC' ic00 "" #create_canister $ empty + .+ #settings .== Just (fromPartialSettings ps) + +ic_provisional_create' :: + (HasCallStack, HasAgentConfig, PartialSettings r) => + IC00 -> Maybe Natural -> Rec r -> IO ReqResponse +ic_provisional_create' ic00 cycles ps = do + callIC' ic00 "" #provisional_create_canister_with_cycles $ empty + .+ #amount .== cycles + .+ #settings .== Just (fromPartialSettings ps) + +ic_install' :: HasAgentConfig => IC00 -> InstallMode -> Blob -> Blob -> Blob -> IO ReqResponse +ic_install' ic00 mode canister_id wasm_module arg = + callIC' ic00 canister_id #install_code $ empty + .+ #mode .== mode + .+ #canister_id .== Principal canister_id + .+ #wasm_module .== wasm_module + .+ #arg .== arg + +ic_update_settings' :: (HasAgentConfig, PartialSettings r) => IC00 -> Blob -> Rec r -> IO ReqResponse +ic_update_settings' ic00 canister_id r = do + callIC' ic00 canister_id #update_settings $ empty + .+ #canister_id .== Principal canister_id + .+ #settings .== fromPartialSettings r + +ic_set_controllers' :: HasAgentConfig => IC00 -> Blob -> [Blob] -> IO ReqResponse +ic_set_controllers' ic00 canister_id new_controllers = do + ic_update_settings' ic00 canister_id (#controllers .== Vec.fromList (map Principal new_controllers)) + +ic_delete_canister' :: HasAgentConfig => IC00 -> Blob -> IO ReqResponse +ic_delete_canister' ic00 canister_id = do + callIC' ic00 canister_id #delete_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_deposit_cycles' :: HasAgentConfig => IC00 -> Blob -> IO ReqResponse +ic_deposit_cycles' ic00 canister_id = do + callIC' ic00 canister_id #deposit_cycles $ empty + .+ #canister_id .== Principal canister_id + +ic_top_up' :: HasAgentConfig => IC00 -> Blob -> Natural -> IO ReqResponse +ic_top_up' ic00 canister_id amount = do + callIC' ic00 canister_id #provisional_top_up_canister $ empty + .+ #canister_id .== Principal canister_id + .+ #amount .== amount + +ic_ecdsa_public_key' :: HasAgentConfig => IC00 -> Maybe Blob -> Vec.Vector Blob -> IO ReqResponse +ic_ecdsa_public_key' ic00 canister_id path = + callIC' ic00 "" #ecdsa_public_key $ empty + .+ #derivation_path .== path + .+ #canister_id .== (Principal <$> canister_id) + .+ #key_id .== (empty + .+ #curve .== enum #secp256k1 + .+ #name .== (T.pack "0") + ) + +ic_install'' :: (HasCallStack, HasAgentConfig) => Blob -> InstallMode -> Blob -> Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_install'' user mode canister_id wasm_module arg = + callIC'' user canister_id #install_code $ empty + .+ #mode .== mode + .+ #canister_id .== Principal canister_id + .+ #wasm_module .== wasm_module + .+ #arg .== arg + +ic_uninstall'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_uninstall'' user canister_id = + callIC'' user canister_id #uninstall_code $ empty + .+ #canister_id .== Principal canister_id + +ic_set_controllers'' :: HasAgentConfig => Blob -> Blob -> [Blob] -> IO (HTTPErrOr ReqResponse) +ic_set_controllers'' user canister_id new_controllers = do + callIC'' user canister_id #update_settings $ empty + .+ #canister_id .== Principal canister_id + .+ #settings .== fromPartialSettings (#controllers .== Vec.fromList (map Principal new_controllers)) + +ic_start_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_start_canister'' user canister_id = do + callIC'' user canister_id #start_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_stop_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_stop_canister'' user canister_id = do + callIC'' user canister_id #stop_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_canister_status'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_canister_status'' user canister_id = do + callIC'' user canister_id #canister_status $ empty + .+ #canister_id .== Principal canister_id + +ic_delete_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_delete_canister'' user canister_id = do + callIC'' user canister_id #delete_canister $ empty + .+ #canister_id .== Principal canister_id + +ic_deposit_cycles'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_deposit_cycles'' user canister_id = do + callIC'' user canister_id #deposit_cycles $ empty + .+ #canister_id .== Principal canister_id + +ic_raw_rand'' :: HasAgentConfig => Blob -> IO (HTTPErrOr ReqResponse) +ic_raw_rand'' user = do + callIC'' user "" #raw_rand () + +ic_http_request'' :: HasAgentConfig => Blob -> IO (HTTPErrOr ReqResponse) +ic_http_request'' user = + callIC'' user "" #http_request $ empty + .+ #url .== (T.pack $ "http://localhost:" ++ show testPort) + .+ #method .== enum #get + .+ #headers .== Vec.empty + .+ #body .== Nothing + .+ #transform .== Nothing + +ic_ecdsa_public_key'' :: HasAgentConfig => Blob -> IO (HTTPErrOr ReqResponse) +ic_ecdsa_public_key'' user = + callIC'' user "" #ecdsa_public_key $ empty + .+ #derivation_path .== Vec.empty + .+ #canister_id .== Nothing + .+ #key_id .== (empty + .+ #curve .== enum #secp256k1 + .+ #name .== (T.pack "0") + ) + +ic_sign_with_ecdsa'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) +ic_sign_with_ecdsa'' user msg = + callIC'' user "" #sign_with_ecdsa $ empty + .+ #derivation_path .== Vec.empty + .+ #message_hash .== msg + .+ #key_id .== (empty + .+ #curve .== enum #secp256k1 + .+ #name .== (T.pack "0") + ) + +-------------------------------------------------------------------------------- + +testPort :: HasAgentConfig => Int +testPort = tc_test_port agentConfig + +-- The following line noise is me getting out of my way +-- to be able to use `ic_create` etc. by passing a record that contains +-- a subset of settings, without Maybe +type family UnRec r where UnRec (R.Rec r) = r +type PartialSettings r = (R.Forall r R.Unconstrained1, R.Map Maybe r .// UnRec Settings ≈ UnRec Settings) +fromPartialSettings :: PartialSettings r => R.Rec r -> Settings +fromPartialSettings r = + R.map' Just r .// + R.default' @(R.IsA R.Unconstrained1 Maybe) @(UnRec Settings) d + where + d :: forall a. R.IsA R.Unconstrained1 Maybe a => a + d = case R.as @R.Unconstrained1 @Maybe @a of R.As -> Nothing diff --git a/src/IC/Test/Spec.hs b/src/IC/Test/Spec.hs index 5a1d2abf..a1795870 100644 --- a/src/IC/Test/Spec.hs +++ b/src/IC/Test/Spec.hs @@ -14,8 +14,6 @@ This module contains a test suite for the Internet Computer module IC.Test.Spec (icTests) where import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T import qualified Data.ByteString.Lazy as BS import qualified Data.HashMap.Lazy as HM import qualified Data.Map.Lazy as M @@ -31,12 +29,7 @@ import Data.Word import Data.Functor import Data.Row as R import qualified Data.Row.Variants as V -import System.FilePath -import System.Directory -import System.Environment -import Network.HTTP.Client import Data.Time.Clock.POSIX -import qualified Data.Binary.Get as Get import Codec.Candid (Principal(..)) import qualified Codec.Candid as Candid import Data.Serialize.LEB128 (toLEB128) @@ -44,7 +37,6 @@ import Data.Serialize.LEB128 (toLEB128) import IC.Types (EntityId(..)) import IC.HTTP.GenR import IC.HTTP.RequestId -import qualified IC.HTTP.CBOR as CBOR import IC.Crypto import qualified IC.Crypto.CanisterSig as CanisterSig import qualified IC.Crypto.DER as DER @@ -53,11 +45,10 @@ import IC.Test.Universal import IC.HashTree hiding (Blob, Label) import IC.Certificate import IC.Hash -import IC.Utils import IC.Test.Agent -import IC.Management (HttpResponse) - -type Blob = BS.ByteString +import IC.Test.Agent.Calls +import IC.Test.Spec.Utils +import qualified IC.Test.Spec.TECDSA -- * The test suite (see below for helper functions) @@ -395,6 +386,7 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests" BS.length r2 @?= 32 assertBool "random blobs are different" $ r1 /= r2 + , IC.Test.Spec.TECDSA.tests , testGroup "canister http calls" [ simpleTestCase "simple call, no transform" $ \cid -> do resp <- ic_http_request (ic00via cid) cid Nothing @@ -2120,6 +2112,12 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests" , testCase "management canister: http_request not accepted" $ do ic_http_request'' defaultUser >>= isErrOrReject [] + , testCase "management canister: ecdsa_public_key not accepted" $ do + ic_ecdsa_public_key'' defaultUser >>= isErrOrReject [] + + , testCase "management canister: sign_with_ecdsa not accepted" $ do + ic_sign_with_ecdsa'' defaultUser (sha256 "dummy") >>= isErrOrReject [] + , simpleTestCase "management canister: deposit_cycles not accepted" $ \cid -> do ic_deposit_cycles'' defaultUser cid >>= isErrOrReject [] @@ -2440,358 +2438,3 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests" ] ] - --- * Equality assertions - -is :: (HasCallStack, Eq a, Show a) => a -> a -> Assertion -is exp act = act @?= exp - -isSet :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion -isSet exp act = S.fromList exp @?= S.fromList act - -isContainedIn :: (HasCallStack, Ord a, Show a) => a -> [(a,a)] -> Assertion -isContainedIn p ranges = assertBool (show p ++ " not contained in: " ++ show ranges) $ - any (\(l,r) -> l <= p && p <= r) ranges - --- * Simple Wasm - -trivialWasmModule :: Blob -trivialWasmModule = "\0asm\1\0\0\0" - --- * Some test data related to standard requests - -queryToNonExistant :: GenR -queryToNonExistant = rec - [ "request_type" =: GText "query" - , "sender" =: GBlob anonymousUser - , "canister_id" =: GBlob doesn'tExist - , "method_name" =: GText "foo" - , "arg" =: GBlob "nothing to see here" - ] - -readStateEmpty :: GenR -readStateEmpty = rec - [ "request_type" =: GText "read_state" - , "sender" =: GBlob defaultUser - , "paths" =: GList [] - ] - -badEnvelope :: GenR -> GenR -badEnvelope content = rec - [ "sender_pubkey" =: GBlob (toPublicKey defaultSK) - , "sender_sig" =: GBlob (BS.replicate 64 0x42) - , "content" =: content - ] - --- * Bad requests - -noDomainSepEnv :: SecretKey -> GenR -> IO GenR -noDomainSepEnv sk content = do - sig <- sign "" sk (requestId content) - return $ rec - [ "sender_pubkey" =: GBlob (toPublicKey sk) - , "sender_sig" =: GBlob sig - , "content" =: content - ] - -noExpiryEnv, pastExpiryEnv, futureExpiryEnv :: GenR -> GenR -noExpiryEnv = deleteField "ingress_expiry" -pastExpiryEnv = modNatField "ingress_expiry" (subtract 3600_000_000_000) -futureExpiryEnv = modNatField "ingress_expiry" (+ 3600_000_000_000) - -deleteField :: T.Text -> GenR -> GenR -deleteField f (GRec hm) = GRec $ HM.delete f hm -deleteField _ _ = error "deleteField: not a record" - -modNatField :: T.Text -> (Natural -> Natural) -> GenR -> GenR -modNatField f g (GRec hm) = GRec $ HM.adjust underNat f hm - where underNat :: GenR -> GenR - underNat (GNat n) = GNat (g n) - underNat _ = error "modNatField: not a nat field" -modNatField _ _ _ = error "modNatField: not a record" - --- * Double request - -awaitCallTwice :: HasAgentConfig => Blob -> GenR -> IO ReqResponse -awaitCallTwice cid req = do - req <- addNonce req - req <- addExpiry req - res <- envelopeFor (senderOf req) req >>= postCallCBOR cid - code202 res - res <- envelopeFor (senderOf req) req >>= postCallCBOR cid - code202 res - assertBool "Response body not empty" (BS.null (responseBody res)) - awaitStatus (getRequestStatus (senderOf req) cid (requestId req)) - - - --- * CBOR decoding - -asCBORBlobList :: Blob -> IO [Blob] -asCBORBlobList blob = do - decoded <- asRight $ CBOR.decode blob - case decoded of - GList list -> mapM cborToBlob list - _ -> assertFailure $ "Failed to decode as CBOR encoded list of blobs: " <> show decoded - -cborToBlob :: GenR -> IO Blob -cborToBlob (GBlob blob) = return blob -cborToBlob r = assertFailure $ "Expected blob, got " <> show r - -asCBORBlobPairList :: Blob -> IO [(Blob, Blob)] -asCBORBlobPairList blob = do - decoded <- asRight $ CBOR.decode blob - case decoded of - GList list -> do - mapM cborToBlobPair list - _ -> assertFailure $ "Failed to decode as CBOR encoded list of blob pairs: " <> show decoded - -cborToBlobPair :: GenR -> IO (Blob, Blob) -cborToBlobPair (GList [GBlob x, GBlob y]) = return (x, y) -cborToBlobPair r = assertFailure $ "Expected list of pairs, got: " <> show r - --- Interaction with aaaaa-aa via the universal canister - -ic00via :: HasAgentConfig => Blob -> IC00 -ic00via cid = ic00viaWithCycles cid 0 - -ic00viaWithCycles :: HasAgentConfig => Blob -> Word64 -> IC00 -ic00viaWithCycles cid cycles _ecid method_name arg = - do call' cid $ - callNew - (bytes "") (bytes (BS.fromStrict (T.encodeUtf8 method_name))) -- aaaaa-aa - (callback relayReply) (callback relayReject) >>> - callDataAppend (bytes arg) >>> - callCyclesAdd (int64 cycles) >>> - callPerform - >>= isReply >>= isRelay - --- * Interacting with the universal canister - --- Some common operations on the universal canister --- The primed variant (call') return the response record, --- e.g. to check for error conditions. --- The unprimed variant expect a reply. - -install' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse -install' cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install' ic00 (enum #install) cid universal_wasm (run prog) - -installAt :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () -installAt cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install ic00 (enum #install) cid universal_wasm (run prog) - --- Also calls create, used default 'ic00' -install :: (HasCallStack, HasAgentConfig) => Prog -> IO Blob -install prog = do - cid <- create - installAt cid prog - return cid - -create :: (HasCallStack, HasAgentConfig) => IO Blob -create = ic_provisional_create ic00 (Just (2^(60::Int))) empty - -upgrade' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse -upgrade' cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install' ic00 (enum #upgrade) cid universal_wasm (run prog) - -upgrade :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () -upgrade cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install ic00 (enum #upgrade) cid universal_wasm (run prog) - -reinstall' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse -reinstall' cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install' ic00 (enum #reinstall) cid universal_wasm (run prog) - -reinstall :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () -reinstall cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install ic00 (enum #reinstall) cid universal_wasm (run prog) - -callRequestAs :: (HasCallStack, HasAgentConfig) => Blob -> Blob -> Prog -> GenR -callRequestAs user cid prog = rec - [ "request_type" =: GText "call" - , "sender" =: GBlob user - , "canister_id" =: GBlob cid - , "method_name" =: GText "update" - , "arg" =: GBlob (run prog) - ] - -callToQueryRequestAs :: (HasCallStack, HasAgentConfig) => Blob -> Blob -> Prog -> GenR -callToQueryRequestAs user cid prog = rec - [ "request_type" =: GText "call" - , "sender" =: GBlob user - , "canister_id" =: GBlob cid - , "method_name" =: GText "query" - , "arg" =: GBlob (run prog) - ] - -callRequest :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> GenR -callRequest cid prog = callRequestAs defaultUser cid prog - -callToQuery'' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO (HTTPErrOr ReqResponse) -callToQuery'' cid prog = awaitCall' cid $ callToQueryRequestAs defaultUser cid prog - -stopRequest :: (HasCallStack, HasAgentConfig) => Blob -> GenR -stopRequest cid = rec - [ "request_type" =: GText "call" - , "sender" =: GBlob defaultUser - , "canister_id" =: GBlob "" - , "method_name" =: GText "stop_canister" - , "arg" =: GBlob (Candid.encode (#canister_id .== Principal cid)) - ] - --- The following variants of the call combinator differ in how much failure they allow: --- --- call'' allows HTTP errors at `submit` time already --- call' requires submission to succeed, and allows reject responses --- call requires a reply response --- call_ requires a reply response with an empty blob (a common case) - -call'' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO (HTTPErrOr ReqResponse) -call'' cid prog = awaitCall' cid (callRequest cid prog) - -call' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse -call' cid prog = call'' cid prog >>= is2xx - -call :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO Blob -call cid prog = call' cid prog >>= isReply - -call_ :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () -call_ cid prog = call cid prog >>= is "" - -callTwice' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse -callTwice' cid prog = awaitCallTwice cid (callRequest cid prog) - - -query' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse -query' cid prog = - queryCBOR cid >=> queryResponse $ rec - [ "request_type" =: GText "query" - , "sender" =: GBlob defaultUser - , "canister_id" =: GBlob cid - , "method_name" =: GText "query" - , "arg" =: GBlob (run prog) - ] - -query :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO Blob -query cid prog = query' cid prog >>= isReply - -query_ :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () -query_ cid prog = query cid prog >>= is "" - --- Predicates to handle the responses from relayReply and relayReject -isRelay :: HasCallStack => Blob -> IO ReqResponse -isRelay = runGet $ Get.getWord32le >>= \case - 0 -> Reply <$> Get.getRemainingLazyByteString - 0x4c444944 -> fail "Encountered Candid when expectin relayed data. Did you forget to use isRelay?" - c -> do - msg <- Get.getRemainingLazyByteString - return $ Reject (fromIntegral c) (T.decodeUtf8With T.lenientDecode (BS.toStrict msg)) Nothing - - --- Shortcut for test cases that just need one canister. -simpleTestCase :: (HasCallStack, HasAgentConfig) => String -> (Blob -> IO ()) -> TestTree -simpleTestCase name act = testCase name $ install noop >>= act - --- * Programmatic test generation - --- | Runs test once for each field with that field removed, including nested --- fields -omitFields :: GenR -> (GenR -> Assertion) -> [TestTree] -omitFields (GRec hm) act = - [ let hm' = HM.delete f hm - in testCase ("omitting " ++ T.unpack f) $ act (GRec hm') - | f <- fields - ] ++ concat - [ omitFields val $ \val' -> act (GRec (HM.insert f val' hm)) - | f <- fields - , val@(GRec _) <- return $ hm HM.! f - ] - where fields = sort $ HM.keys hm -omitFields _ _ = error "omitFields needs a GRec" - - --- * Test data access - -getTestFile :: FilePath -> IO FilePath -getTestFile file = - lookupEnv "IC_TEST_DATA" >>= \case - Just fp -> return $ fp file - Nothing -> do - -- nix use - exePath <- getExecutablePath - let exeRelPath = takeDirectory exePath "../test-data" - -- convenient for cabal new-run use - try [ exeRelPath, "test-data", "../test-data", "impl/test-data" ] - where - try (d:ds) = doesFileExist (d file) >>= \case - True -> return (d file) - False -> try ds - try [] = error $ "getTestDir: Could not read " ++ file ++ " from test-data/. Please consult README.md" - -getTestWasm :: FilePath -> IO BS.ByteString -getTestWasm base = do - fp <- getTestFile $ base <.> "wasm" - BS.readFile fp - --- * Helper patterns - --- A barrier - --- This will stop and start all mentioned canisters. This guarantees --- that all outstanding callbacks are handled -barrier :: HasAgentConfig => [Blob] -> IO () -barrier cids = do - mapM_ (ic_stop_canister ic00) cids - mapM_ (ic_start_canister ic00) cids - - --- A message hold --- --- This allows the test driver to withhold the response to a message, and --- control when they are released, in order to produce situations with --- outstanding call contexts. --- --- In an ideal world (from our pov), we could instrument and control the --- system's scheduler this way, but we can't. So instead, we use some tricks. --- Ideally, the details of this trick are irrelevant to the users of this --- function (yay, abstraction), and if we find better tricks, we can swap them --- out easily. We'll see if that holds water. --- --- One problem with this approach is that a test failure could mean that the --- system doesn't pass the test, but it could also mean that the system has a --- bug that prevents this trick from working, so take care. --- --- The current trick is: Create a canister (the "stopper"). Make it its own --- controller. Tell the canister to stop itself. This call will now hang, --- because a canister cannot stop itself. We can release the call (producing a --- reject) by starting the canister again. --- --- Returns a program to be executed by any canister, which will cause this --- canister to send a message that will not be responded to, until the given --- IO action is performed. -createMessageHold :: HasAgentConfig => IO (Prog, IO ()) -createMessageHold = do - cid <- install noop - ic_set_controllers ic00 cid [defaultUser, cid] - let holdMessage = inter_update cid defArgs - { other_side = - callNew "" "stop_canister" (callback (trap "createMessageHold: stopping succeeded?")) (callback reply) >>> - callDataAppend (bytes (Candid.encode (#canister_id .== Principal cid))) >>> - callPerform - , on_reply = reply - } - let release = ic_start_canister ic00 cid - return (holdMessage, release) - -dummyResponse :: HttpResponse -dummyResponse = R.empty - .+ #status .== 202 - .+ #headers .== Vec.empty - .+ #body .== (toUtf8 "Dummy!") diff --git a/src/IC/Test/Spec/TECDSA.hs b/src/IC/Test/Spec/TECDSA.hs new file mode 100644 index 00000000..2cdf6ea1 --- /dev/null +++ b/src/IC/Test/Spec/TECDSA.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} + +module IC.Test.Spec.TECDSA (tests) where + +import Test.Tasty +import qualified Data.Vector as Vec +import IC.Test.Spec.Utils +import IC.Test.Agent +import IC.Test.Agent.Calls +import Data.Row as R +import Test.Tasty.HUnit +import IC.Test.Universal (noop) +import IC.Hash (sha256) + +tests :: HasAgentConfig => TestTree +tests = testGroup "tECDSA" + [ testCase "sign and verify" $ do + cid <- install noop + cid2 <- install noop + sig1 <- ic_sign_with_ecdsa (ic00via cid) (sha256 "internet computer") + sig2 <- ic_sign_with_ecdsa (ic00via cid2) (sha256 "internet computer") + -- if canister id is unset, default to a caller id + pk1 <- ic_ecdsa_public_key (ic00via cid) Nothing Vec.empty + pk2 <- ic_ecdsa_public_key (ic00via cid) (Just cid2) Vec.empty + + assertBool "incorrect signature" $ verifySignature (sha256 "internet computer") (sig1 .! #signature) (pk1 .! #public_key) + assertBool "correct signature, should be incorrect" $ not $ verifySignature (sha256 "internet computer") (sig1 .! #signature) (pk2 .! #public_key) + assertBool "incorrect signature" $ not $ verifySignature (sha256 "internet computer") (sig2 .! #signature) (pk1 .! #public_key) + assertBool "correct signature, should be incorrect" $ verifySignature (sha256 "internet computer") (sig2 .! #signature) (pk2 .! #public_key) + + , simpleTestCase "invalid derivation path" $ \cid -> do + ic_ecdsa_public_key' (ic00via cid) Nothing (Vec.singleton "clearly not Word32") >>= isReject [5] + + , simpleTestCase "id of non-existent canister" $ \cid -> do + ic_ecdsa_public_key' (ic00via cid) (Just "Clearly not a valid EntityId") Vec.empty >>= isReject [5] + ] diff --git a/src/IC/Test/Spec/Utils.hs b/src/IC/Test/Spec/Utils.hs new file mode 100644 index 00000000..c3ace59f --- /dev/null +++ b/src/IC/Test/Spec/Utils.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} + +module IC.Test.Spec.Utils where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.ByteString.Lazy as BS +import qualified Data.HashMap.Lazy as HM +import qualified Data.Set as S +import qualified Data.Vector as Vec +import Numeric.Natural +import Data.List +import Test.Tasty +import Test.Tasty.HUnit +import Control.Monad +import Data.Word +import Data.Row as R +import System.FilePath +import System.Directory +import System.Environment +import Network.HTTP.Client +import qualified Data.Binary.Get as Get +import Codec.Candid (Principal(..)) +import qualified Codec.Candid as Candid + +import IC.HTTP.GenR +import IC.HTTP.RequestId +import qualified IC.HTTP.CBOR as CBOR +import IC.Crypto +import IC.Test.Universal +import IC.Utils +import IC.Test.Agent +import IC.Test.Agent.Calls +import IC.Management (HttpResponse) + +type Blob = BS.ByteString + +-- * Equality assertions + +is :: (HasCallStack, Eq a, Show a) => a -> a -> Assertion +is exp act = act @?= exp + +isSet :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion +isSet exp act = S.fromList exp @?= S.fromList act + +isContainedIn :: (HasCallStack, Ord a, Show a) => a -> [(a,a)] -> Assertion +isContainedIn p ranges = assertBool (show p ++ " not contained in: " ++ show ranges) $ + any (\(l,r) -> l <= p && p <= r) ranges + +-- * Simple Wasm + +trivialWasmModule :: Blob +trivialWasmModule = "\0asm\1\0\0\0" + +-- * Some test data related to standard requests + +queryToNonExistant :: GenR +queryToNonExistant = rec + [ "request_type" =: GText "query" + , "sender" =: GBlob anonymousUser + , "canister_id" =: GBlob doesn'tExist + , "method_name" =: GText "foo" + , "arg" =: GBlob "nothing to see here" + ] + +readStateEmpty :: GenR +readStateEmpty = rec + [ "request_type" =: GText "read_state" + , "sender" =: GBlob defaultUser + , "paths" =: GList [] + ] + +badEnvelope :: GenR -> GenR +badEnvelope content = rec + [ "sender_pubkey" =: GBlob (toPublicKey defaultSK) + , "sender_sig" =: GBlob (BS.replicate 64 0x42) + , "content" =: content + ] + +-- * Bad requests + +noDomainSepEnv :: SecretKey -> GenR -> IO GenR +noDomainSepEnv sk content = do + sig <- sign "" sk (requestId content) + return $ rec + [ "sender_pubkey" =: GBlob (toPublicKey sk) + , "sender_sig" =: GBlob sig + , "content" =: content + ] + +noExpiryEnv, pastExpiryEnv, futureExpiryEnv :: GenR -> GenR +noExpiryEnv = deleteField "ingress_expiry" +pastExpiryEnv = modNatField "ingress_expiry" (subtract 3600_000_000_000) +futureExpiryEnv = modNatField "ingress_expiry" (+ 3600_000_000_000) + +deleteField :: T.Text -> GenR -> GenR +deleteField f (GRec hm) = GRec $ HM.delete f hm +deleteField _ _ = error "deleteField: not a record" + +modNatField :: T.Text -> (Natural -> Natural) -> GenR -> GenR +modNatField f g (GRec hm) = GRec $ HM.adjust underNat f hm + where underNat :: GenR -> GenR + underNat (GNat n) = GNat (g n) + underNat _ = error "modNatField: not a nat field" +modNatField _ _ _ = error "modNatField: not a record" + +-- * Double request + +awaitCallTwice :: HasAgentConfig => Blob -> GenR -> IO ReqResponse +awaitCallTwice cid req = do + req <- addNonce req + req <- addExpiry req + res <- envelopeFor (senderOf req) req >>= postCallCBOR cid + code202 res + res <- envelopeFor (senderOf req) req >>= postCallCBOR cid + code202 res + assertBool "Response body not empty" (BS.null (responseBody res)) + awaitStatus (getRequestStatus (senderOf req) cid (requestId req)) + + + +-- * CBOR decoding + +asCBORBlobList :: Blob -> IO [Blob] +asCBORBlobList blob = do + decoded <- asRight $ CBOR.decode blob + case decoded of + GList list -> mapM cborToBlob list + _ -> assertFailure $ "Failed to decode as CBOR encoded list of blobs: " <> show decoded + +cborToBlob :: GenR -> IO Blob +cborToBlob (GBlob blob) = return blob +cborToBlob r = assertFailure $ "Expected blob, got " <> show r + +asCBORBlobPairList :: Blob -> IO [(Blob, Blob)] +asCBORBlobPairList blob = do + decoded <- asRight $ CBOR.decode blob + case decoded of + GList list -> do + mapM cborToBlobPair list + _ -> assertFailure $ "Failed to decode as CBOR encoded list of blob pairs: " <> show decoded + +cborToBlobPair :: GenR -> IO (Blob, Blob) +cborToBlobPair (GList [GBlob x, GBlob y]) = return (x, y) +cborToBlobPair r = assertFailure $ "Expected list of pairs, got: " <> show r + +-- Interaction with aaaaa-aa via the universal canister + +ic00via :: HasAgentConfig => Blob -> IC00 +ic00via cid = ic00viaWithCycles cid 0 + +ic00viaWithCycles :: HasAgentConfig => Blob -> Word64 -> IC00 +ic00viaWithCycles cid cycles _ecid method_name arg = + do call' cid $ + callNew + (bytes "") (bytes (BS.fromStrict (T.encodeUtf8 method_name))) -- aaaaa-aa + (callback relayReply) (callback relayReject) >>> + callDataAppend (bytes arg) >>> + callCyclesAdd (int64 cycles) >>> + callPerform + >>= isReply >>= isRelay + +-- * Interacting with the universal canister + +-- Some common operations on the universal canister +-- The primed variant (call') return the response record, +-- e.g. to check for error conditions. +-- The unprimed variant expect a reply. + +install' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse +install' cid prog = do + universal_wasm <- getTestWasm "universal_canister" + ic_install' ic00 (enum #install) cid universal_wasm (run prog) + +installAt :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () +installAt cid prog = do + universal_wasm <- getTestWasm "universal_canister" + ic_install ic00 (enum #install) cid universal_wasm (run prog) + +-- Also calls create, used default 'ic00' +install :: (HasCallStack, HasAgentConfig) => Prog -> IO Blob +install prog = do + cid <- create + installAt cid prog + return cid + +create :: (HasCallStack, HasAgentConfig) => IO Blob +create = ic_provisional_create ic00 (Just (2^(60::Int))) empty + +upgrade' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse +upgrade' cid prog = do + universal_wasm <- getTestWasm "universal_canister" + ic_install' ic00 (enum #upgrade) cid universal_wasm (run prog) + +upgrade :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () +upgrade cid prog = do + universal_wasm <- getTestWasm "universal_canister" + ic_install ic00 (enum #upgrade) cid universal_wasm (run prog) + +reinstall' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse +reinstall' cid prog = do + universal_wasm <- getTestWasm "universal_canister" + ic_install' ic00 (enum #reinstall) cid universal_wasm (run prog) + +reinstall :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () +reinstall cid prog = do + universal_wasm <- getTestWasm "universal_canister" + ic_install ic00 (enum #reinstall) cid universal_wasm (run prog) + +callRequestAs :: (HasCallStack, HasAgentConfig) => Blob -> Blob -> Prog -> GenR +callRequestAs user cid prog = rec + [ "request_type" =: GText "call" + , "sender" =: GBlob user + , "canister_id" =: GBlob cid + , "method_name" =: GText "update" + , "arg" =: GBlob (run prog) + ] + +callToQueryRequestAs :: (HasCallStack, HasAgentConfig) => Blob -> Blob -> Prog -> GenR +callToQueryRequestAs user cid prog = rec + [ "request_type" =: GText "call" + , "sender" =: GBlob user + , "canister_id" =: GBlob cid + , "method_name" =: GText "query" + , "arg" =: GBlob (run prog) + ] + +callRequest :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> GenR +callRequest cid prog = callRequestAs defaultUser cid prog + +callToQuery'' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO (HTTPErrOr ReqResponse) +callToQuery'' cid prog = awaitCall' cid $ callToQueryRequestAs defaultUser cid prog + +stopRequest :: (HasCallStack, HasAgentConfig) => Blob -> GenR +stopRequest cid = rec + [ "request_type" =: GText "call" + , "sender" =: GBlob defaultUser + , "canister_id" =: GBlob "" + , "method_name" =: GText "stop_canister" + , "arg" =: GBlob (Candid.encode (#canister_id .== Principal cid)) + ] + +-- The following variants of the call combinator differ in how much failure they allow: +-- +-- call'' allows HTTP errors at `submit` time already +-- call' requires submission to succeed, and allows reject responses +-- call requires a reply response +-- call_ requires a reply response with an empty blob (a common case) + +call'' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO (HTTPErrOr ReqResponse) +call'' cid prog = awaitCall' cid (callRequest cid prog) + +call' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse +call' cid prog = call'' cid prog >>= is2xx + +call :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO Blob +call cid prog = call' cid prog >>= isReply + +call_ :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () +call_ cid prog = call cid prog >>= is "" + +callTwice' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse +callTwice' cid prog = awaitCallTwice cid (callRequest cid prog) + + +query' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse +query' cid prog = + queryCBOR cid >=> queryResponse $ rec + [ "request_type" =: GText "query" + , "sender" =: GBlob defaultUser + , "canister_id" =: GBlob cid + , "method_name" =: GText "query" + , "arg" =: GBlob (run prog) + ] + +query :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO Blob +query cid prog = query' cid prog >>= isReply + +query_ :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO () +query_ cid prog = query cid prog >>= is "" + +-- Predicates to handle the responses from relayReply and relayReject +isRelay :: HasCallStack => Blob -> IO ReqResponse +isRelay = runGet $ Get.getWord32le >>= \case + 0 -> Reply <$> Get.getRemainingLazyByteString + 0x4c444944 -> fail "Encountered Candid when expectin relayed data. Did you forget to use isRelay?" + c -> do + msg <- Get.getRemainingLazyByteString + return $ Reject (fromIntegral c) (T.decodeUtf8With T.lenientDecode (BS.toStrict msg)) Nothing + + +-- Shortcut for test cases that just need one canister. +simpleTestCase :: (HasCallStack, HasAgentConfig) => String -> (Blob -> IO ()) -> TestTree +simpleTestCase name act = testCase name $ install noop >>= act + +-- * Programmatic test generation + +-- | Runs test once for each field with that field removed, including nested +-- fields +omitFields :: GenR -> (GenR -> Assertion) -> [TestTree] +omitFields (GRec hm) act = + [ let hm' = HM.delete f hm + in testCase ("omitting " ++ T.unpack f) $ act (GRec hm') + | f <- fields + ] ++ concat + [ omitFields val $ \val' -> act (GRec (HM.insert f val' hm)) + | f <- fields + , val@(GRec _) <- return $ hm HM.! f + ] + where fields = sort $ HM.keys hm +omitFields _ _ = error "omitFields needs a GRec" + + +-- * Test data access + +getTestFile :: FilePath -> IO FilePath +getTestFile file = + lookupEnv "IC_TEST_DATA" >>= \case + Just fp -> return $ fp file + Nothing -> do + -- nix use + exePath <- getExecutablePath + let exeRelPath = takeDirectory exePath "../test-data" + -- convenient for cabal new-run use + try [ exeRelPath, "test-data", "../test-data", "impl/test-data" ] + where + try (d:ds) = doesFileExist (d file) >>= \case + True -> return (d file) + False -> try ds + try [] = error $ "getTestDir: Could not read " ++ file ++ " from test-data/. Please consult README.md" + +getTestWasm :: FilePath -> IO BS.ByteString +getTestWasm base = do + fp <- getTestFile $ base <.> "wasm" + BS.readFile fp + +-- * Helper patterns + +-- A barrier + +-- This will stop and start all mentioned canisters. This guarantees +-- that all outstanding callbacks are handled +barrier :: HasAgentConfig => [Blob] -> IO () +barrier cids = do + mapM_ (ic_stop_canister ic00) cids + mapM_ (ic_start_canister ic00) cids + + +-- A message hold +-- +-- This allows the test driver to withhold the response to a message, and +-- control when they are released, in order to produce situations with +-- outstanding call contexts. +-- +-- In an ideal world (from our pov), we could instrument and control the +-- system's scheduler this way, but we can't. So instead, we use some tricks. +-- Ideally, the details of this trick are irrelevant to the users of this +-- function (yay, abstraction), and if we find better tricks, we can swap them +-- out easily. We'll see if that holds water. +-- +-- One problem with this approach is that a test failure could mean that the +-- system doesn't pass the test, but it could also mean that the system has a +-- bug that prevents this trick from working, so take care. +-- +-- The current trick is: Create a canister (the "stopper"). Make it its own +-- controller. Tell the canister to stop itself. This call will now hang, +-- because a canister cannot stop itself. We can release the call (producing a +-- reject) by starting the canister again. +-- +-- Returns a program to be executed by any canister, which will cause this +-- canister to send a message that will not be responded to, until the given +-- IO action is performed. +createMessageHold :: HasAgentConfig => IO (Prog, IO ()) +createMessageHold = do + cid <- install noop + ic_set_controllers ic00 cid [defaultUser, cid] + let holdMessage = inter_update cid defArgs + { other_side = + callNew "" "stop_canister" (callback (trap "createMessageHold: stopping succeeded?")) (callback reply) >>> + callDataAppend (bytes (Candid.encode (#canister_id .== Principal cid))) >>> + callPerform + , on_reply = reply + } + let release = ic_start_canister ic00 cid + return (holdMessage, release) + +dummyResponse :: HttpResponse +dummyResponse = R.empty + .+ #status .== 202 + .+ #headers .== Vec.empty + .+ #body .== (toUtf8 "Dummy!")