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..d0cad17 --- /dev/null +++ b/.ghcid @@ -0,0 +1 @@ +--reload=cem-script.cabal --command="cabal repl test-suite:cem-sdk-test" -W -T ":main" diff --git a/.gitignore b/.gitignore index 4c9e245..037125f 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,5 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +devnet/db +haddocks 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..6a63a2e 100644 --- a/cabal.project +++ b/cabal.project @@ -11,9 +11,21 @@ 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 2023-12-24T05:49:51Z + , cardano-haskell-packages 2023-12-24T05:54:15Z + +source-repository-package + type: git + location: https://github.com/geniusyield/plutus-simple-model + tag: 0cb63af903a835c73aec662092eb67d228bba9b0 + --sha256: sha256-H56EyRFNdDvLDo9FVeGZyQZ92itQPG39TkMVyEC/xqM= + subdir: + cardano-simple + psm tests: true +allow-newer: + cardano-ledger-shelley-ma:base + packages: . diff --git a/cem-script.cabal b/cem-script.cabal index ba967ed..fdddcf8 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -5,7 +5,9 @@ synopsis: Cardano DApp SDK homepage: https://github.com/cem-script author: MLabs maintainer: gregory@mlabs.city -data-files: README.md +data-files: + data/alonzo-params.json + README.md -- @todo #3 Reproduce `cabal repl` and HLS build on another (@adamczykm) computer tested-with: GHC ==9.6.3 @@ -21,10 +23,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 +64,7 @@ common common-lang MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude + NoPolyKinds NumericUnderscores OverloadedStrings PatternSynonyms @@ -76,6 +81,7 @@ common common-lang TypeOperators TypeSynonymInstances UndecidableInstances + ViewPatterns if flag(dev) default-extensions: PartialTypeSignatures @@ -85,12 +91,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,24 +108,91 @@ 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 + , 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 +-- , cardano-cli 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.Stages + + -- Cardano.CEM.Examples.Escrow + build-depends: + , 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 + + hs-source-dirs: test/ + main-is: Main.hs diff --git a/devnet/byron-delegate.key b/devnet/byron-delegate.key new file mode 100644 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 100644 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 100644 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 100644 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-byron.json b/devnet/genesis-byron.json new file mode 100644 index 0000000..d3246e3 --- /dev/null +++ b/devnet/genesis-byron.json @@ -0,0 +1,36 @@ +{ + "protocolConsts": { + "k": 2160, + "protocolMagic": 42 + }, + "startTime": 1708348608, + "blockVersionData": { + "scriptVersion": 0, + "slotDuration": "250", + "maxBlockSize": "2000000", + "maxHeaderSize": "2000000", + "maxTxSize": "4096", + "maxProposalSize": "700", + "mpcThd": "20000000000000", + "heavyDelThd": "300000000000", + "updateVoteThd": "1000000000000", + "updateProposalThd": "100000000000000", + "updateImplicit": "10000", + "softforkRule": { + "initThd": "900000000000000", + "minThd": "600000000000000", + "thdDecrement": "50000000000000" + }, + "txFeePolicy": { + "summand": "155381000000000", + "multiplier": "43000000000" + }, + "unlockStakeEpoch": "18446744073709551615" + }, + "bootStakeholders": { + "7a4519c93d7be4577dd85bd524c644e6b809e44eae0457b43128c1c7": 1 + }, + "heavyDelegation": {}, + "nonAvvmBalances": {}, + "avvmDistr": {} +} diff --git a/devnet/genesis-conway.json b/devnet/genesis-conway.json new file mode 100644 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/genesis-shelley.json b/devnet/genesis-shelley.json new file mode 100644 index 0000000..6944796 --- /dev/null +++ b/devnet/genesis-shelley.json @@ -0,0 +1,65 @@ +{ + "epochLength": 5, + "activeSlotsCoeff": 1.0, + "slotLength": 0.1, + "securityParam": 2160, + "genDelegs": {}, + "initialFunds": { + "00813c32c92aad21770ff8001de0918f598df8c06775f77f8e8839d2a0074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": 900000000000, + "609783be7d3c54f11377966dfabc9284cd6c32fca1cd42ef0a4f1cc45b": 900000000000 + }, + "maxKESEvolutions": 60, + "maxLovelaceSupply": 2000000000000, + "networkId": "Testnet", + "networkMagic": 42, + "protocolParams": { + "a0": 0.0, + "decentralisationParam": 0, + "eMax": 18, + "extraEntropy": { + "tag": "NeutralNonce" + }, + "keyDeposit": 0, + "maxBlockBodySize": 65536, + "maxBlockHeaderSize": 1100, + "maxTxSize": 16384, + "minFeeA": 44, + "minFeeB": 155381, + "minPoolCost": 0, + "minUTxOValue": 0, + "nOpt": 100, + "poolDeposit": 0, + "protocolVersion": { + "major": 7, + "minor": 0 + }, + "rho": 0.1, + "tau": 0.1 + }, + "slotsPerKESPeriod": 129600, + "staking": { + "pools": { + "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60": { + "cost": 0, + "margin": 0.0, + "metadata": null, + "owners": [], + "pledge": 0, + "publicKey": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60", + "relays": [], + "rewardAccount": { + "credential": { + "key hash": "b6ffb20cf821f9286802235841d4348a2c2bafd4f73092b7de6655ea" + }, + "network": "Testnet" + }, + "vrf": "fec17ed60cbf2ec5be3f061fb4de0b6ef1f20947cfbfce5fb2783d12f3f69ff5" + } + }, + "stake": { + "074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60" + } + }, + "systemStart": "2024-02-19T13:16:48Z", + "updateQuorum": 2 +} diff --git a/devnet/kes.skey b/devnet/kes.skey new file mode 100644 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 100644 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 100644 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 100644 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 100644 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/docs/goals_and_soa.md b/docs/goals_and_soa.md index c8324af..547e83e 100644 --- a/docs/goals_and_soa.md +++ b/docs/goals_and_soa.md @@ -18,7 +18,7 @@ are covering our high-level goals. 1. DApp logic as whole (synced-by-construction) 2. Code is free from common security weaknesses by construction (secure-by-construction) -3. Seamplessly emulate and test anything (emulate-anything) +3. Seamlessly emulate and test anything (emulate-anything) 4. Declarativity close to informal specification and bridging lightweight formal methods (declarative-spec) 5. Generally production ready (production-ready) @@ -40,7 +40,7 @@ are covering our high-level goals. ## Reference apps Those are list of open-source DApps, -what we use to demonstrate problems in folloging: +what we use to demonstrate problems in folloving: * Audited production DApps * Agora @@ -167,6 +167,7 @@ real blockchain behaviour may lead to flacky test behaviour. Our script stages abstraction cover all those kind of problems. * @todo #3: document problems with slots + * https://github.com/mlabs-haskell/hydra-auction/issues/236 * @todo #3: bug example 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..7390b1c --- /dev/null +++ b/src-lib/cardano-extras/Cardano/Extras.hs @@ -0,0 +1,225 @@ +{- | 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), IsScriptWitnessInCtx (..), IsShelleyBasedEra (..), Key (..), KeyWitnessInCtx (..), NetworkId (..), PaymentKey, PlutusScript, PolicyId (..), Quantity (..), ScriptDatum (..), ScriptRedeemer, ScriptWitness (..), SigningKey (..), TextEnvelopeError (TextEnvelopeAesonDecodeError), TxIn, 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 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 + +deriving instance (Eq (SigningKey PaymentKey)) + +-- | 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) + +mkInlinedDatumScriptWitness :: + (ToData a) => + PlutusScript PlutusLang -> + a -> + BuildTxWith BuildTx (Witness WitCtxTxIn Era) +mkInlinedDatumScriptWitness script redeemer = + BuildTxWith $ + ScriptWitness scriptWitnessInCtx $ + mkScriptWitness + script + InlineScriptDatum + (unsafeHashableScriptData $ fromPlutusData $ toData redeemer) + +-- | Fields +txOutValue :: TxOut ctx Era -> Value +txOutValue (TxOut _ value _ _) = txOutValueToValue value + +mTxOutDatum :: TxOut ctx Era -> Maybe _ +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..da11622 --- /dev/null +++ b/src-lib/cardano-extras/Plutus/Extras.hs @@ -0,0 +1,46 @@ +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 + +-- | 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 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..185ac77 --- /dev/null +++ b/src/Cardano/CEM.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM where + +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 +import Data.Spine + +data AddressSpec + = ByAddress Address + | ByPubKey PubKeyHash + | BySameScript + deriving stock (Show, Prelude.Eq) + +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) + +{-# INLINEABLE bySameCEM #-} +-- TODO: rename +bySameCEM :: + (ToData (State script), CEMScript script) => + State script -> + TxFanFilter' script +bySameCEM = BySameCEM . toBuiltinData + +-- TODO: use natural numbers +data Quantor = Exist Integer | SumValueEq Value + +data TxFanKind = In | InRef | Out + deriving stock (Prelude.Eq, Prelude.Show) + +data TxFanConstraint script = MkTxFanC + { txFanCKind :: TxFanKind + , txFanCFilter :: TxFanFilter script + , txFanCQuantor :: Quantor + } + +-- 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 = transtion | transtion -> 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] + } + +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) + +-- Bunch of conditional `IsData` instances +-- Plutus TH utils does not work for that case + +instance + (ToData (Params script), ToData (StageParams (Stage script))) => + ToData (CEMParams script) + where + toBuiltinData (MkCEMParams {..}) = + BuiltinData $ List [toData scriptParams, toData stagesParams] + +instance + (FromData (Params script), FromData (StageParams (Stage script))) => + FromData (CEMParams script) + where + fromBuiltinData (BuiltinData (List [scriptParams, stagesParams])) = + MkCEMParams <$> fromData scriptParams <*> fromData stagesParams + fromBuiltinData _ = Nothing + +-- 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..bf1c6d2 --- /dev/null +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.Examples.Auction where + +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.Prelude +import PlutusTx.Show.TH (deriveShow) + +import Cardano.CEM +import Cardano.CEM.Stages +import Data.Spine + +-- Simple no-deposit auction + +data SimpleAuction + +data Bet = 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 + | CurrentBet Bet + | Winner Bet + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionParams = MkAuctionParams + { seller :: PubKeyHash + , lot :: Value + } + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionTransition + = Create + | Start + | MakeBet Bet + | Close + | -- TODO: discuss detirminancy + Buyout {payingFrom :: Address} + deriving stock (Prelude.Eq, Prelude.Show) + +PlutusTx.unstableMakeIsData ''Bet +PlutusTx.unstableMakeIsData 'MkAuctionParams +PlutusTx.unstableMakeIsData 'NotStarted +PlutusTx.unstableMakeIsData 'MakeBet +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)) + , (MakeBetSpine, (Open, Just CurrentBetSpine)) + , (CloseSpine, (Closed, Just CurrentBetSpine)) + , (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) + , MkTxFanC Out (MkTxFanFilter BySameScript (bySameCEM NotStarted)) (SumValueEq $ lot params) + ] + , signers = [seller params] + } + (Just NotStarted, Start) -> + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC + In + (MkTxFanFilter (ByPubKey (seller params)) Anything) + (SumValueEq $ lot params) + , MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM (CurrentBet initialBet))) + (Exist 1) + ] + , signers = [seller params] + } + (Just (CurrentBet currentBet), MakeBet newBet) -> + -- Example: could be parametrized with param or typeclass + if betAmount newBet > betAmount currentBet + then + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM (CurrentBet newBet))) + (SumValueEq $ lot params) + ] + , signers = [better newBet] + } + else Left "Wrong bet amount" + (Just (CurrentBet currentBet), Close) -> + Right + $ MkTransitionSpec + { constraints = + saveLotConstraints + <> [ MkTxFanC Out (MkTxFanFilter BySameScript (bySameCEM (Winner currentBet))) (Exist 1) + ] + , signers = [seller params] + } + (Just (Winner winnerBet), Buyout {payingFrom}) -> + Right + $ MkTransitionSpec + { constraints = + [ -- Example: In constraints redundant for on-chain + MkTxFanC + Out + (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) + (SumValueEq $ lot params) + , MkTxFanC + In + (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) + (SumValueEq $ betAdaValue winnerBet) + , MkTxFanC + Out + (MkTxFanFilter (ByPubKey (seller params)) Anything) + (SumValueEq $ betAdaValue winnerBet) + ] + , signers = [better winnerBet] + } + _ -> Left "Incorrect state for transition" + where + initialBet = MkBet (seller params) 0 + saveLotConstraints = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript Anything) + (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..909bf57 --- /dev/null +++ b/src/Cardano/CEM/Examples/Compilation.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoPolyKinds #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.CEM.Examples.Compilation where + +import PlutusTx qualified + +import Data.Proxy (Proxy (..)) + +import PlutusLedgerApi.V2 (ScriptContext (ScriptContext), serialiseCompiledCode) + +import Cardano.Api (PlutusScript) +import Cardano.CEM +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Examples.Voting +import Cardano.CEM.OnChain (CEMScriptCompiled (..), genericCEMScript) +import Cardano.CEM.Stages (SingleStage) +import Plutus.Extras + +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..70cc479 --- /dev/null +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -0,0 +1,150 @@ +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} + +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.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 + +instance Eq VoteValue where + Yes == Yes = True + No == No = True + Abstain == Abstain = True + _ == _ = False + +-- TODO +data JuryPolicy = Anyone | FixedJuryList [PubKeyHash] | WithToken Value + +-- Stub + +data VoteStorage = MkVoteStorage + +emptyVoteStorage :: VoteStorage +emptyVoteStorage = MkVoteStorage + +addVote :: PubKeyHash -> VoteValue -> VoteStorage -> Either BuiltinString VoteStorage +addVote = traceError "Implementation is not important for example" + +countVotes :: VoteStorage -> VoteValue +countVotes = traceError "Implementation is not important for example" + +data SimpleVotingParams = MkVotingParams + { disputeDescription :: BuiltinByteString + , creator :: PubKeyHash + , juryPolicy :: JuryPolicy + , abstainAllowed :: Bool + } + +data SimpleVotingState + = NotStarted + | InProgress VoteStorage + | Finalized VoteValue + +data SimpleVotingTransition + = Start + | Vote PubKeyHash VoteValue + | Finalize + +PlutusTx.unstableMakeIsData ''VoteStorage +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 + [ (StartSpine, (Always, Just NotStartedSpine)) + , (VoteSpine, (Always, Just InProgressSpine)) + , (FinalizeSpine, (Always, Just InProgressSpine)) + ] + + {-# INLINEABLE transitionSpec #-} + transitionSpec params state transition = + case (state, transition) of + (Just NotStarted, Start) -> + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM $ InProgress emptyVoteStorage)) + (Exist 1) + ] + , 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 = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM $ InProgress newVoteStorage)) + (Exist 1) + ] + ++ allowedToVoteConstraints + , signers = [jury] + } + (Just (InProgress votes), Finalize) -> + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM $ Finalized (countVotes votes))) + (Exist 1) + ] + , signers = [creator params] + } + _ -> Left "Wrong state transition" where diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs new file mode 100644 index 0000000..16d013e --- /dev/null +++ b/src/Cardano/CEM/Monads.hs @@ -0,0 +1,344 @@ +module Cardano.CEM.Monads where + +import Prelude + +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Data (Proxy (..)) +import Data.Map qualified as Map +import Data.Set (Set) + +-- import Control.Monad.Trans.Either (EitherT(..)) + +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.CEM +import Cardano.CEM.OnChain +import Cardano.Extras +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 Debug.Trace (trace, traceM) +import Text.Show.Pretty (ppShow) + +-- MonadBlockchainParams + +-- @todo #13: Derive stock classes for cardano-api + +-- | Params of blockchain required for transaction-building +data BlockchainParams = MkBlockchainParams + { protocolParameters :: PParams LedgerEra + , systemStart :: SystemStart + , eraHistory :: EraHistory + , stakePools :: Set PoolId + } + +{- | This monad gives access to all information about Cardano params, + | which is various kind of Ledger params and ValidityBound/Slots semantics +-} + +-- @todo #13: Implement PSM for `MonadBlockchainParams` (task for Michal) +class (MonadFail m) => MonadBlockchainParams m where + askNetworkId :: m NetworkId + queryCurrentSlot :: m SlotNo + queryBlockchainParams :: m BlockchainParams + +fromPlutusAddressInMonad :: + (MonadBlockchainParams m) => Address -> m (AddressInEra Era) +fromPlutusAddressInMonad address = do + networkId <- askNetworkId + return $ fromPlutusAddress networkId address + +-- MonadQuery + +data UtxoQuery + = ByAddresses [Address] + | ByTxIns [TxIn] + deriving stock (Show, Eq) + +class (MonadBlockchainParams m) => MonadQueryUtxo m where + queryUtxo :: UtxoQuery -> m (UTxO Era) + +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 + +-- MonadSubmit + +data ResolvedTx = MkResolvedTx + { txIns :: [(TxIn, TxInWitness)] + , txInsReference :: [TxIn] + , txOuts :: [TxOut CtxTx Era] + , toMint :: TxMintValue BuildTx Era + , interval :: Interval POSIXTime + , signors :: [SigningKey PaymentKey] + } + deriving stock (Show, Eq) + +data WrongSlotKind = Early | Late + deriving stock (Show, Eq) + +data TxSubmittingError + = WrongSlot WrongSlotKind Integer + | TxInOutdated [TxIn] + | UnhandledNodeError String + deriving stock (Show, Eq) + +class (MonadQueryUtxo m) => MonadSubmitTx m where + submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId) + +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) + +deriving stock instance + ( Show (CEMParams script) + , Show (State script) + , Show (Transition script) + ) => + Show (CEMAction script) + +-- deriving instance +-- ( Eq (State script) +-- , Eq (CEMParams script) +-- , Eq (Transition script) +-- ) => +-- Eq (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) + +data TransitionError + = StateMachineError + { errorMessage :: String + } + | MissingTransitionInputh + 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)) = + 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 + + let + byKind kind = + filter (\x -> txFanCKind x == kind) $ + constraints scriptTransition + + txIns <- concat <$> mapM resolveTxIn (byKind In) + txOuts <- concat <$> mapM compileTxConstraint (byKind Out) + + return $ + MkResolvedTx + { txIns = witnesedScriptTxIns ++ txIns + , txInsReference = [] + , txOuts + , toMint = TxMintNone + , signors = [] + , interval = always + } + where + script = cemScriptCompiled (Proxy :: Proxy script) + scriptAddress = cemScriptAddress (Proxy :: Proxy script) + resolveTxIn (MkTxFanC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do + utxo <- lift $ queryUtxo $ ByAddresses [address] + return $ map withKeyWitness $ Map.keys $ 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] + where + datum = case filterSpec of + Anything -> TxOutDatumNone + ByDatum datum' -> mkInlineDatum datum' + BySameCEM 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 2_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' {signors = map signerKey $ specSigners spec} + + -- TODO + utxo <- lift $ queryUtxo $ ByAddresses [signingKeyToAddress $ head $ signors mergedSpec] + let ins = + map withKeyWitness $ Map.keys $ unUTxO utxo + + result <- lift $ submitResolvedTx $ mergedSpec {txIns = (txIns mergedSpec) ++ ins} + case result of + Right txId -> return txId + Left resolveError -> throwError $ UnhandledSubmittingError resolveError diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs new file mode 100644 index 0000000..538f3a5 --- /dev/null +++ b/src/Cardano/CEM/Monads/L1.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE RecordWildCards #-} + +module Cardano.CEM.Monads.L1 where + +import Prelude + +import Text.Show.Pretty + +import Control.Monad.Reader (MonadReader (..), ReaderT (..)) +import Control.Monad.Trans (MonadIO (..)) +import Data.Set qualified as Set +import Unsafe.Coerce (unsafeCoerce) + +import Data.Aeson +import Data.Aeson.KeyMap ((!?)) + +-- Cardano imports +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley (LedgerProtocolParameters (..), ) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) + +-- CEM imports + +import Cardano.CEM +import Cardano.CEM.Monads +import Cardano.Extras +import Control.Exception (throwIO) +import Data.Bifunctor (Bifunctor (..)) +import Data.Map qualified as Map + +data 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 + <$> queryCardanoNode (convertEra QueryProtocolParameters) + <*> queryCardanoNode (convertEra QuerySystemStart) + <*> queryCardanoNode (convertEra QueryEraHistory) + <*> queryCardanoNode (convertEra QueryStakePools) + where + -- TODO + convertEra = unsafeCoerce + +-- TODO: cardano-api-extras +-- Design inspired by `Hydra.Chain.CardanoClient` helpers +queryCardanoNode :: + QueryInShelleyBasedEra Era b -> L1Runner b +queryCardanoNode query = do + node <- localNode <$> ask + result <- liftIO $ queryNodeLocalState node VolatileTip cardanoQuery + return $ case result of + -- TODO: better handling of wrong-era exceptions + Right (Right x) -> x + _ -> error "Unhandled Cardano API error" + where + cardanoQuery = + QueryInEra $ QueryInShelleyBasedEra ShelleyBasedEraBabbage query + +instance MonadQueryUtxo L1Runner where + queryUtxo query = do + utxoQuery <- case query of + ByTxIns txIns -> + return $ QueryUTxOByTxIn (Set.fromList txIns) + ByAddresses addresses -> do + cardanoAdresses <- + map addressInEraToAny <$> mapM fromPlutusAddressInMonad addresses + return $ QueryUTxOByAddress (Set.fromList cardanoAdresses) + queryCardanoNode $ QueryUTxO utxoQuery + +instance MonadSubmitTx L1Runner where + submitResolvedTx :: ResolvedTx -> L1Runner (Either TxSubmittingError TxId) + submitResolvedTx 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 = + TxExtraKeyWitnesses AlonzoEraOnwardsBabbage $ + fmap (verificationKeyHash . getVerificationKey) signors + , txProtocolParams = + BuildTxWith $ + Just $ + LedgerProtocolParameters protocolParameters + , txValidityLowerBound = + TxValidityNoLowerBound + , txValidityUpperBound = + TxValidityUpperBound ShelleyBasedEraBabbage Nothing + , -- Fee stubs + txTotalCollateral = TxTotalCollateralNone + , txReturnCollateral = TxReturnCollateralNone + , txFee = TxFeeExplicit ShelleyBasedEraBabbage 0 + , -- Not supported fatures + txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txScriptValidity = TxScriptValidityNone + , txProposalProcedures = Nothing + , txVotingProcedures = Nothing + } + + let + mainSignor = signors !! 0 + mainAddress' = signingKeyToAddress mainSignor + + mainAddress <- fromPlutusAddressInMonad mainAddress' + utxo <- queryUtxo $ ByTxIns $ map fst txIns + + body <- + either (\x -> fail $ "Autobalance error: " <> show x) return + =<< callBodyAutoBalance + preBody + utxo + mainAddress + + let + tx = makeSignedTransactionWithKeys signors body + txInMode = TxInMode ShelleyBasedEraBabbage tx + + -- liftIO $ pPrint tx + ci <- localNode <$> ask + liftIO $ + submitTxToNodeLocal ci txInMode >>= \case + SubmitSuccess -> + return $ Right $ getTxId body + SubmitFail e -> + return $ Left $ UnhandledNodeError $ show e + -- case parseError e of + -- ApplyTxError x -> + -- return $ Left $ UnhandledNodeError $ show x + where + +-- parseError wrapper = case wrapper of +-- TxValidationErrorInCardanoMode error -> +-- fromJSON (toJSON error .: "error") :: ApplyTxError _ + +-- 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 + (toLedgerEpochInfo 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 + +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/OnChain.hs b/src/Cardano/CEM/OnChain.hs new file mode 100644 index 0000000..1e79b9c --- /dev/null +++ b/src/Cardano/CEM/OnChain.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.OnChain where + +import PlutusTx.Prelude +import Prelude qualified + +import Data.Proxy + +import PlutusLedgerApi.Common (SerialisedScript) +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress, 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) + ) + +-- TODO: document hacks +-- 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 + BySameCEM 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' :: + Params $(conT script) -> _ -> _ -> Either BuiltinString (TransitionSpec $(conT script)) + transitionSpec' = transitionSpec @($(conT script)) + stageToOnChainInterval' :: StageParams $(conT scriptStage) -> $(conT scriptStage) -> _ + 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 result + 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..1669625 --- /dev/null +++ b/src/Cardano/CEM/Stages.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.Stages where + +import PlutusTx 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 + +data SingleStageParams + = NoSingleStageParams + | AllowedInterval (Interval POSIXTime) + +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/Main.hs b/test/Main.hs new file mode 100644 index 0000000..7ce4747 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,330 @@ +module Main (main) where + +import Prelude hiding (readFile) + +import Control.Monad.Trans +import Data.ByteString (putStr, readFile) +import System.Random + +import Text.Show.Pretty + +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley (ReferenceScript (..), toMaryValue) + +import Cardano.CEM +import Cardano.CEM.Examples.Compilation + +-- import Cardano.CEM.Examples.Escrow +import Cardano.CEM.Monads +import Cardano.CEM.Monads.L1 +import Cardano.CEM.Stages +import Cardano.Extras + +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Examples.Auction (SimpleAuctionState (CurrentBet, NotStarted)) +import Cardano.CEM.Monads (queryScriptState) +import Cardano.Ledger.Val (adaOnly) +import Data.Map (elems, keys) +import PlutusLedgerApi.V1.Address (pubKeyHashAddress) +import PlutusLedgerApi.V1.Interval (always) +import PlutusLedgerApi.V1.Value (adaSymbol, adaToken, assetClass, assetClassValue) +import Test.Hspec (around, describe, hspec, it, shouldBe, shouldSatisfy) +import Unsafe.Coerce (unsafeCoerce) + +data TestContext = MkTestContext + { testEnvKeys :: [SigningKey PaymentKey] + } + +keysPaths = + [ "./devnet/credentials/faucet.sk" + , "./devnet/credentials/bob.sk" + , "./devnet/credentials/carol.sk" + ] + +readTestContext :: IO (TestContext) +readTestContext = do + testEnvKeys <- mapM readKey keysPaths + return (MkTestContext {testEnvKeys}) + where + readKey path = do + Just key <- liftIO $ parseSigningKeyTE <$> readFile path + return key + +withContext :: (TestContext -> IO ()) -> IO () +withContext action = do + context <- readTestContext + action context + +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) + +submitAndCheck spec = do + case head $ actions spec of + MkSomeCEMAction (MkCEMAction _ transition) -> + liftIO $ putStrLn $ "Doing " <> show transition + result <- resolveTxAndSubmit spec + case result of + Right txId -> do + awaitTx txId + liftIO $ putStrLn $ "Awaited " <> show txId + Left error -> fail $ show error + +main :: IO () +main = hspec $ around withContext $ do + describe "Checking monad works" $ do + it "Asking NetworkId works" $ \_context -> execOnLocalDevnet $ do + networkId <- askNetworkId + liftIO $ networkId `shouldBe` localDevnetNetworkId + it "Querying blockchain params works" $ \_context -> execOnLocalDevnet $ do + _slotNo <- queryCurrentSlot + _blockchainParams <- queryBlockchainParams + return () + it "Querying UTxO works" $ \context -> execOnLocalDevnet $ do + utxo <- + queryUtxo $ + ByAddresses + [ signingKeyToAddress $ testEnvKeys context !! 0 + ] + return () + it "Sending transaction works" $ \context -> execOnLocalDevnet $ do + utxo <- + queryUtxo $ + ByAddresses + [ signingKeyToAddress $ testEnvKeys context !! 0 + ] + + user1Address <- + fromPlutusAddressInMonad $ signingKeyToAddress $ testEnvKeys context !! 0 + user2Address <- + fromPlutusAddressInMonad $ signingKeyToAddress $ testEnvKeys context !! 1 + let + user1TxIns = keys $ unUTxO utxo + Just value = valueToLovelace $ utxoValue utxo + convert x = + TxOutValueShelleyBased shelleyBasedEra $ + toMaryValue x + out userAddress = + TxOut + userAddress + (convert $ lovelaceToValue $ fromInteger 10_000_000) + TxOutDatumNone + ReferenceScriptNone + tx = + MkResolvedTx + { txIns = map withKeyWitness user1TxIns + , txInsReference = [] + , txOuts = + [ out user1Address + , out user2Address + ] + , toMint = TxMintNone + , interval = always + , signors = [testEnvKeys context !! 0] + } + Right txId <- submitResolvedTx tx + checkTxCreated txId + + return () + + describe "SimpleAuction usecase" $ do + it "Wrong transition resolution error" $ \context -> execOnLocalDevnet $ do + let + seller = testEnvKeys context !! 0 + bidder1 = testEnvKeys context !! 1 + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + (assetClass adaSymbol adaToken) + 10_000_000 + } + , stagesParams = NoControl + } + + 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 (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) <- + return result + + return () + + it "Wrong bid resolution error" $ \context -> execOnLocalDevnet $ do + let + seller = testEnvKeys context !! 0 + bidder1 = testEnvKeys context !! 1 + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + (assetClass adaSymbol adaToken) + 10_000_000 + } + , stagesParams = NoControl + } + + 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 (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) <- + return result + + return () + + it "Successful transition flow" $ \context -> execOnLocalDevnet $ do + -- XXX: blockchain state is reused, so we need to differentiate Utxos + paramJitter <- liftIO $ getStdRandom (randomR (0, 1_000_000)) + let + seller = testEnvKeys context !! 0 + bidder1 = testEnvKeys context !! 1 + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + (assetClass adaSymbol adaToken) + (10_000_000 + paramJitter) + } + , stagesParams = NoControl + } + + 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 (CurrentBet currentBid') <- queryScriptState auctionParams + liftIO $ currentBid' `shouldBe` initBid + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + + Just (CurrentBet currentBid) <- queryScriptState auctionParams + liftIO $ currentBid `shouldBe` bid1 + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Close + ] + , specSigners = [mkMainSigner seller] + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (Buyout $ signingKeyToAddress bidder1) + ] + , specSigners = [mkMainSigner bidder1] + }