From 22e020f463bf9fff0b0eec02529e74679f4e2969 Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Tue, 6 Feb 2024 21:48:47 +0700 Subject: [PATCH] WIP --- .ghci | 2 + .ghcid | 1 + .gitignore | 2 + cabal.project | 12 ++ cem-script.cabal | 40 +++- devnet/genesis-byron.json | 2 +- devnet/genesis-byron.json.bak | 2 +- devnet/genesis-conway.json | 37 +++- devnet/genesis-shelley.json | 4 +- devnet/genesis-shelley.json.bak | 4 +- docker-compose.devnet.yaml | 20 ++ docs/goals_and_soa.md | 5 +- prepare-devnet.sh | 4 + src/Cardano/CEM.hs | 154 +++++++++++---- src/Cardano/CEM/Examples.hs | 3 - src/Cardano/CEM/Examples/Auction.hs | 119 +++++++++--- src/Cardano/CEM/Examples/Compilation.hs | 29 +++ src/Cardano/CEM/Examples/Escrow.hs | 192 +++++++++++++----- src/Cardano/CEM/Examples/Voting.hs | 58 +++--- src/Cardano/CEM/Monads.hs | 248 +++++++++++++++++++++--- src/Cardano/CEM/Monads/L1.hs | 237 ++++++++++++++++++++-- src/Cardano/CEM/OnChain.hs | 169 ++++++++++------ src/Cardano/CEM/Stages.hs | 34 ++++ src/Cardano/Extras.hs | 222 +++++++++++++++++++++ src/Plutus/Extras.hs | 43 ++-- test/Main.hs | 230 ++++++++++++++++++++++ 26 files changed, 1596 insertions(+), 277 deletions(-) create mode 100644 .ghci create mode 100644 .ghcid create mode 100644 docker-compose.devnet.yaml create mode 100755 prepare-devnet.sh create mode 100644 src/Cardano/CEM/Examples/Compilation.hs create mode 100644 src/Cardano/CEM/Stages.hs create mode 100644 src/Cardano/Extras.hs create mode 100644 test/Main.hs 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..b106f32 --- /dev/null +++ b/.ghcid @@ -0,0 +1 @@ +--reload=cem-script.cabal --command="cabal repl test-suite:cem-sdk-test" -W -r 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/cabal.project b/cabal.project index a77ed01..6a63a2e 100644 --- a/cabal.project +++ b/cabal.project @@ -14,6 +14,18 @@ index-state: , 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 4247591..255d695 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -89,6 +89,8 @@ common common-onchain , 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 @@ -97,16 +99,32 @@ common common-onchain -- (some are enabled additionaly in individual modules) ghc-options: - -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 -fobject-code + -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 + -fplugin-opt PlutusTx.Plugin:verbosity=2 + -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-specialize -fno-unbox-small-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 + , pretty-show + , retry , cardano-api + , cardano-cli + , cardano-ledger-core + , cardano-ledger-babbage + , cardano-ledger-alonzo + , cardano-ledger-shelley + , ouroboros-consensus-cardano + , cardano-crypto-class , containers , filepath , text @@ -124,9 +142,27 @@ library cem-sdk hs-source-dirs: src/ exposed-modules: + Plutus.Extras Cardano.CEM + Cardano.CEM.Stages + Cardano.Extras Cardano.CEM.Examples.Auction Cardano.CEM.Examples.Compilation - Cardano.CEM.Examples.Voting + -- Cardano.CEM.Examples.Escrow + -- Cardano.CEM.Examples.Voting Cardano.CEM.Monads + Cardano.CEM.Monads.L1 Cardano.CEM.OnChain + +test-suite cem-sdk-test + import: + common-onchain, + common-offchain, + type: exitcode-stdio-1.0 + build-depends: + hspec, + cem-script:cem-sdk, + QuickCheck, + quickcheck-dynamic, + hs-source-dirs: test/ + main-is: Main.hs diff --git a/devnet/genesis-byron.json b/devnet/genesis-byron.json index bff40a8..46717bd 100644 --- a/devnet/genesis-byron.json +++ b/devnet/genesis-byron.json @@ -3,7 +3,7 @@ "k": 2160, "protocolMagic": 42 }, - "startTime": 1706549850, + "startTime": 1707213473, "blockVersionData": { "scriptVersion": 0, "slotDuration": "250", diff --git a/devnet/genesis-byron.json.bak b/devnet/genesis-byron.json.bak index f6cd9d7..5999813 100644 --- a/devnet/genesis-byron.json.bak +++ b/devnet/genesis-byron.json.bak @@ -3,7 +3,7 @@ "k": 2160, "protocolMagic": 42 }, - "startTime": 1706549840, + "startTime": 1707128149, "blockVersionData": { "scriptVersion": 0, "slotDuration": "250", diff --git a/devnet/genesis-conway.json b/devnet/genesis-conway.json index 4525ef4..5bad6d5 100644 --- a/devnet/genesis-conway.json +++ b/devnet/genesis-conway.json @@ -1,3 +1,38 @@ { - "genDelegs": {} + "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 index af0330d..08c3b3d 100644 --- a/devnet/genesis-shelley.json +++ b/devnet/genesis-shelley.json @@ -1,5 +1,5 @@ { - "epochLength": 432000, + "epochLength": 5, "activeSlotsCoeff": 1.0, "slotLength": 0.1, "securityParam": 2160, @@ -60,6 +60,6 @@ "074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60" } }, - "systemStart": "2024-01-29T17:37:30Z", + "systemStart": "2024-02-06T09:57:53Z", "updateQuorum": 2 } diff --git a/devnet/genesis-shelley.json.bak b/devnet/genesis-shelley.json.bak index e666978..24319fd 100644 --- a/devnet/genesis-shelley.json.bak +++ b/devnet/genesis-shelley.json.bak @@ -1,5 +1,5 @@ { - "epochLength": 432000, + "epochLength": 5, "activeSlotsCoeff": 1.0, "slotLength": 0.1, "securityParam": 2160, @@ -60,6 +60,6 @@ "074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60" } }, - "systemStart": "2024-01-29T17:37:20Z", + "systemStart": "2024-02-05T10:15:49Z", "updateQuorum": 2 } 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/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..2d3386f --- /dev/null +++ b/prepare-devnet.sh @@ -0,0 +1,4 @@ +TARGETDIR=devnet +sed -i.bak "s/\"startTime\": [0-9]*/\"startTime\": $(date +%s)/" "$TARGETDIR/genesis-byron.json" && \ +sed -i.bak "s/\"systemStart\": \".*\"/\"systemStart\": \"$(date -u +%FT%TZ)\"/" "$TARGETDIR/genesis-shelley.json" +sudo chown -R $USER:$USER ./devnet/ diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index 478d132..e36b477 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -1,50 +1,61 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NoPolyKinds #-} +{-# LANGUAGE RecordWildCards #-} + module Cardano.CEM where -import Prelude +import PlutusTx.Prelude +import Prelude qualified -import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V2 ( - BuiltinByteString, - Interval (..), - POSIXTime (..), + BuiltinData (..), + Data (..), + FromData (..), + ToData (..), + UnsafeFromData, Value, - always, + fromData, ) --- Constraints and filters +import Cardano.CEM.Stages +import PlutusTx qualified as PlutusTxs +import PlutusTx.IsData (toData) +import Prelude (Show) -data TxFanFilter script - = Anything - | BySameCEM (State script) - | ByAddress Address +data AddressSpec + = ByAddress Address | ByPubKey PubKeyHash - | ByDatum BuiltinByteString - | And [TxFanFilter script] - | Or [TxFanFilter script] - -data Quantor = Exist Integer | SumValueEq Value + | BySameScript -data TxFanKind = In | InRef | Out - -data TxFanConstraint script - = MkTxFanC TxFanKind (TxFanFilter script) Quantor +addressSpecToAddress :: Address -> AddressSpec -> Address +addressSpecToAddress ownAddress addressSpec = case addressSpec of + ByAddress address -> address + ByPubKey pubKey -> pubKeyHashAddress pubKey + BySameScript -> ownAddress --- Stages +data TxFanFilter script = MkTxFanFilter + { address :: AddressSpec + , rest :: TxFanFilter' script + } --- This covers constraints on blockchain slot time, --- used by both on- and off-chain code -class Stages stage where - data StageParams stage - stageToOnChainInterval :: StageParams stage -> stage -> Interval POSIXTime +data TxFanFilter' script + = Anything + | BySameCEM (State script) + | ByDatum BuiltinData --- Common +-- TODO: use natural numbers +data Quantor = Exist Integer | SumValueEq Value -data SingleStage = Always +data TxFanKind = In | InRef | Out + deriving stock (Prelude.Eq, Prelude.Show) -instance Stages SingleStage where - data StageParams SingleStage = NoSingleStageParams - stageToOnChainInterval _ Always = always +data TxFanConstraint script = MkTxFanC + { txFanCKind :: TxFanKind + , txFanCFilter :: TxFanFilter script + , txFanCQuantor :: Quantor + } -- Main API @@ -59,10 +70,87 @@ class (Stages (Stage script)) => CEMScript script where data Transition script -- This functions define domain logic - transitionSpec :: Params script -> State script -> Transition script -> Either String (TransitionSpec script) + transitionSpec :: + Params script -> + Maybe (State script) -> + Transition script -> + Either BuiltinString (TransitionSpec script) data TransitionSpec script = MkTransitionSpec - { сonstraints :: [TxFanConstraint script] + { constraints :: [TxFanConstraint script] , signers :: [PubKeyHash] , stage :: Stage script } + +data CEMParams script = MkCEMParams + { scriptParams :: Params script + , stagesParams :: StageParams (Stage script) + } + +deriving stock instance + ( Show (Params script) + , (Show (StageParams (Stage script))) + ) => + (Show (CEMParams script)) + +-- type CEMScriptDatum script = (StageParams script, Params script, State script) + +data CEMScriptDatum script = MkCEMScriptDatum + { params :: CEMParams script + , state :: State script + } + +deriving stock instance + ( Show (CEMParams script) + , (Show (State script)) + ) => + (Show (CEMScriptDatum 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 + +instance + (FromData (CEMParams script)) => + UnsafeFromData (CEMParams script) + where + unsafeFromBuiltinData x = case fromBuiltinData x of + Just y -> y + Nothing -> traceError "Error decoding CEMParams" + +instance + (ToData (CEMParams script), ToData (State script)) => + ToData (CEMScriptDatum script) + where + toBuiltinData (MkCEMScriptDatum {..}) = + BuiltinData $ List [toData params, toData state] + +instance + (FromData (CEMParams script), FromData (State script)) => + FromData (CEMScriptDatum script) + where + fromBuiltinData (BuiltinData (List [params, state])) = + MkCEMScriptDatum <$> fromData params <*> fromData state + fromBuiltinData _ = Nothing + +instance + (FromData (CEMScriptDatum script)) => + UnsafeFromData (CEMScriptDatum script) + where + unsafeFromBuiltinData x = case fromBuiltinData x of + Just y -> y + Nothing -> traceError "Error decoding CEMScriptDatum" diff --git a/src/Cardano/CEM/Examples.hs b/src/Cardano/CEM/Examples.hs index b28b04f..e69de29 100644 --- a/src/Cardano/CEM/Examples.hs +++ b/src/Cardano/CEM/Examples.hs @@ -1,3 +0,0 @@ - - - diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index c141c2e..7869b66 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -1,15 +1,17 @@ module Cardano.CEM.Examples.Auction where import PlutusTx.Prelude +import PlutusTx qualified import Cardano.CEM -import Cardano.CEM.OnChain +import Cardano.CEM.Stages import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Interval (always, from, to) import PlutusLedgerApi.V1.Time (POSIXTime) import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), singleton) -import PlutusLedgerApi.V2 (Value) +import PlutusLedgerApi.V2 (Address, ToData, Value) +import qualified Prelude -- Simple no-deposit auction @@ -19,6 +21,7 @@ data Bet = MkBet { better :: PubKeyHash , betAmount :: Integer } + deriving stock (Prelude.Eq, Prelude.Show) data SimpleAuctionStages = Open | Closed @@ -26,6 +29,8 @@ instance Stages SimpleAuctionStages where data StageParams SimpleAuctionStages = NoControl | CanCloseAt POSIXTime + deriving stock (Prelude.Eq, Prelude.Show) + stageToOnChainInterval NoControl _ = always -- Example: logical error stageToOnChainInterval (CanCloseAt time) Open = to time @@ -33,75 +38,125 @@ instance Stages SimpleAuctionStages where instance CEMScript SimpleAuction where type Stage SimpleAuction = SimpleAuctionStages - data Params SimpleAuction = MkVotingParams + data Params SimpleAuction = MkAuctionParams { seller :: PubKeyHash , lot :: Value } + deriving stock (Prelude.Eq, Prelude.Show) + data State SimpleAuction = NotStarted | CurrentBet Bet | Winner Bet + deriving stock (Prelude.Eq, Prelude.Show) + data Transition SimpleAuction - = Start + = Create + | Start | MakeBet Bet | Close - | Buyout + | -- TODO: discuss detirminancy + Buyout {payingFrom :: Address} + deriving stock (Prelude.Eq, Prelude.Show) + {-# INLINABLE transitionSpec #-} transitionSpec params state transition = case (state, transition) of - (NotStarted, Start) -> - Right - $ MkTransitionSpec + (Nothing, Create) -> + Right $ + MkTransitionSpec { stage = Open - , сonstraints = - [ MkTxFanC In (ByPubKey (seller params)) (SumValueEq $ lot params) - , MkTxFanC Out (BySameCEM (CurrentBet initialBet)) (Exist 1) + , constraints = [ + -- MkTxFanC Out (MkTxFanFilter BySameScript (BySameCEM NotStarted)) (Exist 1), + 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 + { stage = Open + , constraints = + [ MkTxFanC + In + (MkTxFanFilter (ByPubKey (seller params)) Anything) + (SumValueEq $ lot params) + , MkTxFanC + Out + (MkTxFanFilter BySameScript (BySameCEM (CurrentBet initialBet))) + (Exist 1) ] , signers = [seller params] } - (CurrentBet currentBet, MakeBet newBet) -> + (Just (CurrentBet currentBet), MakeBet newBet) -> -- Example: could be parametrized with param or typeclass if betAmount newBet > betAmount currentBet then - Right - $ MkTransitionSpec + Right $ + MkTransitionSpec { stage = Open - , сonstraints = + , constraints = saveLotConstraints - <> [ MkTxFanC Out (BySameCEM (CurrentBet newBet)) (Exist 1) + <> [ MkTxFanC Out (MkTxFanFilter BySameScript (BySameCEM (CurrentBet newBet))) (Exist 1) ] , signers = [better newBet] } else Left "Wrong bet amount" - (CurrentBet currentBet, Close) -> - Right - $ MkTransitionSpec + (Just (CurrentBet currentBet), Close) -> + Right $ + MkTransitionSpec { stage = Closed - , сonstraints = + , constraints = saveLotConstraints - <> [ MkTxFanC Out (BySameCEM (Winner currentBet)) (Exist 1) + <> [ MkTxFanC Out (MkTxFanFilter BySameScript (BySameCEM (Winner currentBet))) (Exist 1) ] , signers = [seller params] } - (Winner winnerBet, Buyout) -> - Right - $ MkTransitionSpec + (Just (Winner winnerBet), Buyout {payingFrom}) -> + Right $ + MkTransitionSpec { stage = Closed - , сonstraints = + , constraints = [ -- Example: In constraints redundant for on-chain - MkTxFanC In Anything (SumValueEq $ lot params) - , MkTxFanC Out (ByPubKey (better winnerBet)) (SumValueEq $ lot params) - , MkTxFanC In (ByPubKey (better winnerBet)) (SumValueEq $ betAdaValue winnerBet) - , MkTxFanC Out (ByPubKey (seller params)) (SumValueEq $ betAdaValue winnerBet) + MkTxFanC + In + (MkTxFanFilter (ByAddress payingFrom) Anything) + (SumValueEq $ lot params) + , 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 stage for transition" + _ -> Left "Incorrect state for transition" where initialBet = MkBet (seller params) 0 saveLotConstraints = - [ MkTxFanC In Anything (SumValueEq $ lot params) - , MkTxFanC Out Anything (SumValueEq $ lot params) + [ MkTxFanC + In + (MkTxFanFilter BySameScript Anything) + (SumValueEq $ lot params) + , MkTxFanC + Out + (MkTxFanFilter BySameScript Anything) + (SumValueEq $ lot params) ] betAdaValue = adaValue . betAmount adaValue = singleton (CurrencySymbol emptyByteString) (TokenName emptyByteString) + +PlutusTx.unstableMakeIsData ''Bet +PlutusTx.unstableMakeIsData 'NoControl +PlutusTx.unstableMakeIsData 'MkAuctionParams +PlutusTx.unstableMakeIsData 'NotStarted +PlutusTx.unstableMakeIsData 'MakeBet +PlutusTx.unstableMakeIsData ''SimpleAuctionStages diff --git a/src/Cardano/CEM/Examples/Compilation.hs b/src/Cardano/CEM/Examples/Compilation.hs new file mode 100644 index 0000000..65dfc62 --- /dev/null +++ b/src/Cardano/CEM/Examples/Compilation.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.Examples.Compilation where + +import PlutusTx qualified + +import Data.Proxy (Proxy (..)) + +import PlutusLedgerApi.V2 (serialiseCompiledCode, ScriptContext (ScriptContext)) + +import Cardano.CEM.Stages () +import Cardano.CEM.Examples.Auction +import Cardano.CEM.OnChain +import Plutus.Extras +import Cardano.CEM +import Cardano.Api (PlutusScript) + + +script :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> () +script _ _ _ = () + +compiled = $$(PlutusTx.compile [||script||]) + +instance CEMScriptCompiled SimpleAuction where + {-# INLINEABLE cemScriptCompiled #-} + cemScriptCompiled Proxy = + serialiseCompiledCode compiled + diff --git a/src/Cardano/CEM/Examples/Escrow.hs b/src/Cardano/CEM/Examples/Escrow.hs index 9f62ce2..35ca781 100644 --- a/src/Cardano/CEM/Examples/Escrow.hs +++ b/src/Cardano/CEM/Examples/Escrow.hs @@ -1,75 +1,173 @@ -module Cardano.CEM.Examples where +module Cardano.CEM.Examples.Escrow where -import Prelude +import PlutusTx qualified +import PlutusTx.Prelude -import Data.Proxy +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 -class Escrow script where - data EscrowLockedState script - data EscrowUnlock script - unlockConstraints :: - EscrowLockedState script -> EscrowUnlock script -> Maybe [TxFanConstraint] - -instance Escrow script => CEMScript script where - type Stage script = SingleStage - data State script = Locked (EscrowLockedState script) - data Transition script = UnLock (EscrowUnlock script) - - transitionSpec transition = case transition of - UnLock escrowState -> MkTransitionSpec { - transitionStates = (Locked, Nothing), - сonstraints = unlockConstraints escrowState, - transitionStage = Single - } +-- 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 EscrowUnlock UnboundedEscrow - unlockConstraints _ = [] + data EscrowParams UnboundedEscrow = MkUnboundedEscrowParams + data EscrowUnlock UnboundedEscrow = UnboundedEscrowUnlock + unlockConstraints _ _ = + Right $ + MkTransitionSpec + { constraints = [] + , signers = [] + , stage = Always + } data UserLockedEscrow instance Escrow UserLockedEscrow where - data EscrowUnlock UserLockedEscrow - unlockConstraints _ = [TxSigned "TODO_USER_PARAM"] + data EscrowParams UserLockedEscrow = MkUserLockedState + { unlockingUser :: PubKeyHash + } + data EscrowUnlock UserLockedEscrow = MkUserUnlock + unlockConstraints state _ = + Right $ + MkTransitionSpec + { constraints = [] + , signers = [unlockingUser state] + , stage = Always + } -data TokenLockedEscrow +PlutusTx.unstableMakeIsData 'MkUserLockedState +PlutusTx.unstableMakeIsData 'MkUserUnlock -{- +data TokenLockedEscrow instance Escrow TokenLockedEscrow where - data EscrowUnlock TokenLockedEscrow = NoData - unlockConstraints _ = [TxInC kind "TODO_TOKEN_PARAM"] - where - kind = InRef - - --} + 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 EscrowUnlock UnboundedEscrow = NoData - unlockConstraints _ = [] + 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 -data SwapEscrow +instance Escrow FeeDistributionEscrow where + data EscrowParams FeeDistributionEscrow = MkFeeDistributionParams + { feeReceivers :: [Address] + } -{- -instance Escrow SwapEscrow where - data EscrowUnlock SwapEscrow = NoData - unlockConstraints _ = [ - TxInC In "TODO_TOKEN_PARAM" - ] --} + -- 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 index 2d26a1f..52d0d56 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -1,33 +1,41 @@ +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} module Cardano.CEM.Examples.Voting where -import Prelude - -import Cardano.CEM -import Cardano.CEM.OnChain +import PlutusTx.Prelude import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V2 (Value) +import Cardano.CEM +import Cardano.CEM.Stages + -- Voting data SimpleVoting -data VoteValue = Yes | No | Abstain deriving stock (Eq) +data VoteValue = Yes | No | Abstain +instance Eq VoteValue + +-- TODO data JuryPolicy = Anyone | FixedJuryList [PubKeyHash] | WithToken Value -- Stub + data VoteStorage + emptyVoteStorage :: VoteStorage -emptyVoteStorage = error "Implementation is not important for example" -addVote :: PubKeyHash -> VoteValue -> VoteStorage -> Either String VoteStorage -addVote = error "Implementation is not important for example" +emptyVoteStorage = traceError "Implementation is not important for example" + +addVote :: PubKeyHash -> VoteValue -> VoteStorage -> Either BuiltinString VoteStorage +addVote = traceError "Implementation is not important for example" + countVotes :: VoteStorage -> VoteValue -countVotes = error "Implementation is not important for example" +countVotes = traceError "Implementation is not important for example" instance CEMScript SimpleVoting where type Stage SimpleVoting = SingleStage data Params SimpleVoting = MkVotingParams - { disputeDescription :: String + { disputeDescription :: BuiltinString , creator :: PubKeyHash , juryPolicy :: JuryPolicy , abstainAllowed :: Bool @@ -44,13 +52,13 @@ instance CEMScript SimpleVoting where transitionSpec params state transition = case (state, transition) of (NotStarted, Start) -> - Right $ - MkTransitionSpec + Right + $ MkTransitionSpec { stage = Always - , сonstraints = + , constraints = [ MkTxFanC Out - (BySameCEM $ InProgress emptyVoteStorage) + (bySameCEM $ InProgress emptyVoteStorage) (Exist 1) ] , signers = [creator params] @@ -70,31 +78,35 @@ instance CEMScript SimpleVoting where let allowedToVoteConstraints = case juryPolicy params of WithToken value -> - [ MkTxFanC InRef (ByPubKey jury) (SumValueEq value) + [ + MkTxFanC + InRef (MkTxFanFilter (ByPubKey jury) Anything) (SumValueEq value) ] _ -> [] -- Update state newVoteStorage <- addVote jury vote votes - Right $ - MkTransitionSpec + Right + $ MkTransitionSpec { stage = Always - , сonstraints = + , constraints = [ MkTxFanC Out - (BySameCEM $ InProgress newVoteStorage) + (bySameCEM $ InProgress newVoteStorage) (Exist 1) ] ++ allowedToVoteConstraints , signers = [jury] } (InProgress votes, Finalize) -> - Right $ - MkTransitionSpec + Right + $ MkTransitionSpec { stage = Always - , сonstraints = - [ MkTxFanC Out (BySameCEM $ Finalized (countVotes votes)) (Exist 1) + , constraints = + [ MkTxFanC Out (bySameCEM $ Finalized (countVotes votes)) (Exist 1) ] , signers = [creator params] } _ -> Left "Wrong state transition" + where + bySameCEM state' = MkTxFanFilter BySameScript (BySameCEM state') diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs index 7cf9945..b3061f2 100644 --- a/src/Cardano/CEM/Monads.hs +++ b/src/Cardano/CEM/Monads.hs @@ -2,76 +2,280 @@ 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 (..), + ToData (..), + always, + ) -import Cardano.Api hiding (Address) +import Cardano.Api hiding (Address, In, Out, queryUtxo) +import Cardano.Api.Shelley (PoolId, ReferenceScript (..), toMaryValue) +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 Debug.Trace (trace, traceM) +import Text.Show.Pretty (ppShow) --- Common +-- MonadBlockchainParams -type Era = BabbageEra +-- @todo #13: Derive stock classes for cardano-api --- MonadBlockchainParams +-- | 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: Add rest of MonadBlockchainParams interface --- @todo #13: Implement PSM for MonadBlockchainParams -class (Monad m) => MonadBlockchainParams m where +-- @todo #13: Implement PSM for `MonadBlockchainParams` (task for Michal) +class (MonadFail m) => MonadBlockchainParams m where askNetworkId :: m NetworkId queryCurrentSlot :: m SlotNo + queryBlockchainParams :: m BlockchainParams --- @todo #12: copy `fromPlutusAddressInMonad` from Hydra +fromPlutusAddressInMonad :: + (MonadBlockchainParams m) => Address -> m (AddressInEra Era) +fromPlutusAddressInMonad address = do + networkId <- askNetworkId + return $ fromPlutusAddress networkId address -- MonadQuery data UtxoQuery - = ByAddress Address + = ByAddresses [Address] | ByTxIns [TxIn] + deriving stock (Show, Eq) class (MonadBlockchainParams m) => MonadQueryUtxo m where queryUtxo :: UtxoQuery -> m (UTxO Era) --- MonadQuery +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 --- @todo #12: specify ResolvedTx and TxResolutionStrategy -data ResolvedTx +-- MonadSubmit + +-- TODO: refactor +deriving instance (Eq (SigningKey PaymentKey)) + +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 TxResolutionStrategy - data TxSigner = MkTxSigner - { signerAddress :: Address + { 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) (Maybe (State 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 SomeTransitionSpec where - MkSomeTransitionSpec :: - forall spec. (CEMScript spec) => TransitionSpec spec -> SomeTransitionSpec +data SomeCEMAction where + MkSomeCEMAction :: + forall script. + ( CEMScriptCompiled script + , Show (CEMAction script) + -- , Eq (CEMAction script) + ) => + CEMAction script -> + SomeCEMAction + +instance Show SomeCEMAction where + -- TODO: show script name + show (MkSomeCEMAction action) = show action data TxSpec = MkTxSpec - { transitionSpec :: [SomeTransitionSpec] + { actions :: [SomeCEMAction] + , specSigners :: [TxSigner] + } + deriving stock (Show) + +{- +data TxSpecProcessed = MkTxSpecProcessed + { constraints :: TxFanConstraint Void , signers :: [TxSigner] - , changeAddress :: Address + , interval :: Interval POSIXTime } +-} + +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 + +resolveAction :: + forall m. + (MonadQueryUtxo m, MonadSubmitTx m) => + SomeCEMAction -> + m (Either TxResolutionError ResolvedTx) +resolveAction someAction@(MkSomeCEMAction @script (MkCEMAction params state transition)) = runExceptT $ do + -- utxo <- queryUtxo [ByAddresses scriptAddress] + -- TxOut _ _ In <- head $ Map.values $ unUTxO utxo + + scriptTransition <- case transitionSpec (scriptParams params) state 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) + + traceM $ ppShow $ txIns + traceM $ ppShow $ txOuts + + + return $ + MkResolvedTx + { txIns + , txInsReference = [] + , txOuts + , toMint = TxMintNone + , signors = [] + , interval = always + } + where + 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 -> mkInlineDatum $ MkCEMScriptDatum params newState + 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 :: - TxSpec -> TxResolutionStrategy -> Either TxResolutionError TxId -resolveTxAndSubmit = error "TODO" + (MonadQueryUtxo m, MonadSubmitTx 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 = ins} + case result of + Right txId -> return txId + Left resolveError -> throwError $ UnhandledSubmittingError resolveError + + -- Check ResolvedTx validity: signers, interval diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs index 725052f..c01d6f0 100644 --- a/src/Cardano/CEM/Monads/L1.hs +++ b/src/Cardano/CEM/Monads/L1.hs @@ -1,21 +1,230 @@ +{-# 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 + -- Cardano imports -import Cardano.Api.UTxO qualified as UTxO +-- import Cardano.Ledger.Chain (PredicateFailure) +-- import Cardano.Ledger.Shelley.API () +-- import Ouroboros.Consensus.Shelley.Ledger (ApplyTxError (..)) +-- import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO, TranslationError) +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley (LedgerProtocolParameters (..)) + +-- 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 +import System.Posix.Internals (puts) + +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 Nothing 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 + MkBlockchainParams {protocolParameters} <- queryBlockchainParams + let preBody = + TxBodyContent + { txIns = txIns + , txInsCollateral = + TxInsCollateral AlonzoEraOnwardsBabbage $ map fst txIns + , 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 165369 + , -- 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 $ ByAddresses [mainAddress'] + + liftIO $ pPrint preBody + liftIO $ pPrint utxo + + 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 --- Hydra imports +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 -import Data.Maybe (listToMaybe) -import Cardano.Api ( - CtxUTxO, - TxOut, - UTxO, - UTxO' (UTxO), - getScriptData, - toPlutusData, - toPlutusTxOut, - txOutDatum, - pattern TxOutDatumInline, - ) +callBodyAutoBalance :: + (MonadBlockchainParams m) => + TxBodyContent BuildTx Era -> + UTxO Era -> + AddressInEra Era -> + m (Either TxBodyErrorAutoBalance (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 index e5249e4..d8f6871 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -1,11 +1,15 @@ +{-# 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) +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress, scriptHashAddress) import PlutusLedgerApi.V1.Interval (contains) import PlutusLedgerApi.V2.Contexts ( ScriptContext, @@ -15,84 +19,127 @@ import PlutusLedgerApi.V2.Contexts ( findOwnInput, scriptContextTxInfo, ) +import PlutusTx.IsData (FromData, ToData (toBuiltinData), UnsafeFromData (..)) import Cardano.CEM +import Cardano.CEM.Stages +import Plutus.Extras +import PlutusLedgerApi.V1.Scripts (Datum (..)) +import PlutusLedgerApi.V2.Tx (OutputDatum (..)) +import Language.Haskell.TH.Syntax (Exp, Q, Dec, Name, Type) -data CEMScriptDatum script = MkCEMScriptDatum - { stageParams :: StageParams (Stage script) - , params :: Params script - , state :: State script - } - -class (CEMScript script) => CEMScriptCompiled script where +class (CEMScript script, CEMScriptIsData script) => CEMScriptCompiled script where cemScriptCompiled :: Proxy script -> SerialisedScript -cemScriptAddress :: (CEMScriptCompiled script) => Proxy script -> Address -cemScriptAddress _ = traceError "TODO" +{-# 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 = + ( + IsData (CEMScriptDatum script) + , Prelude.Show (CEMScriptDatum script) + , UnsafeFromData (Transition script) + ) + +genericCEMScript' :: Q Type -> Q Exp +genericCEMScript' scriptName = [e| + \datum' redeemer' context' -> -genericCEMScript :: - forall script. - (CEMScript script) => + let + -- spec' :: TransitionSpec $scriptName + -- spec' = unsafeFromBuiltinData datum' + datum = unsafeFromBuiltinData datum' + scriptParams' :: Params $scriptName + scriptParams' = unsafeFromBuiltinData datum' + scriptState' :: State $scriptName + scriptState' = unsafeFromBuiltinData datum' + transition :: Transition $scriptName + transition = unsafeFromBuiltinData redeemer' + context = unsafeFromBuiltinData context' + info = scriptContextTxInfo context + ownAddress = case findOwnInput context of + Just x -> txOutAddress $ txInInfoResolved x + Nothing -> traceError "Impossible happened" + result = + case transitionSpec scriptParams' (Just scriptState') transition of + Right spec -> + -- do transition + all (checkConstraint ownAddress datum info) (constraints) + -- check signers + && traceIfFalse + "Wrong signers list" + ( signers + `isSubSetOf` txInfoSignatories info + ) + -- check stage + && let + expectedInterval = + stageToOnChainInterval (stagesParams) stage + in + traceIfFalse "Wrong interval for transition stage" $ + expectedInterval + `contains` txInfoValidRange info + Left errorMessage -> traceError errorMessage + in + if result + then + () + else traceError "TODO error" + |] + +{-# INLINABLE checkTxFanAddress #-} +checkTxFanAddress :: Address -> AddressSpec -> TxOut -> Bool +checkTxFanAddress ownAddress addressSpec fan = + txOutAddress fan == addressSpecToAddress ownAddress addressSpec + +{-# INLINABLE checkTxFan' #-} +checkTxFan' :: + (ToData (CEMScriptDatum script)) => CEMScriptDatum script -> - Transition script -> - ScriptContext -> + TxFanFilter' script -> + TxOut -> Bool -genericCEMScript datum transition context = - case transitionSpec (params datum) (state datum) transition of - Right spec -> - -- do transition - (and $ map (checkConstraint ownAddress datum info) (сonstraints spec)) - -- check signers - && ( traceIfFalse "Wrong signers list" - $ (signers spec) - `isSubSetOf` txInfoSignatories info - ) - -- check stage - && let - expectedInterval = - stageToOnChainInterval (stageParams datum) (stage spec) - in - traceIfFalse "Wrong interval for transition stage" - $ expectedInterval - `contains` txInfoValidRange info - Left _ -> traceError "TODO" +checkTxFan' ownDatum filterSpec' fan = + case filterSpec' of + Anything -> True + BySameCEM state -> + let + stateChangeDatum = ownDatum {state = state} + stateChangeDatumBS = toBuiltinData stateChangeDatum + cemChangeConstraint = ByDatum stateChangeDatumBS + in + checkTxFan' ownDatum cemChangeConstraint fan + ByDatum datum -> getDatum (retrieveFanDatum fan) == datum where - info = scriptContextTxInfo context - ownAddress = case findOwnInput context of - Just x -> txOutAddress $ txInInfoResolved x - Nothing -> traceError "Impossible happened" + retrieveFanDatum (TxOut _ _ (OutputDatum datum) _) = datum + retrieveFanDatum _ = traceError "Missing or non-inline datum" +{-# INLINABLE checkConstraint #-} checkConstraint :: - Address -> CEMScriptDatum script -> TxInfo -> TxFanConstraint script -> Bool + (ToData (CEMScriptDatum script)) => + Address -> + CEMScriptDatum script -> + TxInfo -> + TxFanConstraint script -> + Bool checkConstraint ownAddress ownDatum info (MkTxFanC fanKind filterSpec quantifier) = - checkQuantifier $ filter (predFan filterSpec) fans + checkQuantifier $ filter (checkTxFan filterSpec) fans where + checkTxFan (MkTxFanFilter addressSpec filterSpec') fan = + checkTxFanAddress ownAddress addressSpec fan + && checkTxFan' ownDatum filterSpec' fan fans = case fanKind of In -> map txInInfoResolved $ txInfoInputs info InRef -> map txInInfoResolved $ txInfoReferenceInputs info Out -> txInfoOutputs info - predFan filterSpec' fan = case filterSpec' of - Anything -> True - ByAddress address -> txOutAddress fan == address - BySameCEM state -> - let - stateChangeDatum = ownDatum {state = state} - stateChangeDatumBS = traceError "TODO" - cemChangeConstraint = - And [ByAddress ownAddress, ByDatum stateChangeDatumBS] - in - predFan cemChangeConstraint fan - ByPubKey pubKey -> predFan (ByAddress $ pubKeyHashAddress pubKey) fan - ByDatum datum -> retrieveFanDatum fan == Just datum - And subSpecs -> and $ predOnSubSpecs subSpecs - Or subSpecs -> or $ predOnSubSpecs subSpecs - where - predOnSubSpecs = map (flip predFan fan) checkQuantifier txFans = case quantifier of - SumValueEq value -> (foldMap txOutValue txFans) == value - -- TODO: use natural numbers + SumValueEq value -> foldMap txOutValue txFans == value Exist n -> length txFans == n - retrieveFanDatum fan = traceError "TODO" +{-# INLINABLE isSubSetOf #-} isSubSetOf :: (Eq a) => [a] -> [a] -> Bool -isSubSetOf xs ys = and $ map (`elem` ys) xs +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..46b95b2 --- /dev/null +++ b/src/Cardano/CEM/Stages.hs @@ -0,0 +1,34 @@ +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 + data StageParams stage + stageToOnChainInterval :: + StageParams stage -> stage -> Interval POSIXTime + +-- Common + +data SingleStage = Always + +-- TODO: rename +instance Stages SingleStage where + data StageParams SingleStage + = NoSingleStageParams + | AllowedInterval (Interval POSIXTime) + stageToOnChainInterval NoSingleStageParams Always = always + stageToOnChainInterval (AllowedInterval interval) Always = interval + +PlutusTx.unstableMakeIsData ''SingleStage +PlutusTx.unstableMakeIsData 'NoSingleStageParams diff --git a/src/Cardano/Extras.hs b/src/Cardano/Extras.hs new file mode 100644 index 0000000..ec52e6d --- /dev/null +++ b/src/Cardano/Extras.hs @@ -0,0 +1,222 @@ +{- | 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 qualified Cardano.Api as Cardano +import Cardano.Api ( + AddressAny (..), + AddressInEra (..), + AddressTypeInEra (..), + AsType (..), + AssetId (..), + AssetName (..), + BabbageEra, + BabbageEraOnwards (BabbageEraOnwardsBabbage, BabbageEraOnwardsConway), + BuildTx, + BuildTxWith (..), + ConsensusModeParams (..), + EpochSlots (EpochSlots), + HasTypeProxy (AsType), + IsShelleyBasedEra (..), + Key (..), + KeyWitnessInCtx (..), + NetworkId (..), + PaymentKey, + PlutusScript, + PolicyId (..), + Quantity (..), + SigningKey (..), + TextEnvelopeError (TextEnvelopeAesonDecodeError), + TxIn, + TxOut (..), + TxOutDatum (..), + UTxO (unUTxO), + Value, + WitCtxTxIn, + Witness (..), + deserialiseFromTextEnvelope, + txOutValueToValue, + unsafeHashableScriptData, + valueFromList, + verificationKeyHash, + ) +import Cardano.Api.Byron (Hash (..)) +import Cardano.Api.Ledger (StandardCrypto) +import Cardano.Api.Shelley (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.Map (elems) +import PlutusLedgerApi.V1 qualified as Plutus +import PlutusLedgerApi.V1.Value (CurrencySymbol (..), flattenValue, TokenName (..)) +import PlutusLedgerApi.V3 (ToData (..), adaSymbol, adaToken, toData, ScriptHash (..)) +import PlutusTx.Builtins.Class (FromBuiltin (..)) +import qualified Data.ByteString as BS + +-- Common + +type Era = BabbageEra +type LedgerEra = Ledger.BabbageEra StandardCrypto + +-- | 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 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 + +-- mkInlinedDatumScriptWitness :: +-- (ToData a) => +-- PlutusScript Era -> +-- a -> +-- BuildTxWith BuildTx (Witness WitCtxTxIn Era) +-- mkInlinedDatumScriptWitness script redeemer = +-- BuildTxWith $ +-- ScriptWitness scriptWitnessInCtx $ +-- mkScriptWitness script InlineScriptDatum (toScriptData redeemer) + +-- | Fields +txOutValue :: TxOut ctx Era -> Value +txOutValue (TxOut _ value _ _) = txOutValueToValue value + +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/Plutus/Extras.hs b/src/Plutus/Extras.hs index e715b04..17c8b9a 100644 --- a/src/Plutus/Extras.hs +++ b/src/Plutus/Extras.hs @@ -3,15 +3,14 @@ module Plutus.Extras where import PlutusTx.Prelude import Cardano.Api ( + PlutusScriptVersion (..), + Script (..), SerialiseAsRawBytes (serialiseToRawBytes), - fromPlutusScript, hashScript, - pattern PlutusScript, ) -import PlutusLedgerApi.V1.Api (Script, UnsafeFromData (unsafeFromBuiltinData), ValidatorHash (ValidatorHash)) -import PlutusTx (BuiltinData) - --- * Vendored from plutus-ledger +import Cardano.Api.Shelley (PlutusScript (..)) +import PlutusLedgerApi.Common (SerialisedScript) +import PlutusLedgerApi.V2 (ScriptHash (..), UnsafeFromData (..)) -- | Signature of an untyped validator script. type ValidatorType = BuiltinData -> BuiltinData -> BuiltinData -> () @@ -31,32 +30,14 @@ wrapValidator f d r c = context = unsafeFromBuiltinData c {-# INLINEABLE wrapValidator #-} --- | Signature of an untyped minting policy script. -type MintingPolicyType = BuiltinData -> BuiltinData -> () - --- | Wrap a typed minting policy to get the basic `MintingPolicyType` signature --- which can be passed to `PlutusTx.compile`. -wrapMintingPolicy :: - (UnsafeFromData redeemer, UnsafeFromData context) => - (redeemer -> context -> Bool) -> - MintingPolicyType -wrapMintingPolicy f r c = - check $ f redeemer context - where - redeemer = unsafeFromBuiltinData r - context = unsafeFromBuiltinData c -{-# INLINEABLE wrapMintingPolicy #-} - --- * Similar utilities as plutus-ledger - --- | Compute the 'ValidatorHash' for a given plutus 'Script'. --- --- NOTE: Implemented using hydra-cardano-api (PlutusScript pattern) -scriptValidatorHash :: Script -> ValidatorHash +{- | Compute the on-chain 'ScriptHash' for a given serialised plutus script. Use +this to refer to another validator script. +-} +scriptValidatorHash :: SerialisedScript -> ScriptHash scriptValidatorHash = - ValidatorHash + ScriptHash . toBuiltin . serialiseToRawBytes . hashScript - . PlutusScript - . fromPlutusScript + . PlutusScript PlutusScriptV2 + . PlutusScriptSerialised diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..a182673 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,230 @@ +module Main (main) where + +import Prelude hiding (readFile) + +import Control.Monad.Trans +import Data.ByteString (putStr, readFile) + +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.Ledger.Val (adaOnly) +import Data.Map (elems, keys) +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 + Right txId <- resolveTxAndSubmit spec + awaitTx txId + +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 + valueLeft = convert $ lovelaceToValue $ fromInteger 3_000_000 + out2 = + TxOut + user1Address + valueLeft + TxOutDatumNone + ReferenceScriptNone + tx = + MkResolvedTx + { txIns = map withKeyWitness user1TxIns + , txInsReference = [] + , txOuts = + [ out2 + ] + , 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 Nothing Create + ] + , specSigners = [mkMainSigner seller] + } + + let + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 1_000_000 + } + + result <- + resolveTxAndSubmit $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (Just NotStarted) (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + liftIO $ pPrint result + Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) <- + return result + + return () + + it "Successful transition flow" $ \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 Nothing Create] + , specSigners = [mkMainSigner seller] + } + + let + initBet = + MkBet + { better = signingKeyToPKH seller + , betAmount = 0 + } + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 1_000_000 + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (Just NotStarted) Start + ] + , specSigners = [mkMainSigner seller] + } + + {- + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (Just $ CurrentBet initBet) (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + -}