diff --git a/README.md b/README.md index 0ee317a7..ed6cc5d3 100644 --- a/README.md +++ b/README.md @@ -12,14 +12,13 @@ Supported features: - pre balance tx (adding minimum amount of tx inputs based on fee and tx output value, balancing non ada outputs) - mint tokens, and send them to arbitrary address(es) - redeem utxos from validator scripts, using the correct datum and redeemer (scripts, datums and redeemers are persisted in files for now) +- use validity time ranges +- waiting for slots Unsupported/In development - wallet integration -- chain-index integration (in progress) -- handling on-chain events (utxo set change, waiting for slot, etc.) -- multisig -- automated tests +- handling on-chain events (utxo set change, etc.) ## How to use this? @@ -40,6 +39,10 @@ data MyContracts 2. Define a HasDefinitions instance for the endpoints ```haskell +import BotPlutusInterface.Types (HasDefinitions (..), SomeBuiltin (..), endpointsToSchemas) +import Playground.Types (FunctionSchema) +import Schema (FormSchema) + instance HasDefinitions MyContracts where getDefinitions :: [MyContract] getDefinitions = [] @@ -62,21 +65,38 @@ instance HasDefinitions MyContracts where 3. Write your main entrypoint for the application, with the preferred configurations ```haskell +import BotPlutusInterface.Types (CLILocation (Local), LogLevel (Debug), PABConfig (..)) +import Cardano.Api (NetworkId (Testnet), NetworkMagic (..)) +import Data.Aeson qualified as JSON +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Default (def) +import Servant.Client.Core (BaseUrl (BaseUrl), Scheme (Http)) + main :: IO () main = do protocolParams <- JSON.decode <$> LazyByteString.readFile "protocol.json" let pabConf = PABConfig - { -- Calling the cli through ssh when set to Remote - pcCliLocation = Remote "11.22.33.44" + { -- Calling the cli locally or through an ssh connection + pcCliLocation = Local , pcNetwork = Testnet (NetworkMagic 42) + , pcChainIndexUrl = BaseUrl Http "localhost" 9083 "" + , pcPort = 9080 , pcProtocolParams = protocolParams + , -- | Slot configuration of the network, the default value can be used for the mainnet + pcSlotConfig = def + , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546" , -- Directory name of the script and data files - pcScriptFileDir = "result-scripts" + pcScriptFileDir = "./scripts" + , -- Directory for the signing key file(s) + pcSigningKeyFileDir = "./signing-keys" + , -- Directory where the encoded transaction files will be saved + pcTxFileDir = "./txs" , -- Dry run mode will build the tx, but skip the submit step pcDryRun = False + , pcLogLevel = Debug , -- Protocol params file location relative to the cardano-cli working directory (needed for the cli) - pcProtocolParamsFile = "./protocol.json" + , pcProtocolParamsFile = "./protocol.json" } BotPlutusInterface.runPAB @MyContracts pabConf ``` @@ -107,7 +127,7 @@ The fake PAB consists of the following modules: - **BotPlutusInterface.Contract** handling contract effects by creating the necessary files and calling cardano-cli commands (a few effects are mocked) - **BotPlutusInterface.PreBalance** doing some preparations so the cli can process the rest (non-ada asset balancing, addig tx inputs, adding minimum lovelaces, add signatories) - **BotPlutusInterface.CardanoCLI** wrappers for cardano-cli commands -- For development purposes, I created an ssh wrapper, so I can call relay these commands through an ssh connection. This is not nice, unsafe, and pretty slow, so I'm hoping to get rid of this pretty soon. +- For development purposes, I created an ssh wrapper, so I can call relay these commands through an ssh connection. This is not nice, unsafe, and pretty slow, avoid using it if you can. - **BotPlutusInterface.UtxoParser** parse the output of the `cardano-cli query utxo` command - **BotPlutusInterface.Files** functions for handling script, datum and redeemer files - **BotPlutusInterface.Types** configuration for the fake pab diff --git a/examples/plutus-game/README.md b/examples/plutus-game/README.md index 331a1d67..874fe501 100644 --- a/examples/plutus-game/README.md +++ b/examples/plutus-game/README.md @@ -1,7 +1,3 @@ -### plutus-helloworld +### plutus-game -This directory contains a simple "Hello World" script. There are two versions: one using an integer literal (needed because the Plutus interpreter doesn't currently accept byte string literals) and a slighly more complicated one using a bytestring parameter. - -``plutus-helloworld'' -- very simple numeric version - -``plutus-helloworld-bytestring'' -- more compex version using bytestring constant +Simple guessing game contract to demonstrate locking and redeeming funds with datums and redeemers diff --git a/examples/plutus-game/app/Main.hs b/examples/plutus-game/app/Main.hs index 074420bd..ded25b77 100644 --- a/examples/plutus-game/app/Main.hs +++ b/examples/plutus-game/app/Main.hs @@ -22,6 +22,7 @@ import Cardano.PlutusExample.Game ( import Data.Aeson qualified as JSON import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.ByteString.Lazy qualified as LazyByteString +import Data.Default (def) import Data.Maybe (fromMaybe) import Playground.Types (FunctionSchema) import Schema (FormSchema) @@ -57,6 +58,7 @@ main = do , pcChainIndexUrl = BaseUrl Http "localhost" 9083 "" , pcPort = 9080 , pcProtocolParams = protocolParams + , pcSlotConfig = def , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546" , pcScriptFileDir = "./scripts" , pcSigningKeyFileDir = "./signing-keys" diff --git a/examples/plutus-game/plutus-game.cabal b/examples/plutus-game/plutus-game.cabal index a04e4f52..109069f6 100644 --- a/examples/plutus-game/plutus-game.cabal +++ b/examples/plutus-game/plutus-game.cabal @@ -129,6 +129,7 @@ executable plutus-game-pab , bot-plutus-interface , bytestring , cardano-api + , data-default , playground-common , plutus-game , plutus-ledger diff --git a/examples/plutus-nft/README.md b/examples/plutus-nft/README.md index 331a1d67..7bb722af 100644 --- a/examples/plutus-nft/README.md +++ b/examples/plutus-nft/README.md @@ -1,7 +1,3 @@ -### plutus-helloworld +### plutus-nft -This directory contains a simple "Hello World" script. There are two versions: one using an integer literal (needed because the Plutus interpreter doesn't currently accept byte string literals) and a slighly more complicated one using a bytestring parameter. - -``plutus-helloworld'' -- very simple numeric version - -``plutus-helloworld-bytestring'' -- more compex version using bytestring constant +Simple NFT schema to demonstrate token minting. diff --git a/examples/plutus-nft/app/Main.hs b/examples/plutus-nft/app/Main.hs index 783a5383..8c3de429 100644 --- a/examples/plutus-nft/app/Main.hs +++ b/examples/plutus-nft/app/Main.hs @@ -20,6 +20,7 @@ import Cardano.PlutusExample.NFT ( import Data.Aeson qualified as JSON import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.ByteString.Lazy qualified as LazyByteString +import Data.Default (def) import Data.Maybe (fromMaybe) import Ledger.Value (TokenName) import Playground.Types (FunctionSchema) @@ -57,6 +58,7 @@ main = do , pcChainIndexUrl = BaseUrl Http "localhost" 9083 "" , pcPort = 9080 , pcProtocolParams = protocolParams + , pcSlotConfig = def , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546" , pcScriptFileDir = "./scripts" , pcSigningKeyFileDir = "./signing-keys" diff --git a/examples/plutus-nft/plutus-nft.cabal b/examples/plutus-nft/plutus-nft.cabal index e0354525..a02c2e02 100644 --- a/examples/plutus-nft/plutus-nft.cabal +++ b/examples/plutus-nft/plutus-nft.cabal @@ -129,6 +129,7 @@ executable plutus-nft-pab , bot-plutus-interface , bytestring , cardano-api + , data-default , playground-common , plutus-ledger , plutus-nft diff --git a/examples/plutus-transfer/.gitignore b/examples/plutus-transfer/.gitignore new file mode 100644 index 00000000..5dd5d31e --- /dev/null +++ b/examples/plutus-transfer/.gitignore @@ -0,0 +1,3 @@ +scripts +signing-keys +txs diff --git a/examples/plutus-transfer/README.md b/examples/plutus-transfer/README.md new file mode 100644 index 00000000..491feaca --- /dev/null +++ b/examples/plutus-transfer/README.md @@ -0,0 +1,5 @@ +### plutus-transfer + +Simple value transfer from an address to multiple addresses. With the tfpOutputPerTx option, +payment tx outputs can be grouped together into separate txs, the Contract waits for at least one +block in between. diff --git a/examples/plutus-transfer/ada-transfer.sh b/examples/plutus-transfer/ada-transfer.sh new file mode 100755 index 00000000..ec575ed1 --- /dev/null +++ b/examples/plutus-transfer/ada-transfer.sh @@ -0,0 +1,19 @@ +#!/bin/sh +CONTRACT_INST_ID=$(curl --location --request POST 'localhost:9080/api/contract/activate' \ + --header 'Content-Type: application/json' \ + --data-raw '{ + "caID": { + "tfpOutputPerTx": 50, + "tfpPayments": [ + [ {"getPubKeyHash": "981fc565bcf0c95c0cfa6ee6693875b60d529d87ed7082e9bf03c6a4"}, + {"getValue": [[{"unCurrencySymbol":""},[[{"unTokenName": ""}, 1500000]]]]} + ] + ] + } + }' | jq -r .unContractInstanceId ) + +echo $CONTRACT_INST_ID + + +echo "{ \"tag\": \"Subscribe\", \"contents\": { \"Left\": { \"unContractInstanceId\":\"$CONTRACT_INST_ID\" } } }" | websocat -n ws://localhost:9080/ws + diff --git a/examples/plutus-transfer/app/Main.hs b/examples/plutus-transfer/app/Main.hs new file mode 100644 index 00000000..8e431d06 --- /dev/null +++ b/examples/plutus-transfer/app/Main.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +import BotPlutusInterface qualified +import BotPlutusInterface.Types ( + CLILocation (Local), + HasDefinitions (..), + LogLevel (Debug), + PABConfig (..), + SomeBuiltin (..), + endpointsToSchemas, + ) +import Cardano.Api (NetworkId (Testnet), NetworkMagic (..)) +import Cardano.PlutusExample.Transfer ( + TransferParams, + TransferSchema, + transfer, + ) +import Data.Aeson qualified as JSON +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Default (def) +import Data.Maybe (fromMaybe) +import Playground.Types (FunctionSchema) +import Schema (FormSchema) +import Servant.Client.Core (BaseUrl (BaseUrl), Scheme (Http)) +import Prelude + +instance HasDefinitions TransferContracts where + getDefinitions :: [TransferContracts] + getDefinitions = [] + + getSchema :: TransferContracts -> [FunctionSchema FormSchema] + getSchema _ = endpointsToSchemas @TransferSchema + + getContract :: (TransferContracts -> SomeBuiltin) + getContract = \case + Transfer payments -> + SomeBuiltin $ transfer payments + +newtype TransferContracts = Transfer TransferParams + deriving stock (Show) + +$(deriveJSON defaultOptions ''TransferContracts) + +main :: IO () +main = do + protocolParams <- + fromMaybe (error "protocol.json file not found") . JSON.decode + <$> LazyByteString.readFile "protocol.json" + let pabConf = + PABConfig + { pcCliLocation = Local + , pcNetwork = Testnet (NetworkMagic 1097911063) + , pcChainIndexUrl = BaseUrl Http "localhost" 9083 "" + , pcPort = 9080 + , pcProtocolParams = protocolParams + , pcSlotConfig = def + , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546" + , pcScriptFileDir = "./scripts" + , pcSigningKeyFileDir = "./signing-keys" + , pcTxFileDir = "./txs" + , pcDryRun = True + , pcLogLevel = Debug + , pcProtocolParamsFile = "./protocol.json" + } + BotPlutusInterface.runPAB @TransferContracts pabConf diff --git a/examples/plutus-transfer/cabal.project b/examples/plutus-transfer/cabal.project new file mode 100644 index 00000000..85897a86 --- /dev/null +++ b/examples/plutus-transfer/cabal.project @@ -0,0 +1,14 @@ +-- Bump this if you need newer packages +index-state: 2021-10-20T00:00:00Z + +packages: + ./. + ../../. + +-- You never, ever, want this. +write-ghc-environment-files: never + +-- Always build tests and benchmarks. +tests: true +benchmarks: true + diff --git a/examples/plutus-transfer/hie.yaml b/examples/plutus-transfer/hie.yaml new file mode 100644 index 00000000..8f9e41c8 --- /dev/null +++ b/examples/plutus-transfer/hie.yaml @@ -0,0 +1,7 @@ +cradle: + cabal: + - path: "./src" + component: "lib:plutus-nft" + + - path: "./app" + component: "exe:plutus-nft-pab" diff --git a/examples/plutus-transfer/plutus-transfer.cabal b/examples/plutus-transfer/plutus-transfer.cabal new file mode 100644 index 00000000..4ff08a19 --- /dev/null +++ b/examples/plutus-transfer/plutus-transfer.cabal @@ -0,0 +1,139 @@ +cabal-version: 3.0 +name: plutus-transfer +version: 0.1.0.0 +synopsis: Simple transfer of Ada and/or native tokens +description: Simple transfer of Ada and/or native tokens +homepage: https://github.com/mlabs-haskell/bot-plutus-interface +bug-reports: https://github.com/mlabs-haskell/bot-plutus-interface +license: +license-file: +author: MLabs +maintainer: gergely@mlabs.city +copyright: TODO +build-type: Simple +tested-with: GHC ==8.10.4 +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/mlabs-haskell/bot-plutus-interface + +-- Common sections + +common common-lang + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -Werror + -fobject-code -fno-ignore-interface-pragmas + -fno-omit-interface-pragmas -fplugin=RecordDotPreprocessor + + build-depends: + , base ^>=4.14 + , record-dot-preprocessor + , record-hasfield + + default-extensions: + NoImplicitPrelude + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NumericUnderscores + OverloadedStrings + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + TypeSynonymInstances + UndecidableInstances + + default-language: Haskell2010 + +-- Libraries + + +library + import: common-lang + exposed-modules: Cardano.PlutusExample.Transfer + build-depends: + , aeson ^>=1.5.0.0 + , attoparsec >=0.13.2.2 + , bytestring ^>=0.10.12.0 + , cardano-api + , cardano-crypto + , cardano-ledger-alonzo + , containers + , data-default + , data-default-class + , directory + , either + , filepath + , freer-extras + , freer-simple + , http-client + , http-types + , lens + , memory + , playground-common + , plutus-chain-index + , plutus-chain-index-core + , plutus-contract + , plutus-core + , plutus-ledger + , plutus-ledger-api + , plutus-ledger-constraints + , plutus-pab + , plutus-tx + , plutus-tx-plugin + , process + , row-types + , serialise + , servant + , servant-client + , servant-server + , servant-websockets + , split + , stm + , text ^>=1.2.4.0 + , transformers + , transformers-either + , uuid + , wai + , warp + , websockets + + hs-source-dirs: src + +executable plutus-transfer-pab + import: common-lang + build-depends: + , aeson ^>=1.5.0.0 + , bot-plutus-interface + , bytestring + , cardano-api + , data-default + , playground-common + , plutus-ledger + , plutus-transfer + , servant-client-core + + main-is: Main.hs + hs-source-dirs: app diff --git a/examples/plutus-transfer/protocol.json b/examples/plutus-transfer/protocol.json new file mode 100644 index 00000000..daa1b5f1 --- /dev/null +++ b/examples/plutus-transfer/protocol.json @@ -0,0 +1,208 @@ +{ + "txFeePerByte": 44, + "minUTxOValue": null, + "decentralization": 0.7, + "utxoCostPerWord": 34482, + "stakePoolDeposit": 0, + "poolRetireMaxEpoch": 18, + "extraPraosEntropy": null, + "collateralPercentage": 150, + "stakePoolTargetNum": 100, + "maxBlockBodySize": 65536, + "minPoolCost": 0, + "maxTxSize": 16384, + "treasuryCut": 0.1, + "maxBlockExecutionUnits": { + "memory": 50000000, + "steps": 40000000000 + }, + "maxCollateralInputs": 3, + "maxValueSize": 5000, + "maxBlockHeaderSize": 1100, + "maxTxExecutionUnits": { + "memory": 10000000, + "steps": 10000000000 + }, + "costModels": { + "PlutusScriptV1": { + "cekConstCost-exBudgetMemory": 100, + "unBData-cpu-arguments": 150000, + "divideInteger-memory-arguments-minimum": 1, + "nullList-cpu-arguments": 150000, + "cekDelayCost-exBudgetMemory": 100, + "appendByteString-cpu-arguments-slope": 621, + "sha2_256-memory-arguments": 4, + "multiplyInteger-cpu-arguments-intercept": 61516, + "iData-cpu-arguments": 150000, + "equalsString-cpu-arguments-intercept": 150000, + "trace-cpu-arguments": 150000, + "lessThanEqualsByteString-cpu-arguments-intercept": 103599, + "encodeUtf8-cpu-arguments-slope": 1000, + "equalsString-cpu-arguments-constant": 1000, + "blake2b-cpu-arguments-slope": 29175, + "consByteString-memory-arguments-intercept": 0, + "headList-cpu-arguments": 150000, + "listData-cpu-arguments": 150000, + "divideInteger-cpu-arguments-model-arguments-slope": 118, + "divideInteger-memory-arguments-slope": 1, + "bData-cpu-arguments": 150000, + "chooseData-memory-arguments": 32, + "cekBuiltinCost-exBudgetCPU": 29773, + "mkNilData-memory-arguments": 32, + "equalsInteger-cpu-arguments-intercept": 136542, + "lengthOfByteString-cpu-arguments": 150000, + "subtractInteger-cpu-arguments-slope": 0, + "unIData-cpu-arguments": 150000, + "sliceByteString-cpu-arguments-slope": 5000, + "unMapData-cpu-arguments": 150000, + "modInteger-cpu-arguments-model-arguments-slope": 118, + "lessThanInteger-cpu-arguments-intercept": 179690, + "appendString-memory-arguments-intercept": 0, + "mkCons-cpu-arguments": 150000, + "sha3_256-cpu-arguments-slope": 82363, + "ifThenElse-cpu-arguments": 1, + "mkNilPairData-cpu-arguments": 150000, + "constrData-memory-arguments": 32, + "lessThanEqualsInteger-cpu-arguments-intercept": 145276, + "addInteger-memory-arguments-slope": 1, + "chooseList-memory-arguments": 32, + "equalsData-memory-arguments": 1, + "decodeUtf8-cpu-arguments-intercept": 150000, + "bData-memory-arguments": 32, + "lessThanByteString-cpu-arguments-slope": 248, + "listData-memory-arguments": 32, + "consByteString-cpu-arguments-intercept": 150000, + "headList-memory-arguments": 32, + "subtractInteger-memory-arguments-slope": 1, + "appendByteString-memory-arguments-intercept": 0, + "unIData-memory-arguments": 32, + "remainderInteger-memory-arguments-minimum": 1, + "lengthOfByteString-memory-arguments": 4, + "encodeUtf8-memory-arguments-intercept": 0, + "cekStartupCost-exBudgetCPU": 100, + "remainderInteger-memory-arguments-slope": 1, + "multiplyInteger-memory-arguments-intercept": 0, + "cekForceCost-exBudgetCPU": 29773, + "unListData-memory-arguments": 32, + "sha2_256-cpu-arguments-slope": 29175, + "indexByteString-memory-arguments": 1, + "equalsInteger-memory-arguments": 1, + "remainderInteger-cpu-arguments-model-arguments-slope": 118, + "cekVarCost-exBudgetCPU": 29773, + "lessThanEqualsInteger-cpu-arguments-slope": 1366, + "addInteger-memory-arguments-intercept": 1, + "sndPair-cpu-arguments": 150000, + "lessThanInteger-memory-arguments": 1, + "cekLamCost-exBudgetCPU": 29773, + "chooseUnit-cpu-arguments": 150000, + "decodeUtf8-cpu-arguments-slope": 1000, + "fstPair-cpu-arguments": 150000, + "quotientInteger-memory-arguments-minimum": 1, + "lessThanEqualsInteger-memory-arguments": 1, + "chooseUnit-memory-arguments": 32, + "fstPair-memory-arguments": 32, + "quotientInteger-cpu-arguments-constant": 148000, + "mapData-cpu-arguments": 150000, + "unConstrData-cpu-arguments": 150000, + "mkPairData-cpu-arguments": 150000, + "sndPair-memory-arguments": 32, + "decodeUtf8-memory-arguments-slope": 8, + "equalsData-cpu-arguments-intercept": 150000, + "addInteger-cpu-arguments-intercept": 197209, + "modInteger-memory-arguments-intercept": 0, + "cekStartupCost-exBudgetMemory": 100, + "divideInteger-cpu-arguments-model-arguments-intercept": 425507, + "divideInteger-memory-arguments-intercept": 0, + "cekVarCost-exBudgetMemory": 100, + "consByteString-memory-arguments-slope": 1, + "cekForceCost-exBudgetMemory": 100, + "unListData-cpu-arguments": 150000, + "subtractInteger-cpu-arguments-intercept": 197209, + "indexByteString-cpu-arguments": 150000, + "equalsInteger-cpu-arguments-slope": 1326, + "lessThanByteString-memory-arguments": 1, + "blake2b-cpu-arguments-intercept": 2477736, + "encodeUtf8-cpu-arguments-intercept": 150000, + "multiplyInteger-cpu-arguments-slope": 11218, + "tailList-cpu-arguments": 150000, + "appendByteString-cpu-arguments-intercept": 396231, + "equalsString-cpu-arguments-slope": 1000, + "lessThanEqualsByteString-cpu-arguments-slope": 248, + "remainderInteger-cpu-arguments-constant": 148000, + "chooseList-cpu-arguments": 150000, + "equalsByteString-memory-arguments": 1, + "constrData-cpu-arguments": 150000, + "cekApplyCost-exBudgetCPU": 29773, + "equalsData-cpu-arguments-slope": 10000, + "decodeUtf8-memory-arguments-intercept": 0, + "modInteger-memory-arguments-slope": 1, + "addInteger-cpu-arguments-slope": 0, + "appendString-cpu-arguments-intercept": 150000, + "quotientInteger-cpu-arguments-model-arguments-slope": 118, + "unMapData-memory-arguments": 32, + "cekApplyCost-exBudgetMemory": 100, + "quotientInteger-memory-arguments-slope": 1, + "mkNilPairData-memory-arguments": 32, + "ifThenElse-memory-arguments": 1, + "equalsByteString-cpu-arguments-slope": 247, + "sliceByteString-memory-arguments-slope": 1, + "sha3_256-memory-arguments": 4, + "mkCons-memory-arguments": 32, + "verifySignature-cpu-arguments-intercept": 3345831, + "cekBuiltinCost-exBudgetMemory": 100, + "remainderInteger-memory-arguments-intercept": 0, + "lessThanEqualsByteString-memory-arguments": 1, + "mkNilData-cpu-arguments": 150000, + "equalsString-memory-arguments": 1, + "chooseData-cpu-arguments": 150000, + "remainderInteger-cpu-arguments-model-arguments-intercept": 425507, + "tailList-memory-arguments": 32, + "sha2_256-cpu-arguments-intercept": 2477736, + "multiplyInteger-memory-arguments-slope": 1, + "iData-memory-arguments": 32, + "divideInteger-cpu-arguments-constant": 148000, + "cekDelayCost-exBudgetCPU": 29773, + "encodeUtf8-memory-arguments-slope": 8, + "subtractInteger-memory-arguments-intercept": 1, + "nullList-memory-arguments": 32, + "lessThanByteString-cpu-arguments-intercept": 103599, + "appendByteString-memory-arguments-slope": 1, + "blake2b-memory-arguments": 4, + "unBData-memory-arguments": 32, + "cekConstCost-exBudgetCPU": 29773, + "consByteString-cpu-arguments-slope": 1000, + "trace-memory-arguments": 32, + "quotientInteger-memory-arguments-intercept": 0, + "mapData-memory-arguments": 32, + "verifySignature-cpu-arguments-slope": 1, + "quotientInteger-cpu-arguments-model-arguments-intercept": 425507, + "modInteger-cpu-arguments-constant": 148000, + "appendString-cpu-arguments-slope": 1000, + "unConstrData-memory-arguments": 32, + "mkPairData-memory-arguments": 32, + "equalsByteString-cpu-arguments-constant": 150000, + "equalsByteString-cpu-arguments-intercept": 112536, + "sliceByteString-memory-arguments-intercept": 0, + "lessThanInteger-cpu-arguments-slope": 497, + "verifySignature-memory-arguments": 1, + "cekLamCost-exBudgetMemory": 100, + "sliceByteString-cpu-arguments-intercept": 150000, + "modInteger-cpu-arguments-model-arguments-intercept": 425507, + "modInteger-memory-arguments-minimum": 1, + "appendString-memory-arguments-slope": 1, + "sha3_256-cpu-arguments-intercept": 0 + } + }, + "protocolVersion": { + "minor": 0, + "major": 5 + }, + "txFeeFixed": 155381, + "stakeAddressDeposit": 0, + "monetaryExpansion": 0.1, + "poolPledgeInfluence": 0, + "executionUnitPrices": { + "priceSteps": 7.21e-5, + "priceMemory": 5.77e-2 + } +} \ No newline at end of file diff --git a/examples/plutus-transfer/src/Cardano/PlutusExample/Transfer.hs b/examples/plutus-transfer/src/Cardano/PlutusExample/Transfer.hs new file mode 100644 index 00000000..a3f6b9cf --- /dev/null +++ b/examples/plutus-transfer/src/Cardano/PlutusExample/Transfer.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +module Cardano.PlutusExample.Transfer ( + TransferParams (TransferParams), + TransferSchema, + transfer, +) where + +import Control.Monad (forM_) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Bifunctor (first) +import Data.Monoid (Last (Last)) +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Plutus.Contract (Contract, Endpoint, submitTx, tell, waitNSlots) +import Schema (ToSchema) +import Prelude + +type TransferSchema = + Endpoint "transfer" TransferParams + +data TransferParams = TransferParams + { tfpOutputPerTx :: Int + , tfpPayments :: [(PubKeyHash, Value)] + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToSchema) + +$(deriveJSON defaultOptions ''TransferParams) + +transfer :: TransferParams -> Contract (Last Text) TransferSchema Text () +transfer (TransferParams outputPerTx allPayments) = do + tell $ Last $ Just "Contract started" + let txs = + map toTx $ group outputPerTx allPayments + forM_ txs $ \tx -> submitTx tx >> waitNSlots 1 + tell $ Last $ Just "Finished" + where + toTx :: [(PubKeyHash, Value)] -> TxConstraints Void Void + toTx = mconcat . map (uncurry Constraints.mustPayToPubKey . first PaymentPubKeyHash) + +group :: Int -> [a] -> [[a]] +group n list + | length list <= n = [list] + | otherwise = let (xs, xss) = splitAt n list in xs : group n xss diff --git a/examples/plutus-transfer/token-transfer.sh b/examples/plutus-transfer/token-transfer.sh new file mode 100755 index 00000000..29beb7a0 --- /dev/null +++ b/examples/plutus-transfer/token-transfer.sh @@ -0,0 +1,25 @@ +#!/bin/sh +CONTRACT_INST_ID=$(curl --location --request POST 'localhost:9080/api/contract/activate' \ + --header 'Content-Type: application/json' \ + --data-raw '{ + "caID": { + "tfpOutputPerTx": 2, + "tfpPayments": [ + [ {"getPubKeyHash": "981fc565bcf0c95c0cfa6ee6693875b60d529d87ed7082e9bf03c6a4"}, + {"getValue": [[{"unCurrencySymbol":"1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e"},[[{"unTokenName": "testToken"}, 15]]]]} + ], + [ {"getPubKeyHash": "6696936bb8ae24859d0c2e4d05584106601f58a5e9466282c8561b88"}, + {"getValue": [[{"unCurrencySymbol":"1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e"},[[{"unTokenName": "testToken"}, 18]]]]} + ], + [ {"getPubKeyHash": "a11767a73ea3f59fb11f17c1627706115de75e2d2c444b0e43789567"}, + {"getValue": [[{"unCurrencySymbol":"1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e"},[[{"unTokenName": "testToken"}, 20]]]]} + ] + ] + } + }' | jq -r .unContractInstanceId ) + +echo $CONTRACT_INST_ID + + +echo "{ \"tag\": \"Subscribe\", \"contents\": { \"Left\": { \"unContractInstanceId\":\"$CONTRACT_INST_ID\" } } }" | websocat -n ws://localhost:9080/ws + diff --git a/src/BotPlutusInterface/CardanoCLI.hs b/src/BotPlutusInterface/CardanoCLI.hs index 0e8fa4f5..3a932cc5 100644 --- a/src/BotPlutusInterface/CardanoCLI.hs +++ b/src/BotPlutusInterface/CardanoCLI.hs @@ -13,6 +13,7 @@ module BotPlutusInterface.CardanoCLI ( unsafeSerialiseAddress, policyScriptFilePath, utxosAt, + queryTip, ) where import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, uploadDir) @@ -24,14 +25,17 @@ import BotPlutusInterface.Files ( txFilePath, validatorScriptFilePath, ) -import BotPlutusInterface.Types (PABConfig) +import BotPlutusInterface.Types (PABConfig, Tip) import BotPlutusInterface.UtxoParser qualified as UtxoParser import Cardano.Api.Shelley (NetworkId (Mainnet, Testnet), NetworkMagic (..), serialiseAddress) import Codec.Serialise qualified as Codec import Control.Monad.Freer (Eff, Member) +import Data.Aeson qualified as JSON import Data.Aeson.Extras (encodeByteString) import Data.Attoparsec.Text (parseOnly) +import Data.Bool (bool) import Data.ByteString.Lazy qualified as LazyByteString +import Data.ByteString.Lazy.Char8 qualified as Char8 import Data.ByteString.Short qualified as ShortByteString import Data.Either (fromRight) import Data.Either.Combinators (mapLeft, maybeToRight) @@ -40,16 +44,23 @@ import Data.Kind (Type) import Data.List (sort) import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (maybeToList) +import Data.Maybe (fromMaybe, maybeToList) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8) +import Ledger (Slot (Slot), SlotRange) import Ledger qualified import Ledger.Ada qualified as Ada import Ledger.Address (Address (..)) import Ledger.Crypto (PubKey, PubKeyHash) +import Ledger.Interval ( + Extended (Finite), + Interval (Interval), + LowerBound (LowerBound), + UpperBound (UpperBound), + ) import Ledger.Scripts (Datum, DatumHash (..)) import Ledger.Scripts qualified as Scripts import Ledger.Tx ( @@ -93,6 +104,20 @@ uploadFiles pabConf = , pabConf.pcSigningKeyFileDir ] +-- | Getting information of the latest block +queryTip :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + PABConfig -> + Eff effs Tip +queryTip config = + callCommand @w + ShellArgs + { cmdName = "cardano-cli" + , cmdArgs = mconcat [["query", "tip"], networkOpt config] + , cmdOutParser = fromMaybe (error "Couldn't parse chain tip") . JSON.decode . Char8.pack + } + -- | Getting all available UTXOs at an address (all utxos are assumed to be PublicKeyChainIndexTxOut) utxosAt :: forall (w :: Type) (effs :: [Type -> Type]). @@ -168,9 +193,7 @@ isRawBuildMode :: BuildMode -> Bool isRawBuildMode (BuildRaw _) = True isRawBuildMode _ = False -{- | Build a tx body and write it to disk - If a fee if specified, it uses the build-raw command --} +-- | Build a tx body and write it to disk buildTx :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => @@ -194,6 +217,7 @@ buildTx pabConf ownPkh buildMode tx = , txInCollateralOpts (txCollateral tx) , txOutOpts pabConf (txData tx) (txOutputs tx) , mintOpts pabConf buildMode (txMintScripts tx) (txRedeemers tx) (txMint tx) + , validRangeOpts (txValidRange tx) , requiredSigners , case buildMode of BuildRaw fee -> ["--fee", showText fee] @@ -333,6 +357,20 @@ mintOpts pabConf buildMode mintingPolicies redeemers mintValue = else [] ] +-- | This function does not check if the range is valid, for that see `PreBalance.validateRange` +validRangeOpts :: SlotRange -> [Text] +validRangeOpts (Interval lowerBound upperBound) = + mconcat + [ case lowerBound of + LowerBound (Finite (Slot x)) closed -> + ["--invalid-before", showText (bool (x + 1) x closed)] + _ -> [] + , case upperBound of + UpperBound (Finite (Slot x)) closed -> + ["--invalid-hereafter", showText (bool x (x + 1) closed)] + _ -> [] + ] + txOutOpts :: PABConfig -> Map DatumHash Datum -> [TxOut] -> [Text] txOutOpts pabConf datums = concatMap diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 23f68afc..a3b59fd7 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -11,10 +11,11 @@ import BotPlutusInterface.Effects ( logToContract, printLog, queryChainIndex, + threadDelay, ) import BotPlutusInterface.Files qualified as Files import BotPlutusInterface.PreBalance qualified as PreBalance -import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug)) +import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug), Tip (slot)) import Control.Lens ((^.)) import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>)) import Control.Monad.Freer.Error (runError) @@ -26,8 +27,11 @@ import Data.Kind (Type) import Data.Map qualified as Map import Data.Row (Row) import Data.Text qualified as Text +import Ledger (POSIXTime) import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash)) import Ledger.Constraints.OffChain (UnbalancedTx (..)) +import Ledger.Slot (Slot (Slot)) +import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange, posixTimeToEnclosingSlot, slotToEndPOSIXTime) import Ledger.Tx (CardanoTx) import Ledger.Tx qualified as Tx import Plutus.ChainIndex.Types (RollbackState (Committed), TxValidity (..)) @@ -117,7 +121,6 @@ handlePABReq contractEnv req = do -- Handled requests -- ---------------------- OwnPaymentPublicKeyHashReq -> - -- TODO: Should be able to get this from the wallet, hardcoded for now pure $ OwnPaymentPublicKeyHashResp $ PaymentPubKeyHash contractEnv.cePABConfig.pcOwnPubKeyHash OwnContractInstanceIdReq -> pure $ OwnContractInstanceIdResp (ceContractInstanceId contractEnv) @@ -127,19 +130,26 @@ handlePABReq contractEnv req = do BalanceTxResp <$> balanceTx @w contractEnv unbalancedTx WriteBalancedTxReq tx -> WriteBalancedTxResp <$> writeBalancedTx @w contractEnv tx + AwaitSlotReq s -> AwaitSlotResp <$> awaitSlot @w contractEnv s + AwaitTimeReq t -> AwaitTimeResp <$> awaitTime @w contractEnv t + CurrentSlotReq -> CurrentSlotResp <$> currentSlot @w contractEnv + CurrentTimeReq -> CurrentTimeResp <$> currentTime @w contractEnv + PosixTimeRangeToContainedSlotRangeReq posixTimeRange -> + pure $ + PosixTimeRangeToContainedSlotRangeResp $ + Right $ + posixTimeRangeToContainedSlotRange contractEnv.cePABConfig.pcSlotConfig posixTimeRange ------------------------ -- Unhandled requests -- ------------------------ - AwaitSlotReq s -> pure $ AwaitSlotResp s - AwaitTimeReq t -> pure $ AwaitTimeResp t + -- AwaitTimeReq t -> pure $ AwaitTimeResp t -- AwaitUtxoSpentReq txOutRef -> pure $ AwaitUtxoSpentResp ChainIndexTx -- AwaitUtxoProducedReq Address -> pure $ AwaitUtxoProducedResp (NonEmpty ChainIndexTx) AwaitTxStatusChangeReq txId -> pure $ AwaitTxStatusChangeResp txId (Committed TxValid ()) - -- CurrentSlotReq -> CurrentSlotResp Slot - -- CurrentTimeReq -> CurrentTimeResp POSIXTime + -- AwaitTxOutStatusChangeReq TxOutRef -- ExposeEndpointReq ActiveEndpoint -> ExposeEndpointResp EndpointDescription (EndpointValue JSON.Value) - -- PosixTimeRangeToContainedSlotRangeReq POSIXTimeRange -> PosixTimeRangeToContainedSlotRangeResp (Either SlotConversionError SlotRange) - _ -> pure $ OwnContractInstanceIdResp contractEnv.ceContractInstanceId + -- YieldUnbalancedTxReq UnbalancedTx + unsupported -> error ("Unsupported PAB effect: " ++ show unsupported) printLog @w Debug $ show resp pure resp @@ -152,16 +162,6 @@ balanceTx :: UnbalancedTx -> Eff effs BalanceTxResponse balanceTx contractEnv unbalancedTx = do - -- TODO: Handle paging - -- (_, Page {pageItems}) <- - -- chainIndexQueryMany $ - -- ChainIndexClient.getUtxoAtAddress $ - -- addressCredential ownAddress - -- chainIndexTxOuts <- traverse (chainIndexQueryOne . ChainIndexClient.getTxOut) pageItems - -- let utxos = - -- Map.fromList $ - -- catMaybes $ zipWith (\oref txout -> (,) <$> Just oref <*> txout) pageItems chainIndexTxOuts - eitherPreBalancedTx <- PreBalance.preBalanceTxIO @w contractEnv.cePABConfig @@ -205,3 +205,49 @@ writeBalancedTx contractEnv (Right tx) = do else CardanoCLI.submitTx @w contractEnv.cePABConfig tx pure $ maybe (WriteBalancedTxSuccess (Right tx)) (WriteBalancedTxFailed . OtherError) result + +{- | Wait at least until the given slot. The slot number only changes when a new block is appended + to the chain so it waits for at least one block +-} +awaitSlot :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + ContractEnvironment w -> + Slot -> + Eff effs Slot +awaitSlot contractEnv s@(Slot n) = do + threadDelay @w 10_000_000 + tip' <- CardanoCLI.queryTip @w contractEnv.cePABConfig + if tip'.slot < n + then awaitSlot contractEnv s + else pure $ Slot tip'.slot + +{- | Wait at least until the given time. Uses the awaitSlot under the hood, so the same constraints + are applying here as well. +-} +awaitTime :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + ContractEnvironment w -> + POSIXTime -> + Eff effs POSIXTime +awaitTime ce = fmap fromSlot . awaitSlot ce . toSlot + where + toSlot = posixTimeToEnclosingSlot ce.cePABConfig.pcSlotConfig + fromSlot = slotToEndPOSIXTime ce.cePABConfig.pcSlotConfig + +currentSlot :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + ContractEnvironment w -> + Eff effs Slot +currentSlot contractEnv = + Slot . slot <$> CardanoCLI.queryTip @w contractEnv.cePABConfig + +currentTime :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + ContractEnvironment w -> + Eff effs POSIXTime +currentTime contractEnv = + slotToEndPOSIXTime contractEnv.cePABConfig.pcSlotConfig <$> currentSlot @w contractEnv diff --git a/src/BotPlutusInterface/PreBalance.hs b/src/BotPlutusInterface/PreBalance.hs index 54de828d..304eee60 100644 --- a/src/BotPlutusInterface/PreBalance.hs +++ b/src/BotPlutusInterface/PreBalance.hs @@ -29,7 +29,15 @@ import Ledger.Ada qualified as Ada import Ledger.Address (Address (..)) import Ledger.Constraints.OffChain (UnbalancedTx (..), fromScriptOutput) import Ledger.Crypto (PrivateKey, PubKeyHash) +import Ledger.Interval ( + Extended (Finite, NegInf, PosInf), + Interval (Interval), + LowerBound (LowerBound), + UpperBound (UpperBound), + ) import Ledger.Scripts (Datum, DatumHash) +import Ledger.Time (POSIXTimeRange) +import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange) import Ledger.Tx ( Tx (..), TxIn (..), @@ -64,8 +72,13 @@ preBalanceTxIO pabConf ownPkh unbalancedTx = utxos <- lift $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf let utxoIndex = fmap Tx.toTxOut utxos <> fmap (Ledger.toTxOut . fromScriptOutput) (unBalancedTxUtxoIndex unbalancedTx) - tx = unBalancedTxTx unbalancedTx requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx) + tx <- + hoistEither $ + addValidRange + pabConf + (unBalancedTxValidityTimeRange unbalancedTx) + (unBalancedTxTx unbalancedTx) lift $ printLog @w Debug $ show utxoIndex @@ -259,6 +272,19 @@ addSignatories ownPkh privKeys pkhs tx = tx (ownPkh : pkhs) +addValidRange :: PABConfig -> POSIXTimeRange -> Tx -> Either Text Tx +addValidRange pabConf timeRange tx = + if validateRange timeRange + then Right $ tx {txValidRange = posixTimeRangeToContainedSlotRange pabConf.pcSlotConfig timeRange} + else Left "Invalid validity interval." + +validateRange :: forall (a :: Type). Ord a => Interval a -> Bool +validateRange (Interval (LowerBound PosInf _) _) = False +validateRange (Interval _ (UpperBound NegInf _)) = False +validateRange (Interval (LowerBound (Finite lowerBound) _) (UpperBound (Finite upperBound) _)) + | lowerBound >= upperBound = False +validateRange _ = True + showText :: forall (a :: Type). Show a => a -> Text showText = Text.pack . show diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 1b8f740d..d8b3d930 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RankNTypes #-} module BotPlutusInterface.Types ( @@ -6,6 +7,7 @@ module BotPlutusInterface.Types ( AppState (AppState), LogLevel (..), ContractEnvironment (..), + Tip (Tip, epoch, hash, slot, block, era, syncProgress), ContractState (..), SomeContractState (SomeContractState), HasDefinitions (..), @@ -17,11 +19,14 @@ import Cardano.Api (NetworkId (Testnet), NetworkMagic (..)) import Cardano.Api.ProtocolParameters (ProtocolParameters) import Control.Concurrent.STM (TVar) import Data.Aeson (ToJSON) +import Data.Aeson qualified as JSON import Data.Default (Default (def)) import Data.Kind (Type) import Data.Map (Map) import Data.Text (Text) +import GHC.Generics (Generic) import Ledger (PubKeyHash) +import Ledger.TimeSlot (SlotConfig) import Network.Wai.Handler.Warp (Port) import Plutus.PAB.Core.ContractInstance.STM (Activity) import Plutus.PAB.Effects.Contract.Builtin ( @@ -39,6 +44,8 @@ data PABConfig = PABConfig , pcChainIndexUrl :: !BaseUrl , pcNetwork :: !NetworkId , pcProtocolParams :: !ProtocolParameters + , -- | Slot configuration of the network, the default value can be used for the mainnet + pcSlotConfig :: !SlotConfig , -- | Directory name of the script and data files pcScriptFileDir :: !Text , -- | Directory name of the signing key files @@ -50,7 +57,7 @@ data PABConfig = PABConfig , -- | Dry run mode will build the tx, but skip the submit step pcDryRun :: !Bool , pcLogLevel :: !LogLevel - , pcOwnPubKeyHash :: PubKeyHash + , pcOwnPubKeyHash :: !PubKeyHash , pcPort :: !Port } deriving stock (Show, Eq) @@ -62,6 +69,17 @@ data ContractEnvironment w = ContractEnvironment } deriving stock (Show) +data Tip = Tip + { epoch :: Integer + , hash :: Text + , slot :: Integer + , block :: Integer + , era :: Text + , syncProgress :: Text + } + deriving stock (Show, Generic) + deriving anyclass (JSON.FromJSON) + instance Show (TVar (ContractState w)) where show _ = "" @@ -92,6 +110,7 @@ instance Default PABConfig where , pcChainIndexUrl = BaseUrl Http "localhost" 9083 "" , pcNetwork = Testnet (NetworkMagic 42) , pcProtocolParams = def + , pcSlotConfig = def , pcScriptFileDir = "./result-scripts" , pcSigningKeyFileDir = "./signing-keys" , pcTxFileDir = "./txs" diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index b9009e0c..06d0c534 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -21,13 +21,25 @@ import Ledger qualified import Ledger.Ada qualified as Ada import Ledger.Address qualified as Address import Ledger.Constraints qualified as Constraints +import Ledger.Interval (interval) import Ledger.Scripts qualified as Scripts +import Ledger.Slot (Slot) +import Ledger.Time (POSIXTime (POSIXTime)) import Ledger.Tx (CardanoTx, TxOut (TxOut), TxOutRef (TxOutRef)) import Ledger.Tx qualified as Tx import Ledger.TxId qualified as TxId import Ledger.Value qualified as Value import NeatInterpolation (text) -import Plutus.Contract (Contract (..), Endpoint, submitTx, submitTxConstraintsWith, tell, utxosAt) +import Plutus.ChainIndex.Types (BlockId (..), Tip (..)) +import Plutus.Contract ( + Contract (..), + Endpoint, + submitTx, + submitTxConstraintsWith, + tell, + utxosAt, + waitNSlots, + ) import PlutusTx qualified import PlutusTx.Builtins (fromBuiltin) import Spec.MockContract ( @@ -44,6 +56,7 @@ import Spec.MockContract ( pkh3', pkhAddr1, runContractPure, + tip, utxos, ) import Test.Tasty (TestTree, testGroup) @@ -59,7 +72,7 @@ tests = testGroup "BotPlutusInterface.Contracts" [ testCase "Send ada to address" sendAda - , testCase "Send ada to address+staking" sendAdaStaking + , testCase "Send ada to address with staking key" sendAdaStaking , testCase "Support multiple signatories" multisigSupport , testCase "Send native tokens" sendTokens , testCase "Send native tokens (without token name)" sendTokensWithoutName @@ -67,7 +80,9 @@ tests = , testCase "Spend to validator script" spendToValidator , testCase "Redeem from validator script" redeemFromValidator , testCase "Multiple txs in a contract" multiTx + , testCase "With valid range" withValidRange , testCase "Use Writer in a contract" useWriter + , testCase "Wait for next block" waitNextBlock ] sendAda :: Assertion @@ -666,6 +681,53 @@ multiTx = do ] Right _ -> assertFailure "Wrong number of txs" +withValidRange :: Assertion +withValidRange = do + let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + initState = def & utxos .~ [(txOutRef, txOut)] + inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef + + contract :: Contract () (Endpoint "SendAda" ()) Text CardanoTx + contract = do + let constraints = + Constraints.mustPayToPubKey paymentPkh2 (Ada.lovelaceValueOf 1000) + <> Constraints.mustValidateIn (interval (POSIXTime 1643636293000) (POSIXTime 1646314693000)) + submitTx constraints + + assertContractWithTxId contract initState $ \state outTxId -> + assertCommandHistory + state + [ + ( 2 + , [text| + cardano-cli transaction build-raw --alonzo-era + --tx-in ${inTxId}#0 + --tx-in-collateral ${inTxId}#0 + --tx-out ${addr2}+1000 + --invalid-before 47577202 + --invalid-hereafter 50255602 + --required-signer ./signing-keys/signing-key-${pkh1'}.skey + --fee 0 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + |] + ) + , + ( 6 + , [text| + cardano-cli transaction build --alonzo-era + --tx-in ${inTxId}#0 + --tx-in-collateral ${inTxId}#0 + --tx-out ${addr2}+1000 + --invalid-before 47577202 + --invalid-hereafter 50255602 + --required-signer ./signing-keys/signing-key-${pkh1'}.skey + --change-address ${addr1} + --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + |] + ) + ] + useWriter :: Assertion useWriter = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 @@ -685,6 +747,29 @@ useWriter = do (state ^. observableState) @?= Last (Just ("Right " <> outTxId)) +waitNextBlock :: Assertion +waitNextBlock = do + let initSlot = 1000 + initTip = Tip initSlot (BlockId "ab12") 4 + initState = def & tip .~ initTip + + contract :: Contract () (Endpoint "SendAda" ()) Text Slot + contract = waitNSlots 1 + + (result, state) = runContractPure contract initState + + case result of + Left errMsg -> assertFailure (show errMsg) + Right slot -> do + assertBool "Current Slot is too small" (initSlot + 1 < slot) + assertCommandHistory + state + [ + ( 0 + , [text| cardano-cli query tip --mainnet |] + ) + ] + assertFiles :: forall (w :: Type). MockContractState w -> [Text] -> Assertion assertFiles state expectedFiles = assertBool errorMsg $ diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index e5fa051a..a50dfd30 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -94,13 +94,14 @@ import Ledger qualified import Ledger.Ada qualified as Ada import Ledger.Crypto (PubKey, PubKeyHash) import Ledger.Scripts (DatumHash (DatumHash)) +import Ledger.Slot (Slot (getSlot)) import Ledger.Tx (TxOut (TxOut), TxOutRef (TxOutRef)) import Ledger.Tx qualified as Tx import Ledger.TxId (TxId (TxId)) import Ledger.Value qualified as Value import NeatInterpolation (text) import Plutus.ChainIndex.Api (UtxosResponse (..)) -import Plutus.ChainIndex.Types (BlockId (..), Tip (..)) +import Plutus.ChainIndex.Types (BlockId (..), BlockNumber (unBlockNumber), Tip (..)) import Plutus.Contract (Contract (Contract)) import Plutus.Contract.Effects (ChainIndexQuery (..), ChainIndexResponse (..)) import Plutus.PAB.Core.ContractInstance.STM (Activity (Active)) @@ -238,7 +239,7 @@ runPABEffectPure :: Eff '[PABEffect w] a -> (Either Text a, MockContractState w) runPABEffectPure initState req = - run (runState initState (runError (reinterpret2 go req))) + run (runState initState (runError (reinterpret2 (incSlot . go) req))) where go :: forall (v :: Type). PABEffect w v -> MockContract w v go (CallCommand args) = mockCallCommand args @@ -256,6 +257,18 @@ runPABEffectPure initState req = go (UploadDir dir) = mockUploadDir dir go (QueryChainIndex query) = mockQueryChainIndex query + incSlot :: forall (v :: Type). MockContract w v -> MockContract w v + incSlot mc = + mc <* modify @(MockContractState w) (tip %~ incTip) + + incTip TipAtGenesis = Tip 1 (BlockId "00") 0 + incTip Tip {tipSlot, tipBlockId, tipBlockNo} = + Tip + { tipSlot = tipSlot + 1 + , tipBlockId = tipBlockId + , tipBlockNo = tipBlockNo + } + mockCallCommand :: forall (w :: Type) (a :: Type). ShellArgs a -> @@ -264,6 +277,8 @@ mockCallCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = do modify @(MockContractState w) (commandHistory %~ (cmdName <> " " <> Text.unwords cmdArgs <|)) case (cmdName, cmdArgs) of + ("cardano-cli", "query" : "tip" : _) -> + cmdOutParser <$> mockQueryTip ("cardano-cli", "query" : "utxo" : "--address" : addr : _) -> cmdOutParser <$> mockQueryUtxo addr ("cardano-cli", "transaction" : "calculate-min-required-utxo" : _) -> @@ -293,7 +308,32 @@ mockCallCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = do pure $ cmdOutParser "" ("cardano-cli", "transaction" : "submit" : _) -> pure $ cmdOutParser "" - _ -> throwError @Text "Unknown command" + (unsupportedCmd, unsupportedArgs) -> + throwError @Text + ("Unsupported command: " <> Text.intercalate " " (unsupportedCmd : unsupportedArgs)) + +mockQueryTip :: forall (w :: Type). MockContract w String +mockQueryTip = do + state <- get @(MockContractState w) + + let (slot, blockId, blockNo) = + case state ^. tip of + TipAtGenesis -> ("0", "00", "0") + Tip {tipSlot, tipBlockId, tipBlockNo} -> + ( Text.pack $ show $ getSlot tipSlot + , decodeUtf8 $ getBlockId tipBlockId + , Text.pack $ show $ unBlockNumber tipBlockNo + ) + pure $ + Text.unpack + [text|{ + "era": "Alonzo", + "syncProgress": "100.00", + "hash": "${blockId}", + "epoch": 1, + "slot": ${slot}, + "block": ${blockNo} + }|] mockQueryUtxo :: forall (w :: Type). Text -> MockContract w String mockQueryUtxo addr = do