diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..0fe5694 --- /dev/null +++ b/.envrc @@ -0,0 +1,6 @@ +# https://github.com/nix-community/nix-direnv A fast, persistent use_nix/use_flake implementation for direnv: +if ! has nix_direnv_version || ! nix_direnv_version 2.3.0; then + source_url "https://raw.githubusercontent.com/nix-community/nix-direnv/2.3.0/direnvrc" "sha256-Dmd+j63L84wuzgyjITIfSxSD57Tx7v51DMxVZOsiUD8=" +fi +# https://github.com/input-output-hk/devx Slightly opinionated shared GitHub Action for Cardano-Haskell projects +use flake "github:input-output-hk/devx?rev=2f4fa7f42aa1184ce1ed03f468f60648c466fa84#ghc96-iog" diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..e34911c --- /dev/null +++ b/.ghci @@ -0,0 +1,2 @@ +:set -Wunused-binds -Wunused-imports -Worphans +:set -isrc -itest diff --git a/.ghcid b/.ghcid new file mode 100644 index 0000000..e46612f --- /dev/null +++ b/.ghcid @@ -0,0 +1 @@ +--command="cabal repl test-suite:cem-sdk-test" -W -T ":main --failure-report=/tmp/hspec-report.txt -r" diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 0000000..319312c --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,73 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'cabal.project' +# +# And edited by Grisha A LOT +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.19.20240402 +# +# REGENDATA ("0.19.20240402",["github","cabal.project"]) +# +name: Haskell-CI +on: + - push +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-20.04 + timeout-minutes: + 60 + container: + image: buildpack-deps:bionic + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-9.6.3 + compilerKind: ghc + compilerVersion: 9.6.3 + setup-method: ghcup + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: checkout + uses: actions/checkout@v3 + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: cabal check + run: | + cd ${PKGDIR_cem_script} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: save cache + uses: actions/cache/save@v3 + if: always() + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store diff --git a/.gitignore b/.gitignore index 139083f..3765021 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,8 @@ cabal.project.local~ .HTF/ .ghc.environment.* .vscode +haddocks +.direnv/ +# Functions changed by runing local testnet +devnet/db +devnet/genesis-*.json diff --git a/.hlint.yaml b/.hlint.yaml index 6bceae7..217d5ff 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -9,3 +9,4 @@ - ignore: {name: Use unless} - ignore: {name: Use fmap} - ignore: {name: Use traverse_} +- ignore: {name: "Use asks"} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..a2d7a6f --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "cSpell.words": [ + "Fracada", + "POCRE", + "Serialised" + ] +} diff --git a/README.md b/README.md index 99f58eb..946f046 100644 --- a/README.md +++ b/README.md @@ -15,6 +15,40 @@ Define and reuse Cardano DApp logic via annotated CEM-machines, resulting in fre * Automatically testing invariants * Human-readable specs +## Building + +Building is performed with cabal. +Building requires `libblst` and `libsodium` installed. + +Arch Linux has `libblst` in AUR, nix are exemplified by IOHK, +and manual installation is described here: +https://github.com/input-output-hk/cardano-node-wiki/blob/main/docs/getting-started/install.md#installing-blst + +## Running tests + +Tests depend on localdevnet, which is runned in Docker. +To start it do: + +```bash +./prepare-devnet.sh +docker-compose -f docker-compose.devnet.yaml up +sudo chown -R $USER:$USER ./devnet/ +``` + +After that run: `cabal test`. + +For development and fast response once could consider `ghcid`. + +## Devnet stalling bug + +Sometimes devnet stalls, due to some bug, in that case one should restart it, +and wipe directory `./devnet/db`. To look for stalling one could check: +`CARDANO_NODE_SOCKET_PATH=./devnet/node.socket cardano-cli query tip --testnet-magic 42`. For properly working devnet slots should change +and sync be marked as 100%. + +On this bug: +https://forum.cardano.org/t/restarting-custom-private-networks-cardano-node-forge35/116921 + ## Project status Project is in early development stage and is funded by diff --git a/cabal.project b/cabal.project index aa85c7c..cdc297a 100644 --- a/cabal.project +++ b/cabal.project @@ -11,9 +11,31 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2023-11-03T12:09:05Z - , cardano-haskell-packages 2023-11-03T12:09:05Z + , hackage.haskell.org 2024-03-31T15:25:20Z + , cardano-haskell-packages 2024-03-30T16:14:24Z tests: true +allow-newer: + cardano-ledger-shelley-ma:base, + ouroboros-consensus-cardano:base, + +-- This is needed since prettyprinting stuff was moved to +-- cardano-ledger-test library which is no longer a subject +-- to be published on CHaP. +-- See discussion in https://github.com/IntersectMBO/cardano-ledger/pull/3973 +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: 6e2d37cc0f47bd02e89b4ce9f78b59c35c958e96 + --sha256: 6+Os/mQDzBOU+TkTD+n/T1MFcI+Mn0/tcBMJhLRfqyA= + subdir: + libs/cardano-ledger-test + +source-repository-package + type: git + location: https://github.com/mlabs-haskell/clb + tag: b0717b7a4e84796dbbd3db25f95230fdbf8b4651 + --sha256: 6+Os/mQDzBOU+TkTD+n/T1MFcI+Mn0/tcBMJhLRfqyA= + packages: . diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 0000000..3418c32 --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1,541 @@ +active-repositories: hackage.haskell.org:merge, cardano-haskell-packages:merge +constraints: any.Cabal ==3.10.1.0, + any.Cabal-syntax ==3.10.1.0, + any.Diff ==0.5, + any.FailT ==0.1.2.0, + any.Glob ==0.10.2, + any.HUnit ==1.6.2.0, + any.MemoTrie ==0.6.11, + MemoTrie -examples, + any.MonadRandom ==0.6, + any.OneTuple ==0.4.1.1, + any.Only ==0.1, + any.PyF ==0.11.2.1, + PyF -python_test, + any.QuickCheck ==2.14.3, + QuickCheck -old-random +templatehaskell, + any.StateVar ==1.2.2, + any.Stream ==0.4.7.2, + any.Unique ==0.4.7.9, + any.Win32-network ==0.1.1.1, + Win32-network -demo, + any.adjunctions ==4.4.2, + any.aeson ==2.2.1.0, + aeson +ordered-keymap, + any.aeson-pretty ==0.8.10, + aeson-pretty -lib-only, + any.algebraic-graphs ==0.7, + any.ansi-terminal ==1.0.2, + ansi-terminal -example, + any.ansi-terminal-types ==0.11.5, + any.ansi-wl-pprint ==0.6.9, + ansi-wl-pprint -example, + any.appar ==0.1.8, + any.array ==0.5.5.0, + any.asn1-encoding ==0.9.6, + any.asn1-parse ==0.9.5, + any.asn1-types ==0.3.4, + any.assoc ==1.1, + assoc +tagged, + any.async ==2.2.5, + async -bench, + any.attoparsec ==0.14.4, + attoparsec -developer, + any.attoparsec-aeson ==2.2.0.1, + any.auto-update ==0.1.6, + any.barbies ==2.1.1.0, + any.base ==4.18.1.0, + any.base-compat ==0.13.1, + any.base-compat-batteries ==0.13.1, + any.base-deriving-via ==0.1.0.2, + any.base-orphans ==0.9.1, + any.base16-bytestring ==1.0.2.0, + any.base58-bytestring ==0.1.0, + any.base64-bytestring ==1.2.1.0, + any.base64-bytestring-type ==1.0.1, + base64-bytestring-type +cereal +http-api-data +serialise, + any.basement ==0.0.16, + any.bech32 ==1.1.4.1, + bech32 -release -static, + any.bifunctors ==5.6.1, + bifunctors +tagged, + any.bimap ==0.5.0, + any.bin ==0.1.3, + any.binary ==0.8.9.1, + any.binary-orphans ==1.0.4.1, + any.bitvec ==1.1.5.0, + bitvec +simd, + any.blaze-builder ==0.4.2.3, + any.boring ==0.2.1, + boring +tagged, + any.brick ==2.3.1, + brick -demos, + any.byron-spec-chain ==1.0.0.2, + any.byron-spec-ledger ==1.0.0.2, + any.byteorder ==1.0.4, + any.bytestring ==0.11.5.2, + any.bytestring-builder ==0.10.8.2.0, + bytestring-builder +bytestring_has_builder, + any.bytestring-strict-builder ==0.4.5.7, + any.cabal-doctest ==1.0.9, + any.call-stack ==0.4.0, + any.canonical-json ==0.6.0.1, + any.cardano-api ==8.38.0.0, + any.cardano-binary ==1.7.1.0, + any.cardano-crypto ==1.1.2, + cardano-crypto -golden-tests -golden-tests-exe, + any.cardano-crypto-class ==2.1.4.0, + cardano-crypto-class +secp256k1-support, + any.cardano-crypto-praos ==2.1.2.0, + cardano-crypto-praos -external-libsodium-vrf, + any.cardano-crypto-test ==1.5.0.1, + any.cardano-crypto-tests ==2.1.2.0, + cardano-crypto-tests +secp256k1-support, + any.cardano-crypto-wrapper ==1.5.1.1, + any.cardano-data ==1.2.0.0, + any.cardano-git-rev ==0.1.3.0, + any.cardano-ledger-allegra ==1.3.0.0, + any.cardano-ledger-alonzo ==1.6.0.0, + any.cardano-ledger-alonzo-test ==1.2.0.0, + any.cardano-ledger-api ==1.8.0.0, + any.cardano-ledger-babbage ==1.6.0.0, + any.cardano-ledger-babbage-test ==1.2.0.0, + any.cardano-ledger-binary ==1.3.0.0, + any.cardano-ledger-byron ==1.0.0.4, + cardano-ledger-byron -test-normal-form, + any.cardano-ledger-byron-test ==1.5.0.1, + any.cardano-ledger-conway ==1.12.0.0, + cardano-ledger-conway -asserts, + any.cardano-ledger-conway-test ==1.2.1.3, + any.cardano-ledger-core ==1.10.0.0, + cardano-ledger-core -asserts, + any.cardano-ledger-mary ==1.5.0.0, + cardano-ledger-mary -asserts, + any.cardano-ledger-shelley ==1.9.0.0, + cardano-ledger-shelley -asserts, + any.cardano-ledger-shelley-ma-test ==1.2.1.6, + any.cardano-ledger-shelley-test ==1.3.0.1, + any.cardano-ledger-test ==9.9.9.9, + any.cardano-prelude ==0.1.0.4, + cardano-prelude -development, + any.cardano-prelude-test ==0.1.0.2, + cardano-prelude-test -development, + any.cardano-protocol-tpraos ==1.1.0.0, + any.cardano-slotting ==0.1.2.0, + any.cardano-strict-containers ==0.1.2.1, + any.case-insensitive ==1.2.1.0, + any.cassava ==0.5.3.0, + cassava -bytestring--lt-0_10_4, + any.cborg ==0.2.10.0, + cborg +optimize-gmp, + cem-script +dev, + any.cereal ==0.5.8.3, + cereal -bytestring-builder, + any.charset ==0.3.10, + clb -force-recomp, + any.clock ==0.8.4, + clock -llvm, + any.cmdargs ==0.10.22, + cmdargs +quotation -testprog, + any.code-page ==0.2.1, + any.colour ==2.3.6, + any.comonad ==5.0.8, + comonad +containers +distributive +indexed-traversable, + any.composition-prelude ==3.0.0.2, + composition-prelude -development, + any.concurrent-output ==1.10.20, + any.conduit ==1.3.5, + any.conduit-extra ==1.3.6, + any.config-ini ==0.2.7.0, + config-ini -enable-doctests, + any.constraints ==0.14, + any.constraints-extras ==0.4.0.0, + constraints-extras +build-readme, + any.containers ==0.6.7, + any.contra-tracer ==0.1.0.2, + any.contravariant ==1.5.5, + contravariant +semigroups +statevar +tagged, + any.cookie ==0.4.6, + any.criterion ==1.6.3.0, + criterion -embed-data-files -fast, + any.criterion-measurement ==0.2.1.0, + criterion-measurement -fast, + any.crypton ==0.34, + crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.crypton-connection ==0.3.2, + any.crypton-x509 ==1.7.6, + any.crypton-x509-store ==1.6.9, + any.crypton-x509-system ==1.6.7, + any.crypton-x509-validation ==1.6.12, + any.cryptonite ==0.30, + cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.data-clist ==0.2, + any.data-default ==0.7.1.1, + any.data-default-class ==0.1.2.0, + any.data-default-instances-containers ==0.0.1, + any.data-default-instances-dlist ==0.0.1, + any.data-default-instances-old-locale ==0.0.1, + any.data-fix ==0.3.2, + any.dec ==0.0.5, + any.deepseq ==1.4.8.1, + any.deferred-folds ==0.9.18.6, + any.dense-linear-algebra ==0.1.0.0, + any.dependent-map ==0.4.0.0, + any.dependent-sum ==0.7.2.0, + any.deque ==0.4.4.1, + any.deriving-aeson ==0.2.9, + any.deriving-compat ==0.6.5, + deriving-compat +base-4-9 +new-functor-classes +template-haskell-2-11, + any.dictionary-sharing ==0.1.0.0, + any.digest ==0.0.2.0, + digest -have_arm64_crc32c -have_builtin_prefetch -have_mm_prefetch -have_sse42 -have_strong_getauxval -have_weak_getauxval +pkg-config, + any.directory ==1.3.8.1, + any.distributive ==0.6.2.1, + distributive +semigroups +tagged, + any.dlist ==1.0, + dlist -werror, + any.dns ==4.2.0, + any.doctest ==0.22.2, + any.dom-lt ==0.2.3, + any.double-conversion ==2.0.4.2, + double-conversion -developer +embedded_double_conversion, + any.either ==5.0.2, + any.erf ==2.0.0.0, + any.errors ==2.3.0, + any.exceptions ==0.10.7, + any.extra ==1.7.14, + any.fgl ==5.8.2.0, + fgl +containers042, + any.file-embed ==0.0.16.0, + any.filelock ==0.1.1.7, + any.filepath ==1.4.100.4, + any.fin ==0.3, + any.fingertree ==0.1.5.0, + any.flat ==0.6, + any.foldl ==1.4.15, + any.formatting ==7.2.0, + formatting -no-double-conversion, + any.foundation ==0.0.30, + foundation -bench-all -bounds-check -doctest -experimental -linktest -minimal-deps, + any.free ==5.2, + any.fs-api ==0.2.0.1, + any.fs-sim ==0.2.1.1, + any.generic-random ==1.5.0.1, + generic-random -enable-inspect, + any.generically ==0.1.1, + any.generics-sop ==0.5.1.4, + any.genvalidity ==1.1.0.0, + any.ghc ==9.6.3, + any.ghc-bignum ==1.3, + any.ghc-boot ==9.6.3, + any.ghc-boot-th ==9.6.3, + any.ghc-heap ==9.6.3, + any.ghc-paths ==0.1.0.12, + any.ghc-prim ==0.10.0, + any.ghci ==9.6.3, + any.githash ==0.1.7.0, + any.graphviz ==2999.20.2.0, + graphviz -test-parsing, + any.groups ==0.5.3, + any.half ==0.3.1, + any.happy ==1.20.1.1, + any.hashable ==1.4.3.0, + hashable +integer-gmp -random-initial-seed, + any.haskeline ==0.8.2.1, + any.haskell-lexer ==1.1.1, + any.heapwords ==0.1.0.2, + any.hedgehog ==1.4, + any.hedgehog-extras ==0.6.0.2, + any.hedgehog-quickcheck ==0.1.1, + any.hourglass ==0.2.12, + any.hpc ==0.6.2.0, + any.hsc2hs ==0.68.10, + hsc2hs -in-ghc-tree, + any.hspec ==2.11.7, + any.hspec-core ==2.11.7, + any.hspec-discover ==2.11.7, + any.hspec-expectations ==0.8.4, + any.http-api-data ==0.6, + http-api-data -use-text-show, + any.http-client ==0.7.16, + http-client +network-uri, + any.http-client-tls ==0.3.6.3, + any.http-conduit ==2.3.8.3, + http-conduit +aeson, + any.http-types ==0.12.4, + any.indexed-traversable ==0.1.3, + any.indexed-traversable-instances ==0.1.1.2, + any.infinite-list ==0.1.1, + any.integer-conversion ==0.1.0.1, + any.integer-gmp ==1.1, + any.integer-logarithms ==1.0.3.1, + integer-logarithms -check-bounds +integer-gmp, + any.invariant ==0.6.2, + any.io-classes ==1.3.1.0, + io-classes -asserts, + any.io-classes-mtl ==0.1.0.3, + any.io-sim ==1.3.1.0, + io-sim -asserts, + any.iproute ==1.7.12, + any.isomorphism-class ==0.1.0.12, + any.js-chart ==2.9.4.1, + any.kan-extensions ==5.2.5, + any.lazy-search ==0.1.3.0, + any.lazysmallcheck ==0.6, + any.lens ==5.2.3, + lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, + any.libyaml ==0.1.2, + libyaml -no-unicode -system-libyaml, + any.lifted-async ==0.10.2.5, + any.lifted-base ==0.2.3.12, + any.list-t ==1.0.5.7, + any.logict ==0.8.1.0, + any.math-functions ==0.3.4.3, + math-functions +system-erf +system-expm1, + any.measures ==0.1.0.2, + any.megaparsec ==9.6.1, + megaparsec -dev, + any.memory ==0.18.0, + memory +support_bytestring +support_deepseq, + any.microlens ==0.4.13.1, + any.microlens-mtl ==0.2.0.3, + any.microlens-th ==0.4.3.14, + any.microstache ==1.0.2.3, + any.mime-types ==0.1.2.0, + any.mmorph ==1.2.0, + any.monad-control ==1.0.3.1, + any.mono-traversable ==1.0.15.3, + any.monoidal-containers ==0.6.4.0, + monoidal-containers +split-these, + any.monoidal-synchronisation ==0.1.0.5, + any.mtl ==2.3.1, + any.mtl-compat ==0.2.2, + mtl-compat -two-point-one -two-point-two, + any.multiset ==0.3.4.3, + any.mwc-random ==0.15.0.2, + any.network ==3.1.4.0, + network -devel, + any.network-mux ==0.4.5.0, + network-mux -ipv6 -tracetcpinfo, + any.network-uri ==2.6.4.2, + any.newtype ==0.2.2.0, + any.newtype-generics ==0.6.2, + any.non-integral ==1.0.0.0, + any.nonempty-vector ==0.2.3, + any.nothunks ==0.1.5, + nothunks +bytestring +text +vector, + any.old-locale ==1.0.0.7, + any.old-time ==1.1.0.4, + any.optparse-applicative ==0.18.1.0, + optparse-applicative +process, + any.optparse-applicative-fork ==0.18.1.0, + optparse-applicative-fork +process, + any.ordered-containers ==0.2.3, + any.ouroboros-consensus ==0.15.0.0, + ouroboros-consensus -asserts, + any.ouroboros-consensus-cardano ==0.13.0.0, + ouroboros-consensus-cardano -asserts, + any.ouroboros-consensus-diffusion ==0.10.0.0, + ouroboros-consensus-diffusion -asserts, + any.ouroboros-consensus-protocol ==0.7.0.0, + ouroboros-consensus-protocol -asserts, + any.ouroboros-network ==0.11.0.0, + ouroboros-network -asserts, + any.ouroboros-network-api ==0.6.3.0, + ouroboros-network-api -asserts, + any.ouroboros-network-framework ==0.11.0.0, + ouroboros-network-framework -ipv6, + any.ouroboros-network-mock ==0.1.1.1, + ouroboros-network-mock -asserts, + any.ouroboros-network-protocols ==0.7.0.0, + ouroboros-network-protocols -asserts +cddl, + any.ouroboros-network-testing ==0.5.0.0, + ouroboros-network-testing -nightly, + any.parallel ==3.2.2.0, + any.parsec ==3.1.16.1, + any.parser-combinators ==1.3.0, + parser-combinators -dev, + any.parsers ==0.12.11, + parsers +attoparsec +binary +parsec, + any.partial-order ==0.2.0.0, + partial-order +extra-instances, + any.pem ==0.2.4, + any.pipes ==4.3.16, + any.plutus-core ==1.21.0.0, + plutus-core -with-cert -with-inline-r, + any.plutus-ledger-api ==1.21.0.0, + any.plutus-tx ==1.21.0.0, + any.plutus-tx-plugin ==1.21.0.0, + plutus-tx-plugin -use-ghc-stub, + any.polyparse ==1.13, + any.pretty ==1.1.3.6, + any.pretty-show ==1.10, + any.pretty-simple ==4.1.2.0, + pretty-simple -buildexample +buildexe, + any.prettyprinter ==1.7.1, + prettyprinter -buildreadme +text, + any.prettyprinter-ansi-terminal ==1.1.3, + any.prettyprinter-configurable ==1.21.0.0, + any.primitive ==0.9.0.0, + any.process ==1.6.17.0, + any.profunctors ==5.6.2, + any.protolude ==0.3.4, + any.psqueues ==0.2.8.0, + any.quickcheck-dynamic ==3.3.1, + any.quickcheck-instances ==0.3.30, + quickcheck-instances -bytestring-builder, + any.quickcheck-io ==0.2.0, + any.quickcheck-state-machine ==0.9.0, + any.quickcheck-transformer ==0.3.1.2, + any.quiet ==0.2, + any.ral ==0.2.1, + ral +adjunctions +distributive +semigroupoids, + any.random ==1.2.1.2, + any.random-shuffle ==0.0.4, + any.recursion-schemes ==5.2.2.5, + recursion-schemes +template-haskell, + any.reflection ==2.1.7, + reflection -slow +template-haskell, + any.resourcet ==1.3.0, + any.retry ==0.9.3.1, + retry -lib-werror, + any.rts ==1.0.2, + any.safe ==0.3.21, + any.safe-exceptions ==0.1.7.4, + any.scientific ==0.3.7.0, + scientific -bytestring-builder -integer-simple, + any.selective ==0.5, + any.semialign ==1.3, + semialign +semigroupoids, + any.semigroupoids ==6.0.0.1, + semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, + any.semigroups ==0.20, + semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, + any.serialise ==0.2.6.1, + serialise +newtime15, + any.set-algebra ==1.1.0.2, + any.si-timers ==1.3.0.0, + si-timers -asserts, + any.singletons ==3.0.2, + any.singletons-th ==3.2, + any.size-based ==0.1.3.2, + any.small-steps ==1.0.1.0, + small-steps -sts_assert, + any.small-steps-test ==1.0.1.0, + any.socks ==0.6.1, + any.some ==1.0.6, + some +newtype-unsafe, + any.sop-core ==0.5.0.2, + any.sop-extras ==0.1.0.0, + any.split ==0.2.5, + any.splitmix ==0.1.0.5, + splitmix -optimised-mixer, + any.statistics ==0.16.2.1, + any.statistics-linreg ==0.3, + any.stm ==2.5.1.0, + any.streaming ==0.2.4.0, + any.streaming-binary ==0.3.0.1, + any.streaming-bytestring ==0.3.2, + any.streaming-commons ==0.2.2.6, + streaming-commons -use-bytestring-builder, + any.strict ==0.5, + any.strict-checked-vars ==0.2.0.0, + strict-checked-vars -checkmvarinvariants -checktvarinvariants, + any.strict-list ==0.1.7.4, + any.strict-mvar ==1.3.0.0, + any.strict-sop-core ==0.1.0.0, + any.strict-stm ==1.3.0.0, + strict-stm -asserts, + any.syb ==0.7.2.4, + any.system-cxx-std-lib ==1.0, + any.tagged ==0.8.8, + tagged +deepseq +transformers, + any.tar ==0.5.1.1, + tar -old-bytestring -old-time, + any.tasty ==1.5, + tasty +unix, + any.tasty-expected-failure ==0.12.3, + any.tasty-golden ==2.3.5, + tasty-golden -build-example, + any.tasty-hedgehog ==1.4.0.2, + any.tasty-hunit ==0.10.1, + any.tasty-quickcheck ==0.10.3, + any.template-haskell ==2.20.0.0, + any.temporary ==1.3, + any.terminal-size ==0.3.4, + any.terminfo ==0.4.1.6, + any.testing-type-modifiers ==0.1.0.1, + any.text ==2.0.2, + any.text-builder ==0.6.7.2, + any.text-builder-dev ==0.3.4.2, + any.text-iso8601 ==0.1, + any.text-short ==0.1.5, + text-short -asserts, + any.text-zipper ==0.13, + any.tf-random ==0.5, + any.th-abstraction ==0.6.0.0, + any.th-compat ==0.1.4, + any.th-desugar ==1.15, + any.th-expand-syns ==0.4.11.0, + any.th-lift ==0.8.4, + any.th-lift-instances ==0.1.20, + any.th-orphans ==0.13.14, + any.th-reify-many ==0.1.10, + any.th-utilities ==0.2.5.0, + any.these ==1.2, + any.time ==1.12.2, + any.time-compat ==1.9.6.1, + time-compat -old-locale, + any.tls ==1.9.0, + tls +compat -hans +network, + any.transformers ==0.6.1.0, + any.transformers-base ==0.4.6, + transformers-base +orphaninstances, + any.transformers-compat ==0.7.2, + transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, + any.transformers-except ==0.1.4, + any.tree-diff ==0.3.0.1, + any.type-equality ==1, + any.typed-process ==0.2.11.1, + any.typed-protocols ==0.1.1.0, + any.typed-protocols-cborg ==0.1.0.4, + any.typed-protocols-examples ==0.2.0.2, + any.unbounded-delays ==0.1.1.1, + any.uniplate ==1.6.13, + any.universe-base ==1.1.3.1, + any.unix ==2.8.1.0, + any.unix-bytestring ==0.4.0, + any.unix-compat ==0.7.1, + unix-compat -old-time, + any.unix-time ==0.4.12, + any.unliftio ==0.2.25.0, + any.unliftio-core ==0.2.1.0, + any.unordered-containers ==0.2.20, + unordered-containers -debug, + any.utf8-string ==1.0.2, + any.uuid-types ==1.0.5.1, + any.validation-selective ==0.2.0.0.0.0.0.0.1, + any.validity ==0.12.0.2, + any.vector ==0.13.1.0, + vector +boundschecks -internalchecks -unsafechecks -wall, + any.vector-algorithms ==0.9.0.1, + vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, + any.vector-binary-instances ==0.2.5.2, + any.vector-map ==1.1.0.0, + any.vector-stream ==0.1.0.1, + any.vector-th-unbox ==0.2.2, + any.void ==0.7.3, + void -safe, + any.vty ==6.0, + any.vty-crossplatform ==0.2.0.0, + vty-crossplatform -demos, + any.vty-unix ==0.1.0.0, + any.witherable ==0.4.2, + any.wl-pprint-annotated ==0.1.0.1, + any.wl-pprint-text ==1.2.0.2, + any.word-wrap ==0.5, + any.yaml ==0.11.11.2, + yaml +no-examples +no-exe, + any.zlib ==0.6.3.0, + zlib -bundled-c-zlib -non-blocking-ffi -pkg-config +index-state: cardano-haskell-packages 2024-02-06T15:25:20Z, hackage.haskell.org 2024-02-06T15:14:59Z diff --git a/cem-script.cabal b/cem-script.cabal index ba967ed..22630fe 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -5,9 +5,9 @@ synopsis: Cardano DApp SDK homepage: https://github.com/cem-script author: MLabs maintainer: gregory@mlabs.city -data-files: README.md +data-files: + README.md --- @todo #3 Reproduce `cabal repl` and HLS build on another (@adamczykm) computer tested-with: GHC ==9.6.3 flag dev @@ -21,10 +21,12 @@ common common-lang -- Options from MLabs styleguide ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints - -Wmissing-export-lists -Wmissing-deriving-strategies - -Wno-redundant-constraints + + -- -Wall + -- -Wcompat -Wincomplete-record-updates + -- -Wincomplete-uni-patterns -Wredundant-constraints + -- -Wmissing-export-lists -Wmissing-deriving-strategies + -- -Wno-redundant-constraints if !flag(dev) ghc-options: -Werror @@ -60,6 +62,7 @@ common common-lang MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude + NoPolyKinds NumericUnderscores OverloadedStrings PatternSynonyms @@ -76,6 +79,7 @@ common common-lang TypeOperators TypeSynonymInstances UndecidableInstances + ViewPatterns if flag(dev) default-extensions: PartialTypeSignatures @@ -85,12 +89,15 @@ common common-lang common common-onchain import: common-lang build-depends: + , plutus-core , plutus-ledger-api , plutus-tx , plutus-tx-plugin + , template-haskell >=2.20 + , th-abstraction >=0.6.0.0 - if flag(dev) - ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors + -- if flag(dev) + -- ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors -- Options for Plutus Tx compilations -- (some are enabled additionaly in individual modules) @@ -99,16 +106,28 @@ common common-onchain -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-specialize -fno-unbox-small-strict-fields - -fno-unbox-strict-fields + -fno-unbox-strict-fields -fno-full-laziness -fno-spec-constr + -fno-strictness -fno-unbox-small-strict-fields common common-offchain import: common-lang build-depends: + , aeson , bytestring , cardano-api + -- https://github.com/IntersectMBO/cardano-api/issues/502 + , cardano-api:{internal} + , cardano-crypto-class + , cardano-ledger-alonzo + , cardano-ledger-babbage , cardano-ledger-core + , cardano-ledger-shelley , containers , filepath + , ouroboros-consensus-cardano + , ouroboros-network-protocols + , pretty-show + , retry , text , time , unix @@ -117,6 +136,74 @@ common common-executable import: common-offchain ghc-options: -threaded -rtsopts -library cem-sdk - import: common-onchain +library data-spine + import: common-lang + hs-source-dirs: src-lib/data-spine + build-depends: + , singletons + , template-haskell + + exposed-modules: Data.Spine + +library cardano-extras + import: + common-offchain, + common-onchain + + hs-source-dirs: src-lib/cardano-extras + build-depends: template-haskell + exposed-modules: + Cardano.Extras + Plutus.Extras + +library + import: + common-onchain, + common-offchain + hs-source-dirs: src/ + exposed-modules: + Cardano.CEM + Cardano.CEM.Examples.Auction + Cardano.CEM.Examples.Compilation + Cardano.CEM.Examples.Voting + Cardano.CEM.Monads + Cardano.CEM.Monads.CLB + Cardano.CEM.Monads.L1 + Cardano.CEM.OnChain + Cardano.CEM.OffChain + Cardano.CEM.Stages + + other-modules: + Cardano.CEM.Monads.L1Commons + + build-depends: + , clb + , ouroboros-consensus + , cem-script:{cardano-extras, data-spine} + , dependent-map + , singletons-th + +test-suite cem-sdk-test + import: + common-onchain, + common-offchain, + + type: exitcode-stdio-1.0 + build-depends: + , cem-script:{cem-script, cardano-extras, data-spine} + , dependent-map + , hspec + , QuickCheck + , quickcheck-dynamic + , random + , clb + + hs-source-dirs: test/ + other-modules: + TestNFT + Voting + Auction + Utils + OffChain + main-is: Main.hs diff --git a/devnet/byron-delegate.key b/devnet/byron-delegate.key new file mode 100755 index 0000000..6693ec7 Binary files /dev/null and b/devnet/byron-delegate.key differ diff --git a/devnet/byron-delegation.cert b/devnet/byron-delegation.cert new file mode 100755 index 0000000..f29f3e5 --- /dev/null +++ b/devnet/byron-delegation.cert @@ -0,0 +1,8 @@ +{ "omega": 0 +, "issuerPk": + "NclXQiNNEpaaLdSxP3VFeOPIfSuFqBcNtmv8/7fftBKtgW1Aig7UqHJ/czsywkWFFVmBYPRnGjXspUl3wEMvuQ==" +, "delegatePk": + "24ejRK+kCDs1g4f3PcodFEUFVgNFWtfmuoEtVQf8/Ii2j2ruXHebJmZZPrwtAdbJYwDiSEvsHr95+BAF1ifGsA==" +, "cert": + "498c72e35ef30cd4657b48bfcc0a84a555a67981e3b6104a0d1708ab84510367d81e1ba3f47619565b1ee1098e31dcb8eb648d8030e061b568de113fdf3d6a09" +} \ No newline at end of file diff --git a/devnet/cardano-node.json b/devnet/cardano-node.json new file mode 100755 index 0000000..a594b1d --- /dev/null +++ b/devnet/cardano-node.json @@ -0,0 +1,80 @@ +{ + "Protocol": "Cardano", + + "ByronGenesisFile": "genesis-byron.json", + "ShelleyGenesisFile": "genesis-shelley.json", + "AlonzoGenesisFile": "genesis-alonzo.json", + "ConwayGenesisFile": "genesis-conway.json", + + "ApplicationName": "cardano-sl", + "ApplicationVersion": 1, + "MaxKnownMajorProtocolVersion": 2, + "LastKnownBlockVersion-Alt": 0, + "LastKnownBlockVersion-Major": 6, + "LastKnownBlockVersion-Minor": 0, + + "TestShelleyHardForkAtEpoch": 0, + "TestAllegraHardForkAtEpoch": 0, + "TestMaryHardForkAtEpoch": 0, + "TestAlonzoHardForkAtEpoch": 0, + "TestBabbageHardForkAtEpoch": 0, + + "RequiresNetworkMagic": "RequiresNoMagic", + + "minSeverity": "Info", + "defaultBackends": ["KatipBK"], + "defaultScribes": [[ "StdoutSK", "stdout" ]], + "setupBackends": ["KatipBK"], + "setupScribes": [ + { + "scFormat": "ScJson", + "scKind": "StdoutSK", + "scName": "stdout", + "scRotation": null + } + ], + + "TurnOnLogMetrics": true, + "TurnOnLogging": true, + + "TracingVerbosity": "NormalVerbosity", + "TraceBlockFetchClient": false, + "TraceBlockFetchDecisions": false, + "TraceBlockFetchProtocol": false, + "TraceBlockFetchProtocolSerialised": false, + "TraceBlockFetchServer": false, + "TraceChainDb": true, + "TraceChainSyncBlockServer": false, + "TraceChainSyncClient": false, + "TraceChainSyncHeaderServer": false, + "TraceChainSyncProtocol": false, + "TraceDNSResolver": false, + "TraceDNSSubscription": false, + "TraceErrorPolicy": false, + "TraceForge": true, + "TraceHandshake": false, + "TraceIpSubscription": false, + "TraceLocalChainSyncProtocol": true, + "TraceLocalErrorPolicy": false, + "TraceLocalHandshake": false, + "TraceLocalTxSubmissionProtocol": true, + "TraceLocalTxSubmissionServer": true, + "TraceMempool": true, + "TraceMux": false, + "TraceTxInbound": false, + "TraceTxOutbound": false, + "TraceTxSubmissionProtocol": false, + + "options": { + "mapBackends": { + "cardano.node.metrics": [ "EKGViewBK" ], + "cardano.node.resources": [ "EKGViewBK" ] + }, + "mapSubtrace": { + "cardano.node.metrics": { "subtrace": "Neutral" } + } + }, + + "ExperimentalHardForksEnabled": true, + "ExperimentalProtocolsEnabled": true +} diff --git a/devnet/credentials/alice.sk b/devnet/credentials/alice.sk new file mode 100755 index 0000000..83da192 --- /dev/null +++ b/devnet/credentials/alice.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "58204e1eaaad4ed0ab25c802b7dd90fc8e30001c88bb19dd04a0eea592050b80f35d" +} diff --git a/devnet/credentials/alice.vk b/devnet/credentials/alice.vk new file mode 100755 index 0000000..e471247 --- /dev/null +++ b/devnet/credentials/alice.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "", + "cborHex": "5820eb94e8236e2099357fa499bfbc415968691573f25ec77435b7949f5fdfaa5da0" +} diff --git a/devnet/credentials/bob.sk b/devnet/credentials/bob.sk new file mode 100755 index 0000000..06a3475 --- /dev/null +++ b/devnet/credentials/bob.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "5820258cb3f25a69b9a084bc36fed08fd66473ac6cb549ffa6dcb138bacbc74c3fa4" +} diff --git a/devnet/credentials/bob.vk b/devnet/credentials/bob.vk new file mode 100755 index 0000000..454aca6 --- /dev/null +++ b/devnet/credentials/bob.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "", + "cborHex": "5820fb1e80f6b5c0ef33d1b68215389d0ac836412a99edfac8bb203eb1d782342ab3" +} diff --git a/devnet/credentials/carol.sk b/devnet/credentials/carol.sk new file mode 100755 index 0000000..73449fe --- /dev/null +++ b/devnet/credentials/carol.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "5820bdbe4654a6afa701a52ffb1b020df118c82bafe8dc4670b218a3c903fcfbc5ac" +} diff --git a/devnet/credentials/carol.vk b/devnet/credentials/carol.vk new file mode 100755 index 0000000..d5070a4 --- /dev/null +++ b/devnet/credentials/carol.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820e48471a0e6711b566ae3607582dfa1e79dacfadaa41682673c91cec014907904" +} diff --git a/devnet/credentials/dave.sk b/devnet/credentials/dave.sk new file mode 100755 index 0000000..b165850 --- /dev/null +++ b/devnet/credentials/dave.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "58207db5f1648fad2d8582ccfb66b5a5d9e010d42a71307eedb8c65b4517ac52795d" +} diff --git a/devnet/credentials/dave.vk b/devnet/credentials/dave.vk new file mode 100755 index 0000000..c091b51 --- /dev/null +++ b/devnet/credentials/dave.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820cacd56e031dbfafbd2bef50d4b9caf9d7692176d306b4cb84178577005ed4e97" +} diff --git a/devnet/credentials/eve.sk b/devnet/credentials/eve.sk new file mode 100755 index 0000000..ea19ab7 --- /dev/null +++ b/devnet/credentials/eve.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "58204529a253925e55cb2bfb1fc7c7114e0d7c2b3f5e08011ef54391517d06240bb4" +} diff --git a/devnet/credentials/eve.vk b/devnet/credentials/eve.vk new file mode 100755 index 0000000..b680927 --- /dev/null +++ b/devnet/credentials/eve.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820bbb3a08d51be1a2cc91be884229dc3dc2931e3dba1258949af80d12c26fb6cb0" +} diff --git a/devnet/credentials/faucet.sk b/devnet/credentials/faucet.sk new file mode 100755 index 0000000..cb6f8c5 --- /dev/null +++ b/devnet/credentials/faucet.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "5820a5e4238b67ebb1108c52a01ac850bbce82c915d77bad94331892f3edf612883c" +} diff --git a/devnet/credentials/faucet.vk b/devnet/credentials/faucet.vk new file mode 100755 index 0000000..db53a30 --- /dev/null +++ b/devnet/credentials/faucet.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820ce13cd433cdcb3dfb00c04e216956aeb622dcd7f282b03304d9fc9de804723b2" +} diff --git a/devnet/credentials/frank.sk b/devnet/credentials/frank.sk new file mode 100755 index 0000000..64e96cf --- /dev/null +++ b/devnet/credentials/frank.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "5820340f665de8379c78f85a6eb602e7a7eca7128d9bfb7648d9e58b4a573d570ad0" +} diff --git a/devnet/credentials/frank.vk b/devnet/credentials/frank.vk new file mode 100755 index 0000000..4789405 --- /dev/null +++ b/devnet/credentials/frank.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "582035dcf854ecc46f7b7c4f05c4874b7764fd41785b7e90d076e3a3997206d5111e" +} diff --git a/devnet/credentials/grace.sk b/devnet/credentials/grace.sk new file mode 100755 index 0000000..2c1bd48 --- /dev/null +++ b/devnet/credentials/grace.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "58207a7bcafaebfb720fc99243996aed09c6d2997421c345ef9dccb19680c733da53" +} diff --git a/devnet/credentials/grace.vk b/devnet/credentials/grace.vk new file mode 100755 index 0000000..2849273 --- /dev/null +++ b/devnet/credentials/grace.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "58206cdc42ad53ca773b6bd96494e9c51572d0da4af239f44ba409017036d00db696" +} diff --git a/devnet/credentials/hans.sk b/devnet/credentials/hans.sk new file mode 100755 index 0000000..bd11ef0 --- /dev/null +++ b/devnet/credentials/hans.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "5820142f6a86f25c24146b8a3e51485623b9ccfeea38b37cb1a3859fe21d6bafdbe9" +} diff --git a/devnet/credentials/hans.vk b/devnet/credentials/hans.vk new file mode 100755 index 0000000..065b616 --- /dev/null +++ b/devnet/credentials/hans.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "58200ddb89a6749a4f551b217171e3494e61617486a545da591b87baa18ceeaa9d09" +} diff --git a/devnet/credentials/oscar.sk b/devnet/credentials/oscar.sk new file mode 100755 index 0000000..0d57319 --- /dev/null +++ b/devnet/credentials/oscar.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "58207a77fe23b2b1722809efb8e3eac5fd24cc3a26e3edc3ab13f3b08b9014cfedca" +} diff --git a/devnet/credentials/oscar.vk b/devnet/credentials/oscar.vk new file mode 100755 index 0000000..1c78eb6 --- /dev/null +++ b/devnet/credentials/oscar.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820e122239580c539cd211ed1bd789a9b4b3dfdf69cff82dd1a8e79bd73442e339c" +} diff --git a/devnet/credentials/patricia.sk b/devnet/credentials/patricia.sk new file mode 100755 index 0000000..5377a36 --- /dev/null +++ b/devnet/credentials/patricia.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "5820fd09f3cf43f8e7385c9a6438f8ac6f47b1d0f02adf1f0fbca64ca2ac0f1d1f19" +} diff --git a/devnet/credentials/patricia.vk b/devnet/credentials/patricia.vk new file mode 100755 index 0000000..330f1fb --- /dev/null +++ b/devnet/credentials/patricia.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820d3d83751be4871fe7facfc72d3ad264fdf2076893cdb6469b0e801bd53dda3cc" +} diff --git a/devnet/credentials/rupert.sk b/devnet/credentials/rupert.sk new file mode 100755 index 0000000..087bf41 --- /dev/null +++ b/devnet/credentials/rupert.sk @@ -0,0 +1,5 @@ +{ + "type": "PaymentSigningKeyShelley_ed25519", + "description": "Payment Signing Key", + "cborHex": "58203e7b9ae23641c6d4dd35b03658046ef261663a54b20aa187f9ff15b1e1166724" +} diff --git a/devnet/credentials/rupert.vk b/devnet/credentials/rupert.vk new file mode 100755 index 0000000..2632cec --- /dev/null +++ b/devnet/credentials/rupert.vk @@ -0,0 +1,5 @@ +{ + "type": "PaymentVerificationKeyShelley_ed25519", + "description": "Payment Verification Key", + "cborHex": "5820c0c6cd22f94798e42e2dddce8ba029050e703815e0739db0d13963c1663686b6" +} diff --git a/devnet/genesis-alonzo.json b/devnet/genesis-alonzo.json new file mode 100755 index 0000000..ccc9b42 --- /dev/null +++ b/devnet/genesis-alonzo.json @@ -0,0 +1,365 @@ +{ + "collateralPercentage": 150, + "costModels": { + "PlutusV1": [ + 205665, + 812, + 1, + 1, + 1000, + 571, + 0, + 1, + 1000, + 24177, + 4, + 1, + 1000, + 32, + 117366, + 10475, + 4, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 100, + 100, + 23000, + 100, + 19537, + 32, + 175354, + 32, + 46417, + 4, + 221973, + 511, + 0, + 1, + 89141, + 32, + 497525, + 14068, + 4, + 2, + 196500, + 453240, + 220, + 0, + 1, + 1, + 1000, + 28662, + 4, + 2, + 245000, + 216773, + 62, + 1, + 1060367, + 12586, + 1, + 208512, + 421, + 1, + 187000, + 1000, + 52998, + 1, + 80436, + 32, + 43249, + 32, + 1000, + 32, + 80556, + 1, + 57667, + 4, + 1000, + 10, + 197145, + 156, + 1, + 197145, + 156, + 1, + 204924, + 473, + 1, + 208896, + 511, + 1, + 52467, + 32, + 64832, + 32, + 65493, + 32, + 22558, + 32, + 16563, + 32, + 76511, + 32, + 196500, + 453240, + 220, + 0, + 1, + 1, + 69522, + 11687, + 0, + 1, + 60091, + 32, + 196500, + 453240, + 220, + 0, + 1, + 1, + 196500, + 453240, + 220, + 0, + 1, + 1, + 806990, + 30482, + 4, + 1927926, + 82523, + 4, + 265318, + 0, + 4, + 0, + 85931, + 32, + 205665, + 812, + 1, + 1, + 41182, + 32, + 212342, + 32, + 31220, + 32, + 32696, + 32, + 43357, + 32, + 32247, + 32, + 38314, + 32, + 57996947, + 18975, + 10 + ], + "PlutusV2": [ + 205665, + 812, + 1, + 1, + 1000, + 571, + 0, + 1, + 1000, + 24177, + 4, + 1, + 1000, + 32, + 117366, + 10475, + 4, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 100, + 100, + 23000, + 100, + 19537, + 32, + 175354, + 32, + 46417, + 4, + 221973, + 511, + 0, + 1, + 89141, + 32, + 497525, + 14068, + 4, + 2, + 196500, + 453240, + 220, + 0, + 1, + 1, + 1000, + 28662, + 4, + 2, + 245000, + 216773, + 62, + 1, + 1060367, + 12586, + 1, + 208512, + 421, + 1, + 187000, + 1000, + 52998, + 1, + 80436, + 32, + 43249, + 32, + 1000, + 32, + 80556, + 1, + 57667, + 4, + 1000, + 10, + 197145, + 156, + 1, + 197145, + 156, + 1, + 204924, + 473, + 1, + 208896, + 511, + 1, + 52467, + 32, + 64832, + 32, + 65493, + 32, + 22558, + 32, + 16563, + 32, + 76511, + 32, + 196500, + 453240, + 220, + 0, + 1, + 1, + 69522, + 11687, + 0, + 1, + 60091, + 32, + 196500, + 453240, + 220, + 0, + 1, + 1, + 196500, + 453240, + 220, + 0, + 1, + 1, + 1159724, + 392670, + 0, + 2, + 806990, + 30482, + 4, + 1927926, + 82523, + 4, + 265318, + 0, + 4, + 0, + 85931, + 32, + 205665, + 812, + 1, + 1, + 41182, + 32, + 212342, + 32, + 31220, + 32, + 32696, + 32, + 43357, + 32, + 32247, + 32, + 38314, + 32, + 35892428, + 10, + 57996947, + 18975, + 10, + 38887044, + 32947, + 10 + ] + }, + "executionPrices": { + "prMem": 5.77e-2, + "prSteps": 7.21e-5 + }, + "lovelacePerUTxOWord": 34482, + "maxBlockExUnits": { + "exUnitsMem": 62000000, + "exUnitsSteps": 40000000000 + }, + "maxCollateralInputs": 3, + "maxTxExUnits": { + "exUnitsMem": 14000000, + "exUnitsSteps": 10000000000 + }, + "maxValueSize": 5000 +} diff --git a/devnet/genesis-conway.json b/devnet/genesis-conway.json new file mode 100755 index 0000000..5bad6d5 --- /dev/null +++ b/devnet/genesis-conway.json @@ -0,0 +1,38 @@ +{ + "genDelegs": {}, + "poolVotingThresholds": { + "pvtCommitteeNormal": 0.51, + "pvtCommitteeNoConfidence": 0.51, + "pvtHardForkInitiation": 0.51, + "pvtMotionNoConfidence": 0.51 + }, + "dRepVotingThresholds": { + "dvtMotionNoConfidence": 0.51, + "dvtCommitteeNormal": 0.51, + "dvtCommitteeNoConfidence": 0.51, + "dvtUpdateToConstitution": 0.51, + "dvtHardForkInitiation": 0.51, + "dvtPPNetworkGroup": 0.51, + "dvtPPEconomicGroup": 0.51, + "dvtPPTechnicalGroup": 0.51, + "dvtPPGovGroup": 0.51, + "dvtTreasuryWithdrawal": 0.51 + }, + "committeeMinSize": 0, + "committeeMaxTermLength": 200, + "govActionLifetime": 10, + "govActionDeposit": 1000000000, + "dRepDeposit": 2000000, + "dRepActivity": 20, + "constitution": { + "anchor": { + "url": "", + "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" + } + }, + "committee": { + "members": { + }, + "quorum": 0 + } +} diff --git a/devnet/kes.skey b/devnet/kes.skey new file mode 100755 index 0000000..8711a55 --- /dev/null +++ b/devnet/kes.skey @@ -0,0 +1,5 @@ +{ + "type": "KesSigningKey_ed25519_kes_2^6", + "description": "KES Signing Key", + "cborHex": "590260a199f16b11da6c7f5c1e0f1eb0b9bbe278d3d8f35bfd50d0951c2ff94d0344cd57df5f64c9bac1dd60b4482f9c636168f40737d526625a2ec82f22ec0c72de0013f86ef743a7bba0286db6ddf3d85bf8e49ddbf14d9d3b7ee22f4857c77b740948f84f2e72f6bcf91f405e34ea50a2c53fa4876b43cfce2bcfe87c06a903de8bb33d968ca7930b67d0c23f5cb2d74e422d773ba80e388de384691000d6ba8a9b4dc7d3187f76048fbef9a52b72d80d835bb76eced7c0e0cdc5b58869b73c095dffa01db4ff51765afcead565395a5ed1cf74e5f2134d61076fece21aacd080bbbfaab94125401d7bbc74eafc7e7e3a2235f59dc03d6e332e53d558493a1e22213b92c77b1328ff1b83855da704fc366bf4415490602481d1939136eeaf252c65184912a779d9d94a90e32b72c1877ef60b6d79e707ce5a762acb4bed46436efe4fe62aae50b39068cc508a09427c92791cbcbea44318529cc68d297ca24e1b73b2394c385ec63fcd85ed56eec3de48860a1ec950aad4f91cbf741dbd7bf1d3c278875bd20e31ff5372339f6aa5280ad9b8bf3514889ac44600fe57ca0b535d6dc6b0b981e079595aad186ee0be9b07e837391ab165e4ca406601c876a86e246a3f53311e21199cccc0b080f28d18f4dc6987731e10e4ade00df7c6921c5ef3022b6f49a29ba307a2c8f4bd2ba42fcfa0aad68a2f0ad31fff69a99d3471f9036d3f5817a3edfeff7fc3c14e1151d767aaa043481cfd1a6ee55e8e5d7853ecdaf9da2bb36c716beae8d706bc648a790d4697e1d044a11a49f305ab8bc64a094bd81bda7395fe6f77dd5557c39919dd9bb9cf22a87fe47408ae3ec2247007d015a5" +} diff --git a/devnet/opcert.cert b/devnet/opcert.cert new file mode 100755 index 0000000..2ae24e0 --- /dev/null +++ b/devnet/opcert.cert @@ -0,0 +1,5 @@ +{ + "type": "NodeOperationalCertificate", + "description": "", + "cborHex": "828458204cd49bb05e9885142fe7af1481107995298771fd1a24e72b506a4d600ee2b3120000584089fc9e9f551b2ea873bf31643659d049152d5c8e8de86be4056370bccc5fa62dd12e3f152f1664e614763e46eaa7a17ed366b5cef19958773d1ab96941442e0b58205a3d778e76741a009e29d23093cfe046131808d34d7c864967b515e98dfc3583" +} diff --git a/devnet/protocol-parameters.json b/devnet/protocol-parameters.json new file mode 100755 index 0000000..d055422 --- /dev/null +++ b/devnet/protocol-parameters.json @@ -0,0 +1 @@ +{"collateralPercentage":150,"costModels":{"PlutusV2":[205665,812,1,1,1000,571,0,1,1000,24177,4,1,1000,32,117366,10475,4,23000,100,23000,100,23000,100,23000,100,23000,100,23000,100,100,100,23000,100,19537,32,175354,32,46417,4,221973,511,0,1,89141,32,497525,14068,4,2,196500,453240,220,0,1,1,1000,28662,4,2,245000,216773,62,1,1060367,12586,1,208512,421,1,187000,1000,52998,1,80436,32,43249,32,1000,32,80556,1,57667,4,1000,10,197145,156,1,197145,156,1,204924,473,1,208896,511,1,52467,32,64832,32,65493,32,22558,32,16563,32,76511,32,196500,453240,220,0,1,1,69522,11687,0,1,60091,32,196500,453240,220,0,1,1,196500,453240,220,0,1,1,1159724,392670,0,2,806990,30482,4,1927926,82523,4,265318,0,4,0,85931,32,205665,812,1,1,41182,32,212342,32,31220,32,32696,32,43357,32,32247,32,38314,32,35892428,10,57996947,18975,10,38887044,32947,10]},"decentralization":null,"executionUnitPrices":{"priceMemory":5.77e-2,"priceSteps":7.21e-5},"extraPraosEntropy":null,"maxBlockBodySize":0,"maxBlockExecutionUnits":{"memory":62000000,"steps":40000000000},"maxBlockHeaderSize":0,"maxCollateralInputs":5,"maxTxExecutionUnits":{"memory":14000000,"steps":10000000000},"maxTxSize":16384,"maxValueSize":1000000000,"minPoolCost":0,"minUTxOValue":null,"monetaryExpansion":0,"poolPledgeInfluence":0,"poolRetireMaxEpoch":0,"protocolVersion":{"major":8,"minor":0},"stakeAddressDeposit":0,"stakePoolDeposit":0,"stakePoolTargetNum":100,"treasuryCut":0,"txFeeFixed":155381,"txFeePerByte":44,"utxoCostPerByte":0,"utxoCostPerWord":null} diff --git a/devnet/topology.json b/devnet/topology.json new file mode 100755 index 0000000..5e8e3c5 --- /dev/null +++ b/devnet/topology.json @@ -0,0 +1 @@ +{"Producers": []} diff --git a/devnet/vrf.skey b/devnet/vrf.skey new file mode 100755 index 0000000..5133967 --- /dev/null +++ b/devnet/vrf.skey @@ -0,0 +1,5 @@ +{ + "type": "VrfSigningKey_PraosVRF", + "description": "VRF Signing Key", + "cborHex": "5840899795b70e9f34b737159fe21a6170568d6031e187f0cc84555c712b7c29b45cb882007593ef70f86e5c0948561a3b8e8851529a4f98975f2b24e768dda38ce2" +} diff --git a/docker-compose.devnet.yaml b/docker-compose.devnet.yaml new file mode 100644 index 0000000..e8015ad --- /dev/null +++ b/docker-compose.devnet.yaml @@ -0,0 +1,20 @@ +services: + cardano-node-devnet: + image: ghcr.io/input-output-hk/cardano-node:8.7.3 + volumes: + - ./devnet:/devnet + environment: + - CARDANO_BLOCK_PRODUCER=true + - CARDANO_SOCKET_PATH=/devnet/node.socket # used by cardano-node + - CARDANO_NODE_SOCKET_PATH=/devnet/node.socket # used by cardano-cli + command: + [ "run" + , "--config", "/devnet/cardano-node.json" + , "--topology", "/devnet/topology.json" + , "--database-path", "/devnet/db" + , "--shelley-kes-key", "/devnet/kes.skey" + , "--shelley-vrf-key", "/devnet/vrf.skey" + , "--shelley-operational-certificate", "/devnet/opcert.cert" + , "--byron-delegation-certificate", "/devnet/byron-delegation.cert" + , "--byron-signing-key", "/devnet/byron-delegate.key" + ] diff --git a/docs/backends_comparsion.md b/docs/backends_comparsion.md new file mode 100644 index 0000000..ea55b0a --- /dev/null +++ b/docs/backends_comparsion.md @@ -0,0 +1,61 @@ +# Comparsion + +## Common + +* Production readiness and performance +* Possibility of integration + +## Аггрегация + +* Вопросы + * Где фильтровать +* Критерии + * Нужный код: генерация фильтров, реакция и запросы + * Сценарии: active utxo, реакция DApp и хранение в БД + * Estimates на метрики производительности + * Критерии: production-readiness, скорость, API simplicity, re-indexing +* Фильтрации вид + * Никто не провайдит DSL (Carp/Oura умеют not fully documented Rust/Deno, visitorn) + * Kupo - address, policy id or output reference +* Kupo + * https://github.com/CardanoSolutions/kupo#alternatives + +# Backends + +## On-chain + +* Plutus +* Plutarch + +## Off-chain and testing + +* Monads over cardano-api from Hydra Auction +* Crooked-validators, mutation solutions from Hydra project + +## BMC backends + +### Haskell fuzzing + +* quickcheck-dynamic +* quickcheck-lockstep (?) + +### Haskell BMC + +* SBV + +### Non-Haskell BMC + +* Kind 2 + * Used for Djed. +* NuSMV + * Was explored in pre-smart-contract era by + "Model Checking Contracts – A Case Study" work. + https://link.springer.com/chapter/10.1007/978-3-540-75596-8_8 + * For Ethereum by "Model-Checking of Smart Contracts" + https://hal.science/hal-02103511/file/Nehai-Piriou-Daumas%20V18_03_09.pdf +* ESBMC + * Used by ESBMC-Solidity +* TLA+ +* Procella/SPIN +* Uppaal + diff --git a/docs/examples.md b/docs/examples.md new file mode 100644 index 0000000..4ee2bf6 --- /dev/null +++ b/docs/examples.md @@ -0,0 +1,16 @@ +# Standard evaluation examples + +We chose known simple DApps, +having a reference implementation as models. + +This helps to evaluate DX by comparing +our implementation with our API to reference one. + +* Guessing game + * https://plutus-apps.readthedocs.io/en/latest/plutus/tutorials/contract-testing.html#an-overview-of-the-guessing-game +* Hydra Auction +* POCRE + +# Other examples + +* ... diff --git a/prepare-devnet.sh b/prepare-devnet.sh new file mode 100755 index 0000000..7c75e8b --- /dev/null +++ b/prepare-devnet.sh @@ -0,0 +1,4 @@ +TARGETDIR=devnet +sed -i "s/\"startTime\": [0-9]*/\"startTime\": $(date +%s)/" "$TARGETDIR/genesis-byron.json" && \ +sed -i "s/\"systemStart\": \".*\"/\"systemStart\": \"$(date -u +%FT%TZ)\"/" "$TARGETDIR/genesis-shelley.json" +sudo chown -R $USER:$USER ./devnet/ diff --git a/src-lib/cardano-extras/Cardano/Extras.hs b/src-lib/cardano-extras/Cardano/Extras.hs new file mode 100644 index 0000000..93e47ce --- /dev/null +++ b/src-lib/cardano-extras/Cardano/Extras.hs @@ -0,0 +1,305 @@ +{- | Various utils to cope with `cardano-api` types +Mainly stolen from `hydra-cardano-api` and some from `atlas` +-} +module Cardano.Extras where + +import Prelude + +import Data.Aeson qualified as Aeson +import Data.Word (Word64) + +import PlutusLedgerApi.V1.Address (Address (..), pubKeyHashAddress) +import PlutusLedgerApi.V1.Credential ( + Credential (..), + StakingCredential (..), + ) +import PlutusLedgerApi.V1.Crypto (PubKeyHash (..)) + +import Cardano.Api ( + AddressAny (..), + AddressInEra (..), + AddressTypeInEra (..), + AsType (..), + AssetId (..), + AssetName (..), + BabbageEra, + BabbageEraOnwards (BabbageEraOnwardsBabbage, BabbageEraOnwardsConway), + BuildTx, + BuildTxWith (..), + ConsensusModeParams (..), + EpochSlots (EpochSlots), + ExecutionUnits (..), + HasTypeProxy (AsType), + HashableScriptData, + IsScriptWitnessInCtx (..), + IsShelleyBasedEra (..), + Key (..), + KeyWitnessInCtx (..), + NetworkId (..), + PaymentKey, + PlutusScript, + PolicyId (..), + Quantity (..), + ScriptDatum (..), + ScriptRedeemer, + ScriptWitness (..), + SigningKey (..), + TextEnvelopeError (TextEnvelopeAesonDecodeError), + TxIn, + TxMintValue (..), + TxOut (..), + TxOutDatum (..), + UTxO (unUTxO), + Value, + WitCtxTxIn, + Witness (..), + deserialiseFromTextEnvelope, + txOutValueToValue, + unsafeHashableScriptData, + valueFromList, + verificationKeyHash, + ) +import Cardano.Api qualified as Cardano +import Cardano.Api.Byron (Hash (..)) +import Cardano.Api.Ledger (StandardCrypto) +import Cardano.Api.Shelley (PlutusScriptOrReferenceInput (..), fromPlutusData, fromShelleyAddrIsSbe) +import Cardano.Crypto.Hash.Class qualified as CC +import Cardano.Ledger.Address qualified as Ledger +import Cardano.Ledger.Babbage qualified as Ledger +import Cardano.Ledger.BaseTypes qualified as Ledger +import Cardano.Ledger.Credential qualified as Ledger +import Cardano.Ledger.Hashes qualified as Ledger +import Cardano.Ledger.Keys qualified as Ledger +import Cardano.Ledger.Plutus.TxInfo qualified as Ledger +import Data.Bifunctor (Bifunctor (..)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Map (elems) +import Data.Map qualified as Map +import PlutusLedgerApi.V1 qualified as Plutus +import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), flattenValue) +import PlutusLedgerApi.V2 (ScriptHash (..), ToData (..), adaSymbol, adaToken, toData) +import PlutusTx.Builtins.Class (FromBuiltin (..)) + +-- Common + +type Era = BabbageEra +type LedgerEra = Ledger.BabbageEra StandardCrypto + +type PlutusLang = Cardano.PlutusScriptV2 + +plutusLang :: Cardano.PlutusScriptVersion PlutusLang +plutusLang = Cardano.PlutusScriptV2 + +plutusLangInEra :: + Cardano.ScriptLanguageInEra PlutusLang Era +plutusLangInEra = Cardano.PlutusScriptV2InBabbage + +-- | Orphan Instances +instance (Show Cardano.LedgerEpochInfo) where + show _ = "LedgerEpochInfo (Church-encoded)" + +deriving stock instance (Eq (SigningKey PaymentKey)) + +instance Semigroup (Cardano.TxOutValue Era) where + (Cardano.TxOutValueShelleyBased era x) <> (Cardano.TxOutValueShelleyBased _era y) = + Cardano.TxOutValueShelleyBased era (x <> y) + (Cardano.TxOutValueByron {}) <> _ = error "pre-Shelley era TxOut is not supported" + _ <> (Cardano.TxOutValueByron {}) = error "pre-Shelley era TxOut is not supported" + +instance Monoid (Cardano.TxOutValue Era) where + mempty = Cardano.TxOutValueShelleyBased shelleyBasedEra mempty + +-- | Parsing + +{- | Interpret some raw 'ByteString' as a particular 'Hash'. + +NOTE: This throws if byte string has a length different that the expected +target digest length. +-} +unsafeHashFromBytes :: + (CC.HashAlgorithm hash) => + ByteString -> + CC.Hash hash a +unsafeHashFromBytes bytes = + case CC.hashFromBytes bytes of + Nothing -> + error $ "unsafeHashFromBytes: failed to convert hash: " <> show bytes + Just h -> + h + +parseSigningKeyTE :: ByteString -> Maybe (SigningKey PaymentKey) +parseSigningKeyTE bs = do + let res = + first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict bs) + >>= deserialiseFromTextEnvelope asSigningKey + case res of + Left _ -> Nothing + Right key -> Just key + where + asSigningKey :: AsType (SigningKey PaymentKey) + asSigningKey = AsSigningKey AsPaymentKey + +-- | Conversions +toPlutusKeyHash :: Hash PaymentKey -> PubKeyHash +toPlutusKeyHash (PaymentKeyHash vkh) = Ledger.transKeyHash vkh + +signingKeyToPKH :: SigningKey PaymentKey -> PubKeyHash +signingKeyToPKH = toPlutusKeyHash . verificationKeyHash . getVerificationKey + +signingKeyToAddress :: SigningKey PaymentKey -> Address +signingKeyToAddress = pubKeyHashAddress . signingKeyToPKH + +fromPlutusAddress :: NetworkId -> Address -> AddressInEra Era +fromPlutusAddress networkId plutusAddress = + fromShelleyAddrIsSbe @Era shelleyBasedEra $ + case (addressCredential, addressStakingCredential) of + (cred, Just (StakingHash stakeCred)) -> + Ledger.Addr network (unsafeCredential cred) . Ledger.StakeRefBase $ unsafeCredential stakeCred + (cred, Just (StakingPtr slot txix certix)) -> + Ledger.Addr network (unsafeCredential cred) . Ledger.StakeRefPtr $ + Ledger.Ptr + (fromInteger slot) + (Ledger.TxIx $ fromInteger txix) + (Ledger.CertIx $ fromInteger certix) + (cred, Nothing) -> + Ledger.Addr network (unsafeCredential cred) Ledger.StakeRefNull + where + network = case networkId of + Testnet _ -> Ledger.Testnet + Mainnet -> Ledger.Mainnet + unsafeCredential = \case + PubKeyCredential (PubKeyHash h) -> + Ledger.KeyHashObj . Ledger.KeyHash . unsafeHashFromBytes $ fromBuiltin h + ScriptCredential (ScriptHash h) -> + Ledger.ScriptHashObj . Ledger.ScriptHash . unsafeHashFromBytes $ fromBuiltin h + + Address {addressCredential, addressStakingCredential} = plutusAddress + +addressInEraToAny :: AddressInEra Era -> AddressAny +addressInEraToAny (AddressInEra ByronAddressInAnyEra a) = AddressByron a +addressInEraToAny (AddressInEra (ShelleyAddressInEra _) a) = AddressShelley a + +{- | Unsafe wrap some bytes as a 'ScriptHash', relying on the fact that Plutus +is using Blake2b_224 for hashing data (according to 'cardano-ledger'). + +Pre-condition: the input bytestring MUST be of length 28. +-} +unsafeScriptHashFromBytes :: + ByteString -> + Cardano.ScriptHash +unsafeScriptHashFromBytes bytes + | BS.length bytes /= 28 = + error $ "unsafeScriptHashFromBytes: pre-condition failed: " <> show (BS.length bytes) <> " bytes." + | otherwise = + Cardano.ScriptHash + . Ledger.ScriptHash + $ unsafeHashFromBytes bytes + +-- | Convert a plutus 'CurrencySymbol' into a cardano-api 'PolicyId'. +fromPlutusCurrencySymbol :: CurrencySymbol -> PolicyId +fromPlutusCurrencySymbol = PolicyId . unsafeScriptHashFromBytes . fromBuiltin . unCurrencySymbol + +-- | Convert a plutus 'Value' into a cardano-api 'Value'. +fromPlutusValue :: Plutus.Value -> Value +fromPlutusValue plutusValue = + valueFromList $ map convertAsset $ flattenValue plutusValue + where + convertAsset (cs, tk, i) + | cs == adaSymbol && tk == adaToken = (AdaAssetId, Quantity i) + | otherwise = (AssetId (fromPlutusCurrencySymbol cs) (toAssetName tk), Quantity i) + + -- toAssetName :: Plutus.TokenName -> AssetName + toAssetName = AssetName . fromBuiltin . unTokenName + +-- | Tx and other stuff construction +type TxInWitness = BuildTxWith BuildTx (Witness WitCtxTxIn Era) + +-- | Attaching mark meaning "TxIn would be witnessed by signing key" +withKeyWitness :: + TxIn -> (TxIn, TxInWitness) +withKeyWitness txIn = + (txIn, BuildTxWith $ KeyWitness KeyWitnessForSpending) + +mkInlineDatum :: (ToData datum) => datum -> TxOutDatum ctx Era +mkInlineDatum x = + TxOutDatumInline BabbageEraOnwardsBabbage $ + unsafeHashableScriptData $ + fromPlutusData $ + toData $ + toBuiltinData x + +{- | Construct a full script witness from a datum, a redeemer and a full +'PlutusScript'. That witness has no execution budget. +-} +mkScriptWitness :: + forall ctx. + PlutusScript PlutusLang -> + ScriptDatum ctx -> + ScriptRedeemer -> + ScriptWitness ctx Era +mkScriptWitness script datum redeemer = + PlutusScriptWitness + plutusLangInEra + plutusLang + (PScript script) + datum + redeemer + (ExecutionUnits 0 0) + +toScriptData :: (ToData a) => a -> HashableScriptData +toScriptData = unsafeHashableScriptData . fromPlutusData . toData + +tokenToAsset :: TokenName -> AssetName +tokenToAsset (TokenName t) = AssetName $ fromBuiltin t + +mkInlinedDatumScriptWitness :: + (ToData a) => + PlutusScript PlutusLang -> + a -> + BuildTxWith BuildTx (Witness WitCtxTxIn Era) +mkInlinedDatumScriptWitness script redeemer = + BuildTxWith $ + ScriptWitness scriptWitnessInCtx $ + mkScriptWitness + script + InlineScriptDatum + (toScriptData redeemer) + +mintedTokens :: + (ToData redeemer) => + PlutusScript PlutusLang -> + redeemer -> + [(AssetName, Quantity)] -> + Cardano.TxMintValue BuildTx Era +mintedTokens script redeemer assets = + -- FIXME: is hardcoding era correct? + TxMintValue Cardano.MaryEraOnwardsBabbage mintedTokens' mintedWitnesses' + where + mintedTokens' = valueFromList (fmap (first (AssetId policyId)) assets) + mintedWitnesses' = + BuildTxWith $ Map.singleton policyId mintingWitness + mintingWitness :: ScriptWitness Cardano.WitCtxMint Era + mintingWitness = + mkScriptWitness script NoScriptDatumForMint (toScriptData redeemer) + policyId = + PolicyId $ Cardano.hashScript $ Cardano.PlutusScript plutusLang script + +-- | Fields +txOutValue :: TxOut ctx Era -> Value +txOutValue (TxOut _ value _ _) = txOutValueToValue value + +mTxOutDatum :: TxOut ctx Era -> Maybe HashableScriptData +mTxOutDatum (TxOut _ _ (TxOutDatumInline _ d) _) = Just d +mTxOutDatum _ = Nothing + +utxoValue :: UTxO Era -> Value +utxoValue utxo = foldMap txOutValue $ elems $ unUTxO utxo + +-- | Constants +cardanoModeParams :: ConsensusModeParams +cardanoModeParams = CardanoModeParams $ EpochSlots defaultByronEpochSlots + where + -- NOTE(AB): extracted from Parsers in cardano-cli, this is needed to run in 'cardanoMode' which + -- is the default for cardano-cli + defaultByronEpochSlots = 21600 :: Word64 diff --git a/src-lib/cardano-extras/Plutus/Deriving.hs b/src-lib/cardano-extras/Plutus/Deriving.hs new file mode 100644 index 0000000..c97caab --- /dev/null +++ b/src-lib/cardano-extras/Plutus/Deriving.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- | + Module: PlutusTx.Deriving + Copyright: (C) MLabs 2021 + License: Apache 2.0 + Maintainer: Koz Ross + Portability: GHC only + Stability: Experimental + + Taken from here temporarily: + https://github.com/Liqwid-Labs/plutus-extra/blob/master/ + plutus-deriving/src/PlutusTx/Deriving.hs +-} +module Plutus.Deriving (deriveEq) where + +import Prelude + +import Control.Monad (replicateM) +import Language.Haskell.TH ( + Body (NormalB), + Clause (Clause), + Con ( + ForallC, + GadtC, + InfixC, + NormalC, + RecC, + RecGadtC + ), + Dec ( + DataD, + FunD, + InstanceD, + NewtypeD, + PragmaD + ), + Exp (ConE, UInfixE, VarE), + Info (TyConI), + Inline (Inlinable), + Name, + Pat (ConP, VarP, WildP), + Phases (AllPhases), + Pragma (InlineP), + Q, + RuleMatch (FunLike), + TyVarBndr (KindedTV, PlainTV), + Type (AppT, ConT, VarT), + nameBase, + newName, + reify, + ) +import PlutusTx.Prelude qualified as PTx + +{- | Generates a lawful 'PTx.Eq' instance for the type named by the input. This + instance will obey the following laws: + + * Reflexivity (for any @x@, @x == x = True@) + * Symmetry (for any @x, y@, @x == y = y PTx.== x@) + * Transitivity (for any @x, y, z@, if @x == y@ and @y == z@, then @x == z@) + * Substitution (for any @x, y@ and pure @f@, @x == y@ implies @f x == f y@) + + @since 1.0 +-} +deriveEq :: Name -> Q [Dec] +deriveEq name = do + info <- reify name + case info of + TyConI (DataD _ name' tyVars _ constructors _) -> + mkEq name' tyVars constructors + TyConI (NewtypeD _ name' tyVars _ constructor _) -> + mkEq name' tyVars [constructor] + _ -> error $ nameBase name <> " is not a data or newtype-defined type." + +-- Helpers + +mkEq :: Name -> [TyVarBndr _] -> [Con] -> Q [Dec] +mkEq name tyVars constructors = do + let namePreds = mkCtxVar <$> tyVars + let instanceType = mkInstanceType name (fst <$> namePreds) + method <- mkEqMethod constructors + pure [InstanceD Nothing (snd <$> namePreds) instanceType method] + +mkCtxVar :: TyVarBndr _ -> (Name, Type) +mkCtxVar = \case + PlainTV name -> (name, go name) + KindedTV name _ -> (name, go name) + where + go :: Name -> Type + go = AppT (ConT ''PTx.Eq) . VarT + +mkInstanceType :: Name -> [Name] -> Type +mkInstanceType typeName = AppT (ConT ''PTx.Eq) . foldr go (ConT typeName) + where + go :: Name -> Type -> Type + go varName acc = AppT acc (VarT varName) + +mkEqMethod :: [Con] -> Q [Dec] +mkEqMethod constructors = do + let methodInlineable = PragmaD . InlineP '(PTx.==) Inlinable FunLike $ AllPhases + funDef <- + FunD '(PTx.==) <$> case constructors of + [] -> error "Cannot generate Eq for a type with no constructors." + _ -> do + activeClauses <- traverse mkConstructorMatch constructors + let catchAllClause = + Clause + [WildP, WildP] + (NormalB . ConE $ 'PTx.False) + [] + pure $ activeClauses <> [catchAllClause] + pure [methodInlineable, funDef] + +mkConstructorMatch :: Con -> Q Clause +mkConstructorMatch = \case + NormalC name vars -> go name . length $ vars + RecC name vars -> go name . length $ vars + InfixC {} -> + error "Cannot generate Eq for types with infix constructors." + ForallC {} -> + error "Cannot generate Eq for types with existentials." + GadtC {} -> + error "Cannot generate Eq for GADTs." + RecGadtC {} -> + error "Cannot generate Eq for GADTs." + where + go :: Name -> Int -> Q Clause + go name count = do + namesLeft <- replicateM count (newName "x") + namesRight <- replicateM count (newName "y") + let leftPat = ConP name . fmap VarP $ namesLeft + let rightPat = ConP name . fmap VarP $ namesRight + let bod = NormalB $ case zip namesLeft namesRight of + [] -> ConE 'PTx.True + (lName, rName) : names -> + foldr + andEq + (UInfixE (VarE lName) (VarE '(PTx.==)) (VarE rName)) + names + pure . Clause [leftPat, rightPat] bod $ [] + +andEq :: (Name, Name) -> Exp -> Exp +andEq (lName, rName) = + UInfixE (UInfixE (VarE lName) (VarE '(PTx.==)) (VarE rName)) (VarE '(PTx.&&)) diff --git a/src-lib/cardano-extras/Plutus/Extras.hs b/src-lib/cardano-extras/Plutus/Extras.hs new file mode 100644 index 0000000..d8ba06f --- /dev/null +++ b/src-lib/cardano-extras/Plutus/Extras.hs @@ -0,0 +1,52 @@ +module Plutus.Extras where + +import PlutusTx.Prelude + +import Cardano.Api ( + PlutusScriptVersion (..), + Script (..), + SerialiseAsRawBytes (serialiseToRawBytes), + hashScript, + ) +import Cardano.Api.Shelley (PlutusScript (..)) +import PlutusLedgerApi.Common (SerialisedScript) +import PlutusLedgerApi.V2 (ScriptHash (..), UnsafeFromData (..)) + +import Cardano.Extras +import PlutusLedgerApi.V1.Value (CurrencySymbol (..)) + +-- | Signature of an untyped validator script. +type ValidatorType = BuiltinData -> BuiltinData -> BuiltinData -> () + +{- | Wrap a typed validator to get the basic `ValidatorType` signature which can +be passed to `PlutusTx.compile`. +REVIEW: There might be better ways to name this than "wrap" +-} +wrapValidator :: + (UnsafeFromData datum, UnsafeFromData redeemer, UnsafeFromData context) => + (datum -> redeemer -> context -> Bool) -> + ValidatorType +wrapValidator f d r c = + check $ f datum redeemer context + where + datum = unsafeFromBuiltinData d + redeemer = unsafeFromBuiltinData r + context = unsafeFromBuiltinData c +{-# INLINEABLE wrapValidator #-} + +{- | Compute the on-chain 'ScriptHash' for a given serialised plutus script. Use +this to refer to another validator script. +-} +scriptValidatorHash :: SerialisedScript -> ScriptHash +scriptValidatorHash = + ScriptHash + . toBuiltin + . serialiseToRawBytes + . hashScript + . PlutusScript plutusLang + . PlutusScriptSerialised @PlutusLang + +scriptCurrencySymbol :: SerialisedScript -> CurrencySymbol +scriptCurrencySymbol script = + case scriptValidatorHash script of + ScriptHash hash -> CurrencySymbol hash diff --git a/src-lib/data-spine/Data/Spine.hs b/src-lib/data-spine/Data/Spine.hs new file mode 100644 index 0000000..b1bc50a --- /dev/null +++ b/src-lib/data-spine/Data/Spine.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE PolyKinds #-} + +module Data.Spine where + +import Prelude + +import Control.Monad +import Control.Monad.Reader (MonadReader (..)) +import GHC.Records +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Data.Singletons + +-- | Definitions + +{- | Spine is datatype, which tags constructors of ADT. +| TH deriving utility generates Spines, which are Enums, +| but one could introduce more complex Spine datatypes manually. +-} +class + ( Ord (Spine sop) + ) => + HasSpine sop + where + type Spine sop + getSpine :: sop -> Spine sop + +-- instance (SingI sop1, SingI sop2) => SingI (sop1, sop2) where + +instance (HasSpine sop1, HasSpine sop2) => HasSpine (sop1, sop2) where + type Spine (sop1, sop2) = (Spine sop1, Spine sop2) + getSpine (d1, d2) = (getSpine d1, getSpine d2) + +-- TODO: mkOfSpine, using Sing + +-- | Newtype encoding sop value of fixed known spine +newtype OfSpine (x :: Spine datatype) = UnsafeMkOfSpine {getValue :: datatype} + +-- matchOfSpine :: sop -> ... +-- matchOfSpineDMap :: sop -> DMap Spine (OfSpine -> a) +-- mkOfSpine :: sop -> Some .. OfSpine + +-- TODO: move to module + +{- | This class has same behaviour as `MonadReader` storing some record. +| The difference is that you may not have real record stored. +-} +class (Monad m) => MonadRecord record m where + askField :: forall label a. (HasField label record a) => m a + default askField :: + forall label a. + (MonadReader record m, HasField label record a) => + m a + askField = getField @label <$> ask @record + +-- | Deriving utils +addSuffix :: Name -> String -> Name +addSuffix (Name (OccName name) flavour) suffix = + Name (OccName $ name <> suffix) flavour + +reifyDatatype :: Name -> Q (Name, [Name]) +reifyDatatype ty = do + (TyConI tyCon) <- reify ty + (name, cs :: [Con]) <- + case tyCon of + DataD _ n _ _ cs _ -> pure (n, cs) + NewtypeD _ n _ _ cs _ -> pure (n, [cs]) + _ -> fail "deriveTags: only 'data' and 'newtype' are supported" + csNames <- mapM consName cs + return (name, csNames) + +consName :: (MonadFail m) => Con -> m Name +consName cons = + case cons of + NormalC n _ -> return n + RecC n _ -> return n + _ -> fail "deriveTags: constructor names must be NormalC or RecC (See https://hackage.haskell.org/package/template-haskell-2.20.0.0/docs/src/Language.Haskell.TH.Syntax.html#Con)" + +deriveTags :: Name -> String -> [Name] -> Q [Dec] +deriveTags ty suff classes = do + (tyName, csNames) <- reifyDatatype ty + -- XXX: Quasi-quote splice does not work for case matches list + let cs = map (\name -> NormalC (addSuffix name suff) []) csNames + v = + DataD [] (addSuffix tyName suff) [] Nothing cs [DerivClause (Just StockStrategy) (ConT <$> classes)] + pure [v] + +deriveMapping :: Name -> String -> Q Exp +deriveMapping ty suff = do + (tyName, csNames) <- reifyDatatype ty + -- XXX: Quasi-quote splice does not work for case matches list + let + matches = + map + (\name -> Match (RecP name []) (NormalB (ConE (addSuffix name suff))) []) + csNames + return $ LamCaseE matches + +{- | Derives `HasSpine` +| Usage: `$(deriveSpine ''HydraEvent)` +-} +deriveSpine :: Name -> Q [Dec] +deriveSpine name = do + info <- reify name + let + suffix = "Spine" + spineName = addSuffix name suffix + spineTypeQ = reifyType spineName + spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum] + -- TODO: derive Sing + -- TODO: derive HasField (OfSpine ...) + + decls <- + [d| + instance HasSpine $(conT name) where + type Spine $(conT name) = $(conT spineName) + getSpine = $(deriveMapping name suffix) + |] + return $ spineDec <> decls diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs new file mode 100644 index 0000000..d3315d8 --- /dev/null +++ b/src/Cardano/CEM.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM where + +import PlutusTx.Prelude +import Prelude (Show) +import Prelude qualified + +import Data.Data (Proxy) +import Data.Map qualified as Map + +-- Plutus imports +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V2 ( + ToData (..), + Value, + fromData, + ) +import PlutusTx.Show.TH (deriveShow) + +-- Project imports +import Cardano.CEM.Stages +import Data.Spine + +-- | This is different ways to specify address +data AddressSpec + = ByAddress Address + | ByPubKey PubKeyHash + | ByScript -- TODO + | BySameScript + deriving stock (Show, Prelude.Eq) + +{-# INLINEABLE addressSpecToAddress #-} +addressSpecToAddress :: Address -> AddressSpec -> Address +addressSpecToAddress ownAddress addressSpec = case addressSpec of + ByAddress address -> address + ByPubKey pubKey -> pubKeyHashAddress pubKey + BySameScript -> ownAddress + +data TxFanFilter script = MkTxFanFilter + { address :: AddressSpec + , rest :: TxFanFilter' script + } + deriving stock (Show, Prelude.Eq) + +data TxFanFilter' script + = Anything + | -- | To be used via `bySameCem` + UnsafeBySameCEM BuiltinData + | ByDatum BuiltinData + deriving stock (Show, Prelude.Eq) + +{-# INLINEABLE bySameCEM #-} + +-- | Constraint enforcing state of script mentioning this constraint +bySameCEM :: + (ToData (State script), CEMScript script) => + State script -> + TxFanFilter' script +bySameCEM = UnsafeBySameCEM . toBuiltinData + +-- TODO: use natural numbers +data Quantor = Exist Integer | SumValueEq Value + deriving stock (Show) + +data TxFanKind = In | InRef | Out + deriving stock (Prelude.Eq, Prelude.Show) + +data TxFanConstraint script = MkTxFanC + { txFanCKind :: TxFanKind + , txFanCFilter :: TxFanFilter script + , txFanCQuantor :: Quantor + } + deriving (Show) + +-- Main API + +class + ( HasSpine (Transition script) + , HasSpine (State script) + , Stages (Stage script) + ) => + CEMScript script + where + -- | `Params` is immutable part of script Datum, + -- | it should be used to encode all + type Params script = params | params -> script + + -- | `Stage` is datatype encoding all `Interval`s specified by script. + -- | `Stage` logic is encoded by separate `Stages` type class. + -- | It have separate `StageParams` datatype, + -- | which is stored immutable in script Datum as well. + type Stage script + + -- | `State` is changing part of script Datum. + -- | It is in + type State script = params | params -> script + + -- | Transitions for deterministic CEM-machine + type Transition script = transition | transition -> script + + -- | Each kind of Transition has statically associated Stage and State spine + transitionStage :: + Proxy script -> + Map.Map + (Spine (Transition script)) + (Stage script, Maybe (Spine (State script))) + + -- This functions define domain logic + transitionSpec :: + Params script -> + Maybe (State script) -> + Transition script -> + Either BuiltinString (TransitionSpec script) + +data TransitionSpec script = MkTransitionSpec + { constraints :: [TxFanConstraint script] + , signers :: [PubKeyHash] + } + deriving (Show) + +{- | Static part of CEMScript datum. +Datatype is actually used only by off-chain code due to Plutus limitations. +-} +data CEMParams script = MkCEMParams + { scriptParams :: Params script + , stagesParams :: StageParams (Stage script) + } + +deriving stock instance + ( Show (Params script) + , (Show (StageParams (Stage script))) + ) => + (Show (CEMParams script)) + +deriving stock instance + ( Prelude.Eq (Params script) + , (Prelude.Eq (StageParams (Stage script))) + ) => + (Prelude.Eq (CEMParams script)) + +-- TODO: doc +type CEMScriptDatum script = + (StageParams (Stage script), Params script, State script) + +-- TH deriving done at end of file for GHC staging reasons + +deriveShow ''TxFanKind +deriveShow ''TxFanFilter' diff --git a/src/Cardano/CEM/Constraints.hs b/src/Cardano/CEM/Constraints.hs new file mode 100644 index 0000000..4b5c6d1 --- /dev/null +++ b/src/Cardano/CEM/Constraints.hs @@ -0,0 +1,74 @@ +module Cardano.CEM.Constraints where + +import Prelude + + +import PlutusTx.IsData (toData) +import PlutusTx.Prelude +import Prelude (Show) +import Prelude qualified + +import Data.Data (Proxy) +import Data.Map qualified as Map + +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V2 ( + BuiltinData (..), + Data (..), + FromData (..), + ToData (..), + Value, + fromData, + ) +import PlutusTx.Show.TH (deriveShow) + +import Cardano.CEM.Stages ( Stages(..) ) + + +-- | This is different ways to specify address +data AddressSpec + = ByAddress Address + | ByPubKey PubKeyHash + | ByScript -- TODO + | BySameScript + deriving stock (Show, Prelude.Eq) + +{-# INLINEABLE addressSpecToAddress #-} +addressSpecToAddress :: Address -> AddressSpec -> Address +addressSpecToAddress ownAddress addressSpec = case addressSpec of + ByAddress address -> address + ByPubKey pubKey -> pubKeyHashAddress pubKey + BySameScript -> ownAddress + +data TxFanFilter script = MkTxFanFilter + { address :: AddressSpec + , rest :: TxFanFilter' script + } + deriving stock (Show, Prelude.Eq) + +data TxFanFilter' script + = Anything + | -- TODO + BySameCEM BuiltinData + | ByDatum BuiltinData + deriving stock (Show, Prelude.Eq) + +-- TODO: use natural numbers +data Quantor = Exist Integer | SumValueEq Value + deriving stock (Show) + +data TxFanKind = In | InRef | Out + deriving stock (Prelude.Eq, Prelude.Show) + +data TxFanConstraint script = MkTxFanC + { txFanCKind :: TxFanKind + , txFanCFilter :: TxFanFilter script + , txFanCQuantor :: Quantor + } + deriving (Show) + +-- TH deriving done at end of file for GHC staging reasons + +deriveShow ''TxFanKind +deriveShow ''TxFanFilter' diff --git a/src/Cardano/CEM/Examples.hs b/src/Cardano/CEM/Examples.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs new file mode 100644 index 0000000..71005e1 --- /dev/null +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.Examples.Auction where + +import PlutusTx.Prelude +import Prelude qualified + +import Data.Data (Proxy (..)) +import Data.Map qualified as Map + +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Interval qualified as Interval +import PlutusLedgerApi.V1.Time (POSIXTime) +import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), singleton) +import PlutusLedgerApi.V2 (Address, ToData, Value) +import PlutusTx qualified +import PlutusTx.Show.TH (deriveShow) + +import Cardano.CEM +import Cardano.CEM.Stages +import Data.Spine + +-- Simple no-deposit auction + +data SimpleAuction + +data Bid = MkBet + { better :: PubKeyHash + , betAmount :: Integer + } + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionStage = Open | Closed + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionStageParams + = NoControl + | CanCloseAt POSIXTime + deriving stock (Prelude.Eq, Prelude.Show) + +instance Stages SimpleAuctionStage where + type StageParams SimpleAuctionStage = SimpleAuctionStageParams + stageToOnChainInterval NoControl _ = Interval.always + -- Example: logical error + stageToOnChainInterval (CanCloseAt time) Open = Interval.to time + stageToOnChainInterval (CanCloseAt time) Closed = Interval.from time + +data SimpleAuctionState + = NotStarted + | CurrentBid Bid + | Winner Bid + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionParams = MkAuctionParams + { seller :: PubKeyHash + , lot :: Value + } + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionTransition + = Create + | Start + | MakeBid Bid + | Close + | Buyout + deriving stock (Prelude.Eq, Prelude.Show) + +PlutusTx.unstableMakeIsData ''Bid +PlutusTx.unstableMakeIsData 'MkAuctionParams +PlutusTx.unstableMakeIsData 'NotStarted +PlutusTx.unstableMakeIsData 'MakeBid +PlutusTx.unstableMakeIsData ''SimpleAuctionStage +PlutusTx.unstableMakeIsData ''SimpleAuctionStageParams +deriveShow ''SimpleAuction + +deriveSpine ''SimpleAuctionTransition +deriveSpine ''SimpleAuctionState + +instance CEMScript SimpleAuction where + type Stage SimpleAuction = SimpleAuctionStage + type Params SimpleAuction = SimpleAuctionParams + + type State SimpleAuction = SimpleAuctionState + + type Transition SimpleAuction = SimpleAuctionTransition + + transitionStage Proxy = + Map.fromList + [ (CreateSpine, (Open, Nothing)) + , (StartSpine, (Open, Just NotStartedSpine)) + , (MakeBidSpine, (Open, Just CurrentBidSpine)) + , (CloseSpine, (Closed, Just CurrentBidSpine)) + , (BuyoutSpine, (Closed, Just WinnerSpine)) + ] + + {-# INLINEABLE transitionSpec #-} + transitionSpec params state transition = case (state, transition) of + (Nothing, Create) -> + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC + In + (MkTxFanFilter (ByPubKey $ seller params) Anything) + (SumValueEq $ lot params) + , nextState NotStarted + ] + , signers = [seller params] + } + (Just NotStarted, Start) -> + Right + $ MkTransitionSpec + { constraints = [nextState (CurrentBid initialBid)] + , signers = [seller params] + } + (Just (CurrentBid currentBet), MakeBid newBet) -> + -- Example: could be parametrized with param or typeclass + if betAmount newBet > betAmount currentBet + then + Right + $ MkTransitionSpec + { constraints = [nextState (CurrentBid newBet)] + , signers = [better newBet] + } + else Left "Wrong Bid amount" + (Just (CurrentBid currentBet), Close) -> + Right + $ MkTransitionSpec + { constraints = [nextState (Winner currentBet)] + , signers = [seller params] + } + (Just (Winner winnerBet), Buyout {}) -> + Right + $ MkTransitionSpec + { constraints = + [ -- Example: In constraints redundant for on-chain + MkTxFanC + In + (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) + (SumValueEq $ betAdaValue winnerBet) + , MkTxFanC + Out + (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) + (SumValueEq $ lot params) + , MkTxFanC + Out + (MkTxFanFilter (ByPubKey (seller params)) Anything) + (SumValueEq $ betAdaValue winnerBet) + ] + , signers = [better winnerBet] + } + _ -> Left "Incorrect state for transition" + where + initialBid = MkBet (seller params) 0 + nextState state = + MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM state)) + (SumValueEq $ lot params) + betAdaValue = adaValue . betAmount + adaValue = + singleton (CurrencySymbol emptyByteString) (TokenName emptyByteString) diff --git a/src/Cardano/CEM/Examples/Compilation.hs b/src/Cardano/CEM/Examples/Compilation.hs new file mode 100644 index 0000000..7a747b6 --- /dev/null +++ b/src/Cardano/CEM/Examples/Compilation.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoPolyKinds #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.CEM.Examples.Compilation where + +import PlutusTx qualified + +import Data.Proxy (Proxy (..)) + +import PlutusLedgerApi.V2 (serialiseCompiledCode) + +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Examples.Voting +import Cardano.CEM.OnChain (CEMScriptCompiled (..), genericCEMScript) +import Cardano.CEM.Stages (SingleStage) + +compiledAuction = $(PlutusTx.compileUntyped (genericCEMScript ''SimpleAuction ''SimpleAuctionStage)) + +instance CEMScriptCompiled SimpleAuction where + {-# INLINEABLE cemScriptCompiled #-} + cemScriptCompiled Proxy = + serialiseCompiledCode compiledAuction + +compiledVoting = $(PlutusTx.compileUntyped (genericCEMScript ''SimpleVoting ''SingleStage)) + +instance CEMScriptCompiled SimpleVoting where + {-# INLINEABLE cemScriptCompiled #-} + cemScriptCompiled Proxy = + serialiseCompiledCode compiledVoting diff --git a/src/Cardano/CEM/Examples/Escrow.hs b/src/Cardano/CEM/Examples/Escrow.hs new file mode 100644 index 0000000..35ca781 --- /dev/null +++ b/src/Cardano/CEM/Examples/Escrow.hs @@ -0,0 +1,173 @@ +module Cardano.CEM.Examples.Escrow where + +import PlutusTx qualified +import PlutusTx.Prelude + +import PlutusLedgerApi.V1 (Address, Value) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) + +import Cardano.CEM +import Cardano.CEM.Stages +import Cardano.CEM.OnChain (CEMScriptIsData, IsData) +import PlutusLedgerApi.V1.Value (AssetClass, assetClassValue) +import PlutusTx.IsData (FromData, ToData) +import qualified PlutusTx as Plutus + +-- Generic escrows + +-- TODO: move to Commons +class Escrow escrow where + data EscrowParams escrow + data EscrowUnlock escrow + unlockConstraints :: + EscrowParams escrow -> + EscrowUnlock escrow -> + Either BuiltinString (TransitionSpec (EscrowScript escrow)) + +newtype EscrowScript escrow = MkEscrowScript escrow + +instance + (Escrow escrow, IsData (EscrowUnlock escrow)) => + CEMScript (EscrowScript escrow) + where + type Stage (EscrowScript escrow) = SingleStage + data Params (EscrowScript escrow) = MkEscrowParams (EscrowParams escrow) + data State (EscrowScript escrow) = Locked + data Transition (EscrowScript escrow) = UnLock (EscrowUnlock escrow) + + transitionSpec (MkEscrowParams params) (Just Locked) (UnLock unlock) = + unlockConstraints params unlock + + +-- TODO +instance FromData (EscrowParams escrow) => FromData (Params (EscrowScript escrow)) where +instance ToData (EscrowParams escrow) => ToData (Params (EscrowScript escrow)) where +Plutus.unstableMakeIsData 'Locked +-- Plutus.unstableMakeIsData 'UnLock + +-- Specific escrows + +data UnboundedEscrow + +instance Escrow UnboundedEscrow where + data EscrowParams UnboundedEscrow = MkUnboundedEscrowParams + data EscrowUnlock UnboundedEscrow = UnboundedEscrowUnlock + unlockConstraints _ _ = + Right $ + MkTransitionSpec + { constraints = [] + , signers = [] + , stage = Always + } + +data UserLockedEscrow + +instance Escrow UserLockedEscrow where + data EscrowParams UserLockedEscrow = MkUserLockedState + { unlockingUser :: PubKeyHash + } + data EscrowUnlock UserLockedEscrow = MkUserUnlock + unlockConstraints state _ = + Right $ + MkTransitionSpec + { constraints = [] + , signers = [unlockingUser state] + , stage = Always + } + +PlutusTx.unstableMakeIsData 'MkUserLockedState +PlutusTx.unstableMakeIsData 'MkUserUnlock + +data TokenLockedEscrow + +instance Escrow TokenLockedEscrow where + data EscrowParams TokenLockedEscrow = MkTokenLockedState + { unlockingToken :: AssetClass + } + data EscrowUnlock TokenLockedEscrow = MkTokenUnlock + { unlocker :: PubKeyHash + } + unlockConstraints params (MkTokenUnlock {unlocker}) = + Right $ + MkTransitionSpec + { constraints = + [ MkTxFanC + InRef + (MkTxFanFilter (ByPubKey unlocker) Anything) + (SumValueEq singleToken) + -- TODO: unlocker? + ] + , signers = [unlocker] + , stage = Always + } + where + singleToken = assetClassValue (unlockingToken params) 1 + +data HashLockedEscrow + +instance Escrow HashLockedEscrow where + data EscrowParams HashLockedEscrow = MkHashLockedState + { secretHash :: BuiltinByteString + } + data EscrowUnlock HashLockedEscrow = MkHashLockedUnlock + { secretValue :: BuiltinByteString + } + unlockConstraints state unlock = + if blake2b_256 (secretValue unlock) == secretHash state + then + Right $ + MkTransitionSpec + { constraints = [] + , signers = [] + , stage = Always + } + else Left "Wrong hash" + +data FixedSwapEscrow + +instance Escrow FixedSwapEscrow where + data EscrowParams FixedSwapEscrow = MkSwapState + { creator :: Address + , lockedValue :: Value + , toSwapValue :: Value + } + data EscrowUnlock FixedSwapEscrow = FixedSwapUnlock + { swappingActor :: Address + } + unlockConstraints state unlock = + Right $ + MkTransitionSpec + { constraints = + [ -- TODO: balance, need to sign? + MkTxFanC Out (MkTxFanFilter (ByAddress (creator state)) Anything) (SumValueEq (toSwapValue state)) + , MkTxFanC Out (MkTxFanFilter (ByAddress (swappingActor unlock)) Anything) (SumValueEq (lockedValue state)) + ] + , signers = [] + , stage = Always + } + +data FeeDistributionEscrow + +instance Escrow FeeDistributionEscrow where + data EscrowParams FeeDistributionEscrow = MkFeeDistributionParams + { feeReceivers :: [Address] + } + + -- TODO: explain + data EscrowUnlock FeeDistributionEscrow = MkFeeDistributionUnlock + { amountPerFeeReceiver :: Value + } + + unlockConstraints params unlock = + Right $ + MkTransitionSpec + { constraints = map receiverConstraint $ feeReceivers params + , signers = [] + , stage = Always + } + where + receiverConstraint address = + MkTxFanC + Out + (MkTxFanFilter (ByAddress address) Anything) + (SumValueEq $ amountPerFeeReceiver unlock) diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs new file mode 100644 index 0000000..2fc860c --- /dev/null +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -0,0 +1,173 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use when" #-} + +module Cardano.CEM.Examples.Voting where + +import PlutusTx.Prelude +import Prelude qualified + +import Data.Map qualified as Map + +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V2 (Value) +import PlutusTx qualified +import PlutusTx.AssocMap qualified as PMap +import PlutusTx.Show.TH (deriveShow) + +import Cardano.Api.Ledger (Vote) + +import Cardano.CEM +import Cardano.CEM.Stages +import Data.Spine (deriveSpine) + +-- Voting + +data SimpleVoting + +data VoteValue = Yes | No | Abstain + deriving (Prelude.Show, Prelude.Eq) + +instance Eq VoteValue where + Yes == Yes = True + No == No = True + Abstain == Abstain = True + _ == _ = False + +-- | Policy determinig who can vote +data JuryPolicy = Anyone | FixedJuryList [PubKeyHash] | WithToken Value + deriving (Prelude.Show, Prelude.Eq) + +-- Votes storage + +-- | Map from jury to their decision +type VoteStorage = PMap.Map PubKeyHash VoteValue + +addVote :: PubKeyHash -> VoteValue -> VoteStorage -> Either BuiltinString VoteStorage +addVote jury vote storage = case PMap.lookup jury storage of + Just _ -> traceError "You already casted vote" + Nothing -> Right $ PMap.insert jury vote storage + +{-# INLINEABLE countVotes #-} +countVotes :: SimpleVotingParams -> VoteStorage -> VoteValue +countVotes params votesMap = maxDecision + where + votesFor (accum :: (Integer, Integer)) [] = accum + votesFor (yesCount, noCount) (vote : vs) = case vote of + Yes -> votesFor (yesCount + 1, noCount) vs + No -> votesFor (yesCount, noCount + 1) vs + (votesYes, votesNo) = votesFor (0, 0) $ PMap.elems votesMap + maxDecision = + case compare votesYes votesNo of + GT -> Yes + LT -> No + EQ -> drawDecision params + +-- No + +-- Other datatypes + +data SimpleVotingParams = MkVotingParams + { disputeDescription :: BuiltinByteString + , creator :: PubKeyHash + , juryPolicy :: JuryPolicy + , abstainAllowed :: Bool + , drawDecision :: VoteValue + } + deriving (Prelude.Show, Prelude.Eq) + +data SimpleVotingState + = NotStarted + | InProgress VoteStorage + | Finalized VoteValue + deriving (Prelude.Show, Prelude.Eq) + +data SimpleVotingTransition + = Create + | Start + | Vote PubKeyHash VoteValue + | Finalize + deriving (Prelude.Show, Prelude.Eq) + +PlutusTx.unstableMakeIsData ''VoteValue +PlutusTx.unstableMakeIsData ''JuryPolicy +PlutusTx.unstableMakeIsData ''SimpleVotingState +PlutusTx.unstableMakeIsData ''SimpleVotingParams +PlutusTx.unstableMakeIsData ''SimpleVotingTransition + +deriveShow ''SimpleVoting + +deriveSpine ''SimpleVotingTransition +deriveSpine ''SimpleVotingState + +instance CEMScript SimpleVoting where + type Stage SimpleVoting = SingleStage + type Params SimpleVoting = SimpleVotingParams + type State SimpleVoting = SimpleVotingState + type Transition SimpleVoting = SimpleVotingTransition + + transitionStage _ = + Map.fromList + [ (CreateSpine, (Always, Nothing)) + , (StartSpine, (Always, Just NotStartedSpine)) + , (VoteSpine, (Always, Just InProgressSpine)) + , (FinalizeSpine, (Always, Just InProgressSpine)) + ] + + {-# INLINEABLE transitionSpec #-} + transitionSpec params state transition = + case (state, transition) of + (Nothing, Create) -> + Right + $ MkTransitionSpec + { constraints = [nextScriptState NotStarted] + , signers = [creator params] + } + (Just NotStarted, Start) -> + Right + $ MkTransitionSpec + { constraints = [nextScriptState (InProgress PMap.empty)] + , signers = [creator params] + } + (Just (InProgress votes), Vote jury vote) -> do + -- Check if you can vote + case juryPolicy params of + FixedJuryList allowedJury -> + if jury `notElem` allowedJury + then Left "You are not allowed to vote, not on list" + else return () + _ -> return () + if not (abstainAllowed params) && vote == Abstain + then Left "You cannot vote Abstain in this vote" + else return () + + let allowedToVoteConstraints = + case juryPolicy params of + WithToken value -> + [ MkTxFanC + InRef + (MkTxFanFilter (ByPubKey jury) Anything) + (SumValueEq value) + ] + _ -> [] + + -- Update state + newVoteStorage <- addVote jury vote votes + Right + $ MkTransitionSpec + { constraints = + nextScriptState (InProgress newVoteStorage) + : allowedToVoteConstraints + , signers = [jury] + } + (Just (InProgress votes), Finalize) -> + Right + $ MkTransitionSpec + { constraints = + [nextScriptState $ Finalized (countVotes params votes)] + , signers = [creator params] + } + _ -> Left "Wrong state transition" where + where + nextScriptState state = + MkTxFanC Out (MkTxFanFilter BySameScript (bySameCEM state)) (Exist 1) diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs new file mode 100644 index 0000000..f6f9301 --- /dev/null +++ b/src/Cardano/CEM/Monads.hs @@ -0,0 +1,96 @@ +module Cardano.CEM.Monads where + +import Prelude + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Data (Proxy (..)) +import Data.Map qualified as Map +import Data.Set (Set) + +import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V2 ( + Interval (..), + POSIXTime (..), + UnsafeFromData (..), + always, + fromData, + ) + +import Cardano.Api hiding (Address, In, Out, queryUtxo, txIns) +import Cardano.Api.Shelley (PlutusScript (..), PoolId, ReferenceScript (..), fromPlutusData, toMaryValue, toPlutusData) +import Cardano.Ledger.Core (PParams) + +import Cardano.Api.IPC (TxValidationError) +import Cardano.CEM +import Cardano.CEM.OnChain +import Cardano.Extras +import Cardano.Ledger.Shelley.API (ApplyTxError) +import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT) +import Control.Monad.Trans (MonadTrans (..)) +import Data.List (find) +import Data.Maybe (listToMaybe) +import Data.Spine (HasSpine (..)) +import Text.Show.Pretty (ppShow) + +-- MonadBlockchainParams + +-- | Params of blockchain required for transaction-building +data BlockchainParams = MkBlockchainParams + { protocolParameters :: PParams LedgerEra + , systemStart :: SystemStart + , -- FIXME: rename + eraHistory :: LedgerEpochInfo + , stakePools :: Set PoolId + } + deriving stock (Show) + +{- | This monad gives access to all information about Cardano params, + | which is various kind of Ledger params and ValidityBound/Slots semantics +-} +class (MonadFail m) => MonadBlockchainParams m where + askNetworkId :: m NetworkId + queryCurrentSlot :: m SlotNo + queryBlockchainParams :: m BlockchainParams + +-- MonadQuery + +data UtxoQuery + = ByAddresses [Address] + | ByTxIns [TxIn] + deriving stock (Show, Eq) + +-- | Ability to query current Utxo state of chain +class (MonadBlockchainParams m) => MonadQueryUtxo m where + queryUtxo :: UtxoQuery -> m (UTxO Era) + +-- MonadSubmit + +data ResolvedTx = MkResolvedTx + { txIns :: [(TxIn, TxInWitness)] + , txInsReference :: [TxIn] + , txOuts :: [TxOut CtxTx Era] + , toMint :: TxMintValue BuildTx Era + , interval :: Interval POSIXTime + , signer :: [SigningKey PaymentKey] + } + deriving stock (Show, Eq) + +data WrongSlotKind = Early | Late + deriving stock (Show, Eq) + +data TxSubmittingError + = WrongSlot WrongSlotKind Integer + | TxInOutdated [TxIn] + | UnhandledAutobalanceError (TxBodyErrorAutoBalance Era) + | UnhandledNodeSubmissionError (TxValidationError Era) + deriving stock (Show) + +-- | Ability to send transaction to chain +class (MonadQueryUtxo m) => MonadSubmitTx m where + submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId) + +-- | Stuff needed to use monad for local testing +class (MonadSubmitTx m) => MonadTest m where + -- | List of keys having some amount of genesis ADA + getTestWalletSks :: m [SigningKey PaymentKey] diff --git a/src/Cardano/CEM/Monads/CLB.hs b/src/Cardano/CEM/Monads/CLB.hs new file mode 100644 index 0000000..8c211b0 --- /dev/null +++ b/src/Cardano/CEM/Monads/CLB.hs @@ -0,0 +1,93 @@ +module Cardano.CEM.Monads.CLB where + +import Prelude + +import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) +import Control.Monad.State (StateT (..), gets) +import Control.Monad.Trans (MonadIO (..)) +import Data.Map qualified as Map +import Data.Set qualified as Set + +-- Cardano imports +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Query (fromLedgerUTxO) +import Cardano.Api.Shelley (LedgerProtocolParameters (..)) + +-- Lib imports +import Clb ( + ClbState (mockConfig), + ClbT (..), + MockConfig (..), + SlotConfig (scSlotZeroTime), + ValidationResult (..), + getCurrentSlot, + getEpochInfo, + getUtxosAtState, + initClb, + intToCardanoSk, + sendTx, + ) +import Clb.MockConfig (defaultBabbage) +import Clb.TimeSlot (posixTimeToUTCTime) + +-- CEM imports + +import Cardano.CEM.Monads +import Cardano.CEM.Monads.L1Commons +import Cardano.CEM.OffChain (fromPlutusAddressInMonad) +import Cardano.Extras + +instance (MonadFail m) => MonadBlockchainParams (ClbT m) where + askNetworkId :: ClbT m NetworkId + askNetworkId = gets (mockConfigNetworkId . mockConfig) + + queryCurrentSlot :: ClbT m SlotNo + queryCurrentSlot = getCurrentSlot + + queryBlockchainParams = do + protocolParameters <- gets (mockConfigProtocol . mockConfig) + slotConfig <- gets (mockConfigSlotConfig . mockConfig) + eraHistory <- LedgerEpochInfo <$> getEpochInfo + let systemStart = + SystemStart $ posixTimeToUTCTime $ scSlotZeroTime slotConfig + return $ + MkBlockchainParams + { protocolParameters + , systemStart + , eraHistory + , -- Staking is not supported + stakePools = Set.empty + } + +instance (MonadFail m) => MonadQueryUtxo (ClbT m) where + queryUtxo query = do + utxos <- fromLedgerUTxO shelleyBasedEra <$> gets getUtxosAtState + predicate <- mkPredicate + return $ UTxO $ Map.filterWithKey predicate $ unUTxO utxos + where + mkPredicate = case query of + ByAddresses addresses -> do + cardanoAddresses <- mapM fromPlutusAddressInMonad addresses + return $ \_ (TxOut a _ _ _) -> a `elem` cardanoAddresses + ByTxIns txIns -> return $ \txIn _ -> txIn `elem` txIns + +instance (MonadFail m) => MonadSubmitTx (ClbT m) where + submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId) + submitResolvedTx tx = do + cardanoTxBodyFromResolvedTx tx >>= \case + Right (body, TxInMode ShelleyBasedEraBabbage tx') -> do + result <- sendTx tx' + case result of + Success _ _ -> return $ Right $ getTxId body + _ -> fail "TODO" + Left e -> return $ Left $ UnhandledAutobalanceError e + +instance (MonadFail m) => MonadTest (ClbT m) where + getTestWalletSks = return $ map intToCardanoSk [1 .. 10] + +execOnIsolatedClb :: Value -> ClbT IO a -> IO a +execOnIsolatedClb genesisValue action = + fst + <$> runStateT + (unwrapClbT action) + (initClb defaultBabbage genesisValue genesisValue) diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs new file mode 100644 index 0000000..68f8b91 --- /dev/null +++ b/src/Cardano/CEM/Monads/L1.hs @@ -0,0 +1,143 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Cardano.CEM.Monads.L1 where + +import Prelude + +import Control.Monad.Reader (MonadReader (..), ReaderT (..)) +import Control.Monad.Trans (MonadIO (..)) +import Data.ByteString qualified as BS +import Data.Set qualified as Set +import Unsafe.Coerce (unsafeCoerce) + +-- Cardano imports +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.IPC (TxValidationError) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) + +-- Project imports + +import Cardano.CEM.Monads ( + BlockchainParams (MkBlockchainParams), + MonadBlockchainParams (..), + MonadQueryUtxo (..), + MonadSubmitTx (..), + MonadTest (..), + ResolvedTx, + TxSubmittingError (..), + UtxoQuery (..), + ) +import Cardano.CEM.Monads.L1Commons (cardanoTxBodyFromResolvedTx) +import Cardano.CEM.OffChain (fromPlutusAddressInMonad) +import Cardano.Extras (Era, addressInEraToAny, cardanoModeParams, parseSigningKeyTE) + +newtype ExecutionContext = MkExecutionContext + { localNode :: LocalNodeConnectInfo + } + +newtype L1Runner a = MkL1Runner + { unL1Runner :: ReaderT ExecutionContext IO a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadFail + , MonadReader ExecutionContext + ) + +-- Monad implementations + +instance MonadBlockchainParams L1Runner where + askNetworkId = localNodeNetworkId . localNode <$> ask + queryCurrentSlot = do + node <- localNode <$> ask + tip <- liftIO $ getLocalChainTip node + case tip of + ChainTipAtGenesis -> pure 0 + ChainTip slotNo _ _ -> pure slotNo + + queryBlockchainParams = do + MkBlockchainParams + <$> queryCardanoNodeWrapping QueryProtocolParameters + <*> queryCardanoNode QuerySystemStart + <*> (toLedgerEpochInfo <$> queryCardanoNode QueryEraHistory) + <*> queryCardanoNodeWrapping QueryStakePools + +queryCardanoNodeWrapping :: QueryInShelleyBasedEra Era b -> L1Runner b +queryCardanoNodeWrapping query = + handleEitherEra =<< queryCardanoNode (wrapQuery query) + where + handleEitherEra (Right x) = return x + handleEitherEra (Left _) = fail "Unexpected era mismatch" + wrapQuery query = QueryInEra (QueryInShelleyBasedEra shelleyBasedEra query) + +-- Design inspired by `Hydra.Chain.CardanoClient` helpers +queryCardanoNode :: + QueryInMode b -> L1Runner b +queryCardanoNode query = do + node <- localNode <$> ask + result <- liftIO $ queryNodeLocalState node VolatileTip query + case result of + -- FIXME: better handling of wrong-era exceptions + Right x -> return x + _ -> fail "Unhandled Cardano API error" + +instance MonadQueryUtxo L1Runner where + queryUtxo query = do + utxoQuery <- case query of + ByTxIns txIns -> + return $ QueryUTxOByTxIn (Set.fromList txIns) + ByAddresses addresses -> do + cardanoAddresses <- + map addressInEraToAny <$> mapM fromPlutusAddressInMonad addresses + return $ QueryUTxOByAddress (Set.fromList cardanoAddresses) + queryCardanoNodeWrapping $ QueryUTxO utxoQuery + +instance MonadSubmitTx L1Runner where + -- FIXME: code duplication, probably refactor out + submitResolvedTx :: ResolvedTx -> L1Runner (Either TxSubmittingError TxId) + submitResolvedTx tx = do + ci <- localNode <$> ask + cardanoTxBodyFromResolvedTx tx >>= \case + Right (body, txInMode) -> + liftIO $ + submitTxToNodeLocal ci txInMode >>= \case + SubmitSuccess -> + return $ Right $ getTxId body + SubmitFail (TxValidationErrorInCardanoMode e) -> + return $ Left $ UnhandledNodeSubmissionError $ unsafeCoerce e + Left e -> return $ Left $ UnhandledAutobalanceError e + +instance MonadTest L1Runner where + -- FIXME: cache keys and better error handling + getTestWalletSks = do + mapM key [0 .. 2] + where + key n = do + keyBytes <- liftIO $ BS.readFile $ keysPaths !! fromInteger n + let Just key = parseSigningKeyTE keyBytes + return key + keysPaths = + [ "./devnet/credentials/faucet.sk" + , "./devnet/credentials/bob.sk" + , "./devnet/credentials/carol.sk" + ] + +-- | Starting local devnet +localDevnetNetworkId :: NetworkId +localDevnetNetworkId = Testnet $ NetworkMagic 42 + +execOnLocalDevnet :: L1Runner a -> IO a +execOnLocalDevnet action = + runReaderT (unL1Runner action) localNodeContext + where + localNodeContext = + MkExecutionContext + { localNode = + LocalNodeConnectInfo + cardanoModeParams + localDevnetNetworkId + "./devnet/node.socket" + } diff --git a/src/Cardano/CEM/Monads/L1Commons.hs b/src/Cardano/CEM/Monads/L1Commons.hs new file mode 100644 index 0000000..3c9fd45 --- /dev/null +++ b/src/Cardano/CEM/Monads/L1Commons.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Code common for resolving Tx of backends which use `cardano-api` +module Cardano.CEM.Monads.L1Commons where + +import Prelude + +import Control.Monad.Except (ExceptT (..), runExceptT) +import Data.Map qualified as Map + +-- Lib imports +import Text.Show.Pretty (ppShow) + +-- Cardano imports +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley (LedgerProtocolParameters (..)) + +-- Project imports +import Cardano.CEM.Monads +import Cardano.CEM.OffChain +import Cardano.Extras + +-- Main function + +cardanoTxBodyFromResolvedTx :: + (MonadQueryUtxo m, MonadBlockchainParams m) => + ResolvedTx -> + m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode)) +cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do + -- (lowerBound, upperBound) <- convertValidityBound validityBound + -- TODO + let keyWitnessedTxIns = [fst $ last txIns] + MkBlockchainParams {protocolParameters} <- queryBlockchainParams + let preBody = + TxBodyContent + { txIns = txIns + , txInsCollateral = + TxInsCollateral AlonzoEraOnwardsBabbage keyWitnessedTxIns + , txInsReference = + TxInsReference BabbageEraOnwardsBabbage txInsReference + , txOuts + , txMintValue = toMint + , txExtraKeyWits = + -- Somehow now it does not requires them, while before does + TxExtraKeyWitnesses AlonzoEraOnwardsBabbage [] + , txProtocolParams = + BuildTxWith $ + Just $ + LedgerProtocolParameters protocolParameters + , txValidityLowerBound = + TxValidityNoLowerBound + , txValidityUpperBound = + TxValidityUpperBound ShelleyBasedEraBabbage Nothing + , -- Fee stubs + txTotalCollateral = TxTotalCollateralNone + , txReturnCollateral = TxReturnCollateralNone + , txFee = TxFeeExplicit ShelleyBasedEraBabbage 0 + , -- Not supported features + txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txScriptValidity = TxScriptValidityNone + , txProposalProcedures = Nothing + , txVotingProcedures = Nothing + } + + let + mainSignor = signer !! 0 + mainAddress' = signingKeyToAddress mainSignor + + mainAddress <- fromPlutusAddressInMonad mainAddress' + utxo <- queryUtxo $ ByTxIns $ map fst txIns + + runExceptT $ do + body <- + ExceptT $ + callBodyAutoBalance + preBody + utxo + mainAddress + let + tx = makeSignedTransactionWithKeys signer body + txInMode = TxInMode ShelleyBasedEraBabbage tx + return (body, txInMode) + +-- Utils + +makeSignedTransactionWithKeys :: + [SigningKey PaymentKey] -> + TxBody Era -> + Tx Era +makeSignedTransactionWithKeys keys txBody = + makeSignedTransaction keyWitnesses txBody + where + createWitness key = makeShelleyKeyWitness shelleyBasedEra txBody (WitnessPaymentKey key) + keyWitnesses = fmap createWitness keys + +callBodyAutoBalance :: + (MonadBlockchainParams m) => + TxBodyContent BuildTx Era -> + UTxO Era -> + AddressInEra Era -> + m (Either (TxBodyErrorAutoBalance Era) (TxBody Era)) +callBodyAutoBalance + preBody + utxo + changeAddress = do + MkBlockchainParams {protocolParameters, systemStart, eraHistory, stakePools} <- + queryBlockchainParams + let result = + makeTransactionBodyAutoBalance @Era + shelleyBasedEra + systemStart + eraHistory + (LedgerProtocolParameters protocolParameters) + stakePools + Map.empty -- Stake credentials + Map.empty -- Some other DRep stuff + utxo + preBody + changeAddress + Nothing + return $ fmap balancedTxBody result + where + balancedTxBody (BalancedTxBody _ txBody _ _) = txBody diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs new file mode 100644 index 0000000..0f67432 --- /dev/null +++ b/src/Cardano/CEM/OffChain.hs @@ -0,0 +1,310 @@ +{- | User-facing utilities for querying and sending Txs +on top of interfaces in `Monads` module +-} +module Cardano.CEM.OffChain where + +import Prelude + +-- Haskell imports +import Control.Concurrent (threadDelay) +import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans (MonadTrans (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Data (Proxy (..)) +import Data.List (find) +import Data.Map qualified as Map +import Data.Set (Set) + +import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V2 ( + Interval (..), + POSIXTime (..), + UnsafeFromData (..), + always, + fromData, + ) + +import Cardano.Api hiding (Address, In, Out, queryUtxo, txIns) +import Cardano.Api.IPC (TxValidationError) +import Cardano.Api.Shelley ( + PlutusScript (..), + PoolId, + ReferenceScript (..), + fromPlutusData, + toMaryValue, + toPlutusData, + ) +import Cardano.Ledger.Core (PParams) +import Cardano.Ledger.Shelley.API (ApplyTxError) + +-- Project imports + +import Cardano.CEM +import Cardano.CEM.Monads +import Cardano.CEM.OnChain +import Cardano.Extras +import Data.Spine + +fromPlutusAddressInMonad :: + (MonadBlockchainParams m) => Address -> m (AddressInEra Era) +fromPlutusAddressInMonad address = do + networkId <- askNetworkId + return $ fromPlutusAddress networkId address + +queryByFanFilter :: (MonadQueryUtxo m) => TxFanFilter script -> m (UTxO Era) +queryByFanFilter query = return $ error "TODO" + +checkTxIdExists :: (MonadQueryUtxo m) => TxId -> m Bool +checkTxIdExists txId = do + result <- queryUtxo $ ByTxIns [TxIn txId (TxIx 0)] + return $ not $ Map.null $ unUTxO result + +awaitTx :: forall m. (MonadIO m, MonadQueryUtxo m) => TxId -> m () +awaitTx txId = do + go 5 + where + go :: Integer -> m () + go 0 = liftIO $ fail "Tx was not awaited." -- TODO + go n = do + exists <- checkTxIdExists txId + liftIO $ threadDelay 1_000_000 + if exists + then return () + else go $ n - 1 + +data TxSigner = MkTxSigner + { signerKey :: SigningKey PaymentKey + , allowTxInSpending :: Bool + , allowFeeCovering :: Bool + } + deriving stock (Show, Eq) + +mkMainSigner :: SigningKey PaymentKey -> TxSigner +mkMainSigner signerKey = + MkTxSigner + { signerKey + , allowTxInSpending = True + , allowFeeCovering = True + } + +data CEMAction script + = MkCEMAction (CEMParams script) (Transition script) + +-- TODO +deriving stock instance + ( Show (CEMParams script) + , Show (State script) + , Show (Transition script) + ) => + Show (CEMAction script) + +data SomeCEMAction where + MkSomeCEMAction :: + forall script. + ( CEMScriptCompiled script + , Show (CEMAction script) + , Show (State script) + , Show (Transition script) + , Eq (CEMParams script) + ) => + CEMAction script -> + SomeCEMAction + +instance Show SomeCEMAction where + -- TODO: show script name + show :: SomeCEMAction -> String + show (MkSomeCEMAction action) = show action + +data TxSpec = MkTxSpec + { actions :: [SomeCEMAction] + , specSigners :: [TxSigner] + } + deriving stock (Show) + +-- | Error occurred while trying to execute CEMScript transition +data TransitionError + = StateMachineError + { errorMessage :: String + } + | MissingTransitionInput + deriving stock (Show, Eq) + +data TxResolutionError + = TxSpecIsIncorrect + | MkTransitionError SomeCEMAction TransitionError + | UnhandledSubmittingError TxSubmittingError + deriving stock (Show) + +failLeft :: (MonadFail m, Show s) => Either s a -> m a +failLeft (Left errorMsg) = fail $ show errorMsg +failLeft (Right value) = return value + +-- TODO: use regular CEMScript +cemTxOutDatum :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (CEMScriptDatum script) +cemTxOutDatum txOut = + fromData =<< toPlutusData <$> getScriptData <$> mTxOutDatum txOut + +cemTxOutState :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (State script) +cemTxOutState txOut = + let + getState (_, _, state) = state + in + getState <$> cemTxOutDatum txOut + +queryScriptTxInOut :: + forall m script. + ( MonadQueryUtxo m + , CEMScriptCompiled script + , Eq (CEMParams script) + ) => + CEMParams script -> + m (Maybe (TxIn, TxOut CtxUTxO Era)) +queryScriptTxInOut params = do + utxo <- queryUtxo $ ByAddresses [scriptAddress] + let mScriptTxIn = + case Map.assocs $ unUTxO utxo of + [] -> Nothing + pairs -> find hasSameParams pairs + hasSameParams (txIn, txOut) = + case cemTxOutDatum txOut of + Just (p1, p2, _) -> params == MkCEMParams p2 p1 + Nothing -> False -- May happen in case of changed Datum encoding + return mScriptTxIn + where + scriptAddress = cemScriptAddress (Proxy :: Proxy script) + +queryScriptState :: + forall m script. + ( MonadQueryUtxo m + , CEMScriptCompiled script + , Eq (CEMParams script) + ) => + CEMParams script -> + m (Maybe (State script)) +queryScriptState params = do + mTxInOut <- queryScriptTxInOut params + return (cemTxOutState . snd =<< mTxInOut) + +resolveAction :: + forall m. + (MonadQueryUtxo m, MonadSubmitTx m) => + SomeCEMAction -> + m (Either TxResolutionError ResolvedTx) +resolveAction + someAction@(MkSomeCEMAction @script (MkCEMAction params transition)) = + -- Add script TxIn + + runExceptT $ do + mScriptTxIn' <- lift $ queryScriptTxInOut params + + let + -- TODO + mScriptTxIn = case transitionStage (Proxy :: Proxy script) Map.! getSpine transition of + (_, Nothing) -> Nothing + _ -> mScriptTxIn' + mState = cemTxOutState =<< snd <$> mScriptTxIn + witnesedScriptTxIns = + case mScriptTxIn of + Just (txIn, _) -> + let + scriptWitness = + mkInlinedDatumScriptWitness + (PlutusScriptSerialised @PlutusLang script) + transition + in + [(txIn, scriptWitness)] + Nothing -> [] + + scriptTransition <- case transitionSpec (scriptParams params) mState transition of + Left errorMessage -> + throwError $ + MkTransitionError someAction (StateMachineError $ show errorMessage) + Right result -> return result + + -- Coin-select + + let + byKind kind = + filter (\x -> txFanCKind x == kind) $ + constraints scriptTransition + + txInsPairs <- concat <$> mapM resolveTxIn (byKind In) + txOuts <- concat <$> mapM compileTxConstraint (byKind Out) + + let + txInValue = mconcat $ map (txOutValue . snd) txInsPairs + txOutValue' = mconcat $ map txOutValue txOuts + + -- TODO + -- traceM $ + -- "Doing transition: " <> ppShow someAction <> + -- "From state: " <> ppShow mState <> + -- "With transition spec: " <> ppShow scriptTransition + -- traceM $ ppShow witnesedScriptTxIns + -- traceM $ ppShow txInsPairs + -- traceM $ ppShow txOutValue' + + return $ + MkResolvedTx + { txIns = witnesedScriptTxIns <> map fst txInsPairs + , txInsReference = [] + , txOuts + , toMint = TxMintNone + , signer = [] + , interval = always + } + where + txOutValue (TxOut _ value _ _) = value + script = cemScriptCompiled (Proxy :: Proxy script) + scriptAddress = cemScriptAddress (Proxy :: Proxy script) + resolveTxIn (MkTxFanC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do + utxo <- lift $ queryUtxo $ ByAddresses [address] + return $ map (\(x, y) -> (withKeyWitness x, y)) $ Map.toList $ unUTxO utxo + where + address = addressSpecToAddress scriptAddress addressSpec + compileTxConstraint + (MkTxFanC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do + address' <- lift $ fromPlutusAddressInMonad address + let compiledTxOut value = + TxOut address' value datum ReferenceScriptNone + return $ case quantor of + Exist n -> replicate (fromInteger n) $ compiledTxOut minUtxoValue + SumValueEq value -> [compiledTxOut $ (convertTxOut $ fromPlutusValue value) <> minUtxoValue] + where + datum = case filterSpec of + Anything -> TxOutDatumNone + ByDatum datum' -> mkInlineDatum datum' + -- FIXME: Can be optimized via Plutarch + UnsafeBySameCEM newState -> + let + datum :: CEMScriptDatum script + datum = (stagesParams params, scriptParams params, unsafeFromBuiltinData newState) + in + mkInlineDatum datum + address = addressSpecToAddress scriptAddress addressSpec + -- TODO: protocol params + -- calculateMinimumUTxO era txout bpp + minUtxoValue = convertTxOut $ lovelaceToValue $ Lovelace 3_000_000 + -- TODO + convertTxOut x = + TxOutValueShelleyBased shelleyBasedEra $ toMaryValue x + +resolveTxAndSubmit :: + (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) => + TxSpec -> + m (Either TxResolutionError TxId) +resolveTxAndSubmit spec = runExceptT $ do + -- Get specs + !actionsSpecs <- mapM (ExceptT . resolveAction) $ actions spec + + -- Merge specs + let + mergedSpec' = head actionsSpecs + mergedSpec = mergedSpec' {signer = map signerKey $ specSigners spec} + + -- TODO + !utxo <- lift $ queryUtxo $ ByAddresses [signingKeyToAddress $ head $ signer mergedSpec] + let ins = map withKeyWitness $ Map.keys $ unUTxO utxo + let result = submitResolvedTx $ mergedSpec {txIns = txIns mergedSpec ++ ins} + ExceptT $ (bimap UnhandledSubmittingError id) <$> result diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs new file mode 100644 index 0000000..9136b00 --- /dev/null +++ b/src/Cardano/CEM/OnChain.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NoPolyKinds #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} + +module Cardano.CEM.OnChain where + +import PlutusTx.Prelude + +import Data.Proxy + +import PlutusLedgerApi.Common (SerialisedScript) +import PlutusLedgerApi.V1.Address (Address, scriptHashAddress) +import PlutusLedgerApi.V1.Interval (always, contains) +import PlutusLedgerApi.V1.Scripts (Datum (..)) +import PlutusLedgerApi.V1.Value (geq) +import PlutusLedgerApi.V2.Contexts ( + ScriptContext, + TxInInfo (..), + TxInfo (..), + TxOut (..), + findOwnInput, + scriptContextTxInfo, + ) +import PlutusLedgerApi.V2.Tx (OutputDatum (..)) +import PlutusTx.IsData (FromData, ToData (toBuiltinData), UnsafeFromData (..)) +import PlutusTx.Show (Show (..)) + +import Plutus.Extras + +import Cardano.CEM +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Stages +import Cardano.Ledger.Babbage.TxBody (getEitherAddrBabbageTxOut) +import Language.Haskell.TH (Code, conT, unsafe) +import Language.Haskell.TH.Syntax (Dec, Exp, Name, Q, Type) + +class (CEMScript script, CEMScriptIsData script) => CEMScriptCompiled script where + cemScriptCompiled :: Proxy script -> SerialisedScript + +{-# INLINEABLE cemScriptAddress #-} +cemScriptAddress :: + forall script. (CEMScriptCompiled script) => Proxy script -> Address +cemScriptAddress = + scriptHashAddress . scriptValidatorHash . cemScriptCompiled + +type IsData x = (UnsafeFromData x, FromData x, ToData x) + +type CEMScriptIsData script = + ( UnsafeFromData (Transition script) + , IsData (StageParams (Stage script)) + , IsData (Params script) + , IsData (Transition script) + , IsData (State script) + ) + +-- Various hacks and type annotations are done due to Plutus limitations +-- Typed quasiquotes do not allow type splicing, so we need use untyped +-- Fields bug - https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8686 +-- Data famlily - not suported - +-- https://github.com/IntersectMBO/plutus/issues/5768 +-- Type familiy mentioning: https://github.com/IntersectMBO/plutus/issues/5769 + +{-# INLINEABLE genericCEMScript #-} +genericCEMScript :: + Name -> + Name -> + Q Exp +genericCEMScript script scriptStage = + [| + \datum' redeemer' context' -> + let + checkTxFan' ownDatum filterSpec' fan = + case filterSpec' of + Anything -> True + UnsafeBySameCEM stateData -> + let + state = unsafeFromBuiltinData stateData :: State $(conT script) + (p1, p2, _) = ownDatum + stateChangeDatum = (p1, p2, state) + stateChangeDatumBS = toBuiltinData stateChangeDatum + in + checkTxFan' ownDatum (ByDatum stateChangeDatumBS) fan + ByDatum expecedDatum -> + let + TxOut _ _ datum _ = fan + in + case datum of + OutputDatum datum -> getDatum datum == expecedDatum + OutputDatumHash _ -> traceError "Hash datum not supported" + _ -> False + checkConstraint ownDatum ownAddress info (MkTxFanC fanKind filterSpec quantifier) = + traceIfFalse ("Checking constraint " <> show fanKind <> " " <> show datumSpec) + $ checkQuantifier + $ filter checkTxFan fans + where + MkTxFanFilter addressSpec datumSpec = filterSpec + checkTxFan fan = + checkTxFanAddress ownAddress addressSpec fan + && checkTxFan' ownDatum datumSpec fan + fans = case fanKind of + In -> map txInInfoResolved $ txInfoInputs info + InRef -> map txInInfoResolved $ txInfoReferenceInputs info + Out -> txInfoOutputs info + checkQuantifier txFans = + case quantifier of + SumValueEq value -> + foldMap txOutValue txFans `geq` value + Exist n -> length txFans == n + + params :: Params $(conT script) + stageParams :: StageParams ($(conT scriptStage)) + datum :: CEMScriptDatum $(conT script) + datum = unsafeFromBuiltinData datum' + (stageParams, params, state) = datum + transition :: Transition $(conT script) + transition = unsafeFromBuiltinData redeemer' + context = unsafeFromBuiltinData context' + info = scriptContextTxInfo context + ownAddress = case findOwnInput context of + Just x -> txOutAddress $ txInInfoResolved x + Nothing -> traceError "Impossible happened" + transitionSpec' = transitionSpec @($(conT script)) + stageToOnChainInterval' = stageToOnChainInterval @($(conT scriptStage)) + result = + case transitionSpec' params (Just state) transition of + Right (MkTransitionSpec @($(conT script)) constraints signers) -> + -- do transition + traceIfFalse + "Some constraint not matching" + ( all (checkConstraint datum ownAddress info) constraints + ) + -- check signers + && traceIfFalse + "Wrong signers list" + ( signers + `isSubSetOf` txInfoSignatories info + ) + -- check stage + && let + expectedInterval = + always + -- stageToOnChainInterval' stageParams (traceError "TODO") + in + traceIfFalse "Wrong interval for transition stage" + $ expectedInterval + `contains` txInfoValidRange info + Left _ -> traceIfFalse "Wrong transition" False + in + if True + then () + else error () + |] + +{-# INLINEABLE checkTxFanAddress #-} +checkTxFanAddress :: Address -> AddressSpec -> TxOut -> Bool +checkTxFanAddress ownAddress addressSpec fan = + txOutAddress fan == addressSpecToAddress ownAddress addressSpec + +{-# INLINEABLE isSubSetOf #-} +isSubSetOf :: (Eq a) => [a] -> [a] -> Bool +isSubSetOf xs ys = all (`elem` ys) xs diff --git a/src/Cardano/CEM/Stages.hs b/src/Cardano/CEM/Stages.hs new file mode 100644 index 0000000..e3b3838 --- /dev/null +++ b/src/Cardano/CEM/Stages.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.Stages where + +import PlutusTx qualified +import Prelude qualified + +import PlutusLedgerApi.V2 ( + Interval (..), + POSIXTime (..), + always, + ) + +-- Stages + +-- This covers constraints on blockchain slot time, +-- used by both on- and off-chain code +class Stages stage where + type StageParams stage = params | params -> stage + stageToOnChainInterval :: + StageParams stage -> stage -> Interval POSIXTime + +-- Common + +-- TODO: rename +data SingleStage = Always + deriving (Prelude.Show, Prelude.Eq) + +data SingleStageParams + = NoSingleStageParams + | AllowedInterval (Interval POSIXTime) + deriving (Prelude.Show, Prelude.Eq) + +instance Stages SingleStage where + type StageParams SingleStage = SingleStageParams + + stageToOnChainInterval NoSingleStageParams Always = always + stageToOnChainInterval (AllowedInterval interval) Always = interval + +PlutusTx.unstableMakeIsData ''SingleStage +PlutusTx.unstableMakeIsData 'NoSingleStageParams diff --git a/test/Auction.hs b/test/Auction.hs new file mode 100644 index 0000000..aa6b45c --- /dev/null +++ b/test/Auction.hs @@ -0,0 +1,227 @@ +module Auction where + +import Prelude + +import Control.Monad.Trans (MonadIO (..)) +import GHC.Num (Num (fromInteger)) + +import PlutusLedgerApi.V1.Address (pubKeyHashAddress) +import PlutusLedgerApi.V1.Interval (always) +import PlutusLedgerApi.V1.Value (adaSymbol, adaToken, assetClass, assetClassValue) + +import Cardano.Ledger.Val (adaOnly) + +import Cardano.CEM +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.Monads +import Cardano.CEM.Monads.CLB (execOnIsolatedClb) +import Cardano.CEM.OffChain +import Cardano.Extras + +import Test.Hspec (around, describe, hspec, it, shouldBe, shouldSatisfy) + +import TestNFT (testNftAssetClass) +import Utils (execClb, mintTestTokens, submitAndCheck) + +auctionSpec = describe "SimpleAuction usecase" $ do + it "Wrong transition resolution error" $ execClb $ do + seller <- (!! 0) <$> getTestWalletSks + bidder1 <- (!! 1) <$> getTestWalletSks + let + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + testNftAssetClass + 1 + } + , stagesParams = NoControl + } + + mintTestTokens seller 1 + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigners = [mkMainSigner seller] + } + + let + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 1_000_000 + } + + result <- + resolveTxAndSubmit $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBid bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + ~( Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) + ) <- + return result + + return () + + it "Wrong bid resolution error" $ execClb $ do + seller <- (!! 0) <$> getTestWalletSks + bidder1 <- (!! 1) <$> getTestWalletSks + let + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + testNftAssetClass + 10 + } + , stagesParams = NoControl + } + + mintTestTokens seller 10 + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigners = [mkMainSigner seller] + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Start + ] + , specSigners = [mkMainSigner seller] + } + + let + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 0 + } + + result <- + resolveTxAndSubmit $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBid bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + ~( Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) + ) <- + return result + + return () + + it "Successful transition flow" $ execClb $ do + seller <- (!! 0) <$> getTestWalletSks + bidder1 <- (!! 1) <$> getTestWalletSks + bidder2 <- (!! 2) <$> getTestWalletSks + let + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + testNftAssetClass + 10 + } + , stagesParams = NoControl + } + + mintTestTokens seller 10 + + Nothing <- queryScriptState auctionParams + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigners = [mkMainSigner seller] + } + + Just NotStarted <- queryScriptState auctionParams + + let + initBid = + MkBet + { better = signingKeyToPKH seller + , betAmount = 0 + } + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 3_000_000 + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Start + ] + , specSigners = [mkMainSigner seller] + } + + Just (CurrentBid currentBid') <- queryScriptState auctionParams + liftIO $ currentBid' `shouldBe` initBid + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBid bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + + Just (CurrentBid currentBid) <- queryScriptState auctionParams + liftIO $ currentBid `shouldBe` bid1 + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Close + ] + , specSigners = [mkMainSigner seller] + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Buyout + ] + , specSigners = [mkMainSigner bidder1] + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..4038def --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Prelude + +import Test.Hspec (hspec) + +import Auction (auctionSpec) +import OffChain (offChainSpec) +import Voting (votingSpec) + +main :: IO () +main = hspec $ do + offChainSpec + auctionSpec + votingSpec diff --git a/test/OffChain.hs b/test/OffChain.hs new file mode 100644 index 0000000..a347e12 --- /dev/null +++ b/test/OffChain.hs @@ -0,0 +1,84 @@ +module OffChain where + +import Prelude + +import Data.Map (keys) + +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley ( + PlutusScript (..), + PoolId, + ReferenceScript (..), + fromPlutusData, + toMaryValue, + toPlutusData, + ) + +import PlutusLedgerApi.V2 ( + always, + fromData, + ) + +import Test.Hspec (around, describe, hspec, it, shouldBe, shouldSatisfy) + +import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.Monads +import Cardano.CEM.Monads.CLB (execOnIsolatedClb) +import Cardano.CEM.OffChain (fromPlutusAddressInMonad) +import Cardano.Extras ( + signingKeyToAddress, + utxoValue, + withKeyWitness, + ) + +import Utils (awaitEitherTx, execClb) + +execOn = execClb + +offChainSpec = describe "Checking monad works" $ do + it "Asking NetworkId works" $ execOn $ do + _networkId <- askNetworkId + return () + -- liftIO $ networkId `shouldBe` localDevnetNetworkId + it "Querying blockchain params works" $ execOn $ do + _slotNo <- queryCurrentSlot + _blockchainParams <- queryBlockchainParams + return () + it "Querying UTxO works" $ execOn $ do + address <- signingKeyToAddress <$> (!! 0) <$> getTestWalletSks + _utxo <- queryUtxo $ ByAddresses [address] + return () + it "Sending transaction works" $ execOn $ do + key1 <- (!! 0) <$> getTestWalletSks + key2 <- (!! 1) <$> getTestWalletSks + utxo <- queryUtxo $ ByAddresses [signingKeyToAddress key1] + user1Address <- fromPlutusAddressInMonad $ signingKeyToAddress key1 + user2Address <- fromPlutusAddressInMonad $ signingKeyToAddress key2 + let + user1TxIns = keys $ unUTxO utxo + Just value = valueToLovelace $ utxoValue utxo + convert x = + TxOutValueShelleyBased shelleyBasedEra $ + toMaryValue x + out userAddress = + TxOut + userAddress + ( convert (lovelaceToValue $ fromInteger 3_000_000) + ) + TxOutDatumNone + ReferenceScriptNone + tx = + MkResolvedTx + { txIns = map withKeyWitness user1TxIns + , txInsReference = [] + , txOuts = + [ out user1Address + , out user2Address + ] + , toMint = TxMintNone + , interval = always + , signer = [key1] + } + awaitEitherTx =<< submitResolvedTx tx + + return () diff --git a/test/TestNFT.hs b/test/TestNFT.hs new file mode 100644 index 0000000..69f254b --- /dev/null +++ b/test/TestNFT.hs @@ -0,0 +1,31 @@ +module TestNFT (testNftPolicy, testNftCurrencySymbol, testNftAssetClass, testNftTokenName) where + +-- Prelude imports +import PlutusTx.Prelude + +-- Plutus imports +import PlutusLedgerApi.Common (SerialisedScript, serialiseCompiledCode) +import PlutusLedgerApi.V1.Value ( + AssetClass (..), + CurrencySymbol, + TokenName (..), + ) +import PlutusTx qualified + +-- Hydra auction imports +import Plutus.Extras (scriptCurrencySymbol) + +testNftPolicy :: SerialisedScript +testNftPolicy = + serialiseCompiledCode + $ $$(PlutusTx.compile [||\(_ :: BuiltinData) (_ :: BuiltinData) -> ()||]) + +testNftCurrencySymbol :: CurrencySymbol +testNftCurrencySymbol = scriptCurrencySymbol testNftPolicy + +testNftTokenName :: TokenName +testNftTokenName = TokenName "Mona Lisa by Leonardo da Vinci" + +testNftAssetClass :: AssetClass +testNftAssetClass = + AssetClass (testNftCurrencySymbol, testNftTokenName) diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 index 0000000..803fd12 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,108 @@ +module Utils where + +import Prelude + +import Control.Monad.Trans (MonadIO (..)) +import Data.Map (elems, keys) + +import PlutusLedgerApi.V1.Address (pubKeyHashAddress) +import PlutusLedgerApi.V1.Interval (always) +import PlutusLedgerApi.V1.Value (adaSymbol, adaToken, assetClass, assetClassValue) + +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley ( + PlutusScript (..), + ReferenceScript (..), + toMaryValue, + ) + +import Test.Hspec (shouldSatisfy) +import Text.Show.Pretty (ppShow) + +import Cardano.CEM.Monads ( + MonadQueryUtxo (..), + MonadSubmitTx (..), + ResolvedTx (..), + UtxoQuery (..), + ) +import Cardano.CEM.Monads.CLB (execOnIsolatedClb) +import Cardano.CEM.OffChain ( + CEMAction (..), + SomeCEMAction (..), + TxSpec (..), + awaitTx, + fromPlutusAddressInMonad, + resolveTxAndSubmit, + ) +import Cardano.Extras + +import TestNFT + +execClb = execOnIsolatedClb $ lovelaceToValue $ fromInteger 300_000_000 + +mintTestTokens userSk numMint = do + userAddress <- fromPlutusAddressInMonad $ signingKeyToAddress userSk + utxo <- queryUtxo $ ByAddresses [signingKeyToAddress userSk] + + let + user1TxIns = keys $ unUTxO utxo + Just value = valueToLovelace $ utxoValue utxo + convert x = + TxOutValueShelleyBased shelleyBasedEra $ + toMaryValue x + out userAddress = + TxOut + userAddress + ( convert $ + ( fromPlutusValue $ + assetClassValue + testNftAssetClass + numMint + ) + <> (lovelaceToValue $ fromInteger 3_000_000) + ) + TxOutDatumNone + ReferenceScriptNone + tx = + MkResolvedTx + { txIns = map withKeyWitness user1TxIns + , txInsReference = [] + , txOuts = + [ out userAddress + ] + , toMint = + mintedTokens + (PlutusScriptSerialised testNftPolicy) + () + [(tokenToAsset testNftTokenName, fromInteger numMint)] + , interval = always + , signer = [userSk] + } + awaitEitherTx =<< submitResolvedTx tx + return () + +checkTxCreated :: + (MonadQueryUtxo m, MonadIO m) => TxId -> m () +checkTxCreated txId = do + -- TODO: better out checks + awaitTx txId + let + txIn = TxIn txId (TxIx 0) + someValue = lovelaceToValue $ fromInteger 0 + utxo <- queryUtxo $ ByTxIns [txIn] + liftIO $ shouldSatisfy (utxoValue utxo) (/= someValue) + +awaitEitherTx :: + (MonadQueryUtxo m, MonadIO m, Show error) => Either error TxId -> m () +awaitEitherTx eitherTx = + case eitherTx of + Right txId -> do + awaitTx txId + -- liftIO $ putStrLn $ "Awaited " <> show txId + Left errorMsg -> error $ "Failed to send tx: " <> ppShow errorMsg + +submitAndCheck spec = do + case head $ actions spec of + MkSomeCEMAction (MkCEMAction _ transition) -> + liftIO $ putStrLn $ "Doing " <> show transition + awaitEitherTx =<< resolveTxAndSubmit spec diff --git a/test/Voting.hs b/test/Voting.hs new file mode 100644 index 0000000..ffbcbe5 --- /dev/null +++ b/test/Voting.hs @@ -0,0 +1,78 @@ +module Voting (votingSpec) where + +import Prelude hiding (readFile) + +import Control.Monad.IO.Class (MonadIO (..)) + +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley ( + PlutusScript (..), + ReferenceScript (..), + toMaryValue, + ) + +import Test.Hspec (around, describe, hspec, it, shouldBe, shouldSatisfy) + +import Cardano.CEM +import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.Examples.Voting +import Cardano.CEM.Monads (MonadTest (..)) +import Cardano.CEM.OffChain +import Cardano.CEM.Stages +import Cardano.Extras (signingKeyToPKH) + +import Utils + +votingSpec = describe "Voting" $ + it "Successfull flow" $ + execClb $ do + jury1 : jury2 : creator : _ <- getTestWalletSks + let + params' = + MkVotingParams + { disputeDescription = "Test dispute" + , creator = signingKeyToPKH creator + , juryPolicy = + FixedJuryList $ map signingKeyToPKH [jury1, jury2] + , abstainAllowed = True + , drawDecision = Abstain + } + params = MkCEMParams params' NoSingleStageParams + mkAction = MkSomeCEMAction . MkCEMAction params + -- Start + submitAndCheck $ + MkTxSpec + { actions = [mkAction Create] + , specSigners = [mkMainSigner creator] + } + + submitAndCheck $ + MkTxSpec + { actions = [mkAction Start] + , specSigners = [mkMainSigner creator] + } + + -- Vote + + submitAndCheck $ + MkTxSpec + { actions = [mkAction $ Vote (signingKeyToPKH jury1) Yes] + , specSigners = [mkMainSigner jury1] + } + + submitAndCheck $ + MkTxSpec + { actions = [mkAction $ Vote (signingKeyToPKH jury2) No] + , specSigners = [mkMainSigner jury2] + } + + -- Count result + + submitAndCheck $ + MkTxSpec + { actions = [mkAction Finalize] + , specSigners = [mkMainSigner jury2] + } + + Just state <- queryScriptState params + liftIO $ state `shouldBe` (Finalized Abstain)