From 2ec71d7ecfe60166f4433ec4273bbbdcc4289bab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 23 Jun 2021 00:12:31 +0200 Subject: [PATCH] bumped Plutus and fixed EnglishAuction --- code/week01/cabal.project | 98 +++++++++++++++++++----- code/week01/src/Week01/EnglishAuction.hs | 67 ++++++---------- 2 files changed, 101 insertions(+), 64 deletions(-) diff --git a/code/week01/cabal.project b/code/week01/cabal.project index 80eea8d..2f238b6 100644 --- a/code/week01/cabal.project +++ b/code/week01/cabal.project @@ -1,4 +1,4 @@ -index-state: 2021-02-24T00:00:00Z +index-state: 2021-06-10T00:00:00Z packages: ./. @@ -15,6 +15,7 @@ source-repository-package subdir: freer-extras playground-common + plutus-chain-index plutus-core plutus-contract plutus-ledger @@ -23,7 +24,8 @@ source-repository-package plutus-tx-plugin prettyprinter-configurable quickcheck-dynamic - tag: 0c3c310cab61dbff8cbc1998a3678b367be6815a + word-array + tag: eaf2c901d9d51a6132e3290927887e8924219599 -- The following sections are copied from the 'plutus' repository cabal.project at the revision -- given above. @@ -31,22 +33,44 @@ source-repository-package -- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to -- re-update this section from the template when you do an upgrade. +-- This is also needed so evenful-sql-common will build with a +-- newer version of persistent. See stack.yaml for the mirrored +-- configuration. package eventful-sql-common - ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances + ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses allow-newer: - -- Has a commit to allow newer aeson, not on Hackage yet - monoidal-containers:aeson -- Pins to an old version of Template Haskell, unclear if/when it will be updated - , size-based:template-haskell + size-based:template-haskell -- The following two dependencies are needed by plutus. , eventful-sql-common:persistent , eventful-sql-common:persistent-template + , ouroboros-consensus-byron:formatting + , beam-core:aeson + , beam-sqlite:aeson + , beam-sqlite:dlist + , beam-migrate:aeson constraints: - -- aws-lambda-haskell-runtime-wai doesn't compile with newer versions - aws-lambda-haskell-runtime <= 3.0.3 + -- big breaking change here, inline-r doens't have an upper bound + singletons < 3.0 + -- breaks eventful even more than it already was + , persistent-template < 2.12 + -- bizarre issue: in earlier versions they define their own 'GEq', in newer + -- ones they reuse the one from 'some', but there isn't e.g. a proper version + -- constraint from dependent-sum-template (which is the library we actually use). + , dependent-sum > 0.6.2.0 + +-- See the note on nix/pkgs/default.nix:agdaPackages for why this is here. +-- (NOTE this will change to ieee754 in newer versions of nixpkgs). +extra-packages: ieee, filemanip + +-- Drops an instance breaking our code. Should be released to Hackage eventually. +source-repository-package + type: git + location: https://github.com/Quid2/flat.git + tag: 95e5d7488451e43062ca84d5376b3adcc465f1cd -- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year) source-repository-package @@ -62,29 +86,25 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-crypto.git - tag: f73079303f663e028288f9f4a9e08bcca39a923e - --- Needs a fix (https://github.com/wenkokke/unlit/pull/11) and a Hackage release -source-repository-package - type: git - location: https://github.com/michaelpj/unlit.git - tag: 9ca1112093c5ffd356fc99c7dafa080e686dd748 + tag: ce8f1934e4b6252084710975bd9bbc0a4648ece4 source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: 4251c0bb6e4f443f00231d28f5f70d42876da055 + tag: a715c7f420770b70bbe95ca51d3dec83866cb1bd subdir: binary binary/test slotting cardano-crypto-class cardano-crypto-praos + cardano-crypto-tests + strict-containers source-repository-package type: git location: https://github.com/input-output-hk/cardano-prelude - tag: ee4e7b547a991876e6b05ba542f4e62909f4a571 + tag: fd773f7a58412131512b9f694ab95653ac430852 subdir: cardano-prelude cardano-prelude-test @@ -92,32 +112,39 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: 6cb9052bde39472a0555d19ade8a42da63d3e904 + tag: e50613562d6d4a0f933741fcf590b0f69a1eda67 subdir: typed-protocols typed-protocols-examples ouroboros-network ouroboros-network-testing ouroboros-network-framework + ouroboros-consensus + ouroboros-consensus-byron + ouroboros-consensus-cardano + ouroboros-consensus-shelley io-sim io-sim-classes network-mux - Win32-network source-repository-package type: git location: https://github.com/input-output-hk/iohk-monitoring-framework - tag: a89c38ed5825ba17ca79fddb85651007753d699d + tag: 34abfb7f4f5610cabb45396e0496472446a0b2ca subdir: iohk-monitoring tracer-transformers contra-tracer + plugins/backend-aggregation plugins/backend-ekg + plugins/backend-monitoring + plugins/backend-trace-forwarder + plugins/scribe-systemd source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger-specs - tag: 097890495cbb0e8b62106bcd090a5721c3f4b36f + tag: a3ef848542961079b7cd53d599e5385198a3035c subdir: byron/chain/executable-spec byron/crypto @@ -129,8 +156,37 @@ source-repository-package semantics/small-steps-test shelley/chain-and-ledger/dependencies/non-integer shelley/chain-and-ledger/executable-spec + shelley/chain-and-ledger/shelley-spec-ledger-test shelley-ma/impl + cardano-ledger-core + alonzo/impl +-- A lot of plutus dependencies have to be synchronized with the dependencies of +-- cardano-node. If you update cardano-node, please make sure that all dependencies +-- of cardano-node are also updated. +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-node.git + tag: b3cabae6b3bf30a0b1b4e78bc4b67282dabad0a6 + subdir: + cardano-api/test + cardano-api + cardano-node + cardano-cli + cardano-config + +source-repository-package + type: git + location: https://github.com/input-output-hk/Win32-network + tag: 94153b676617f8f33abe8d8182c37377d2784bd1 + +source-repository-package + type: git + location: https://github.com/input-output-hk/hedgehog-extras + tag: 8bcd3c9dc22cc44f9fcfe161f4638a384fc7a187 + +-- The following dependencies are not mirrored in the +-- stack.yaml file, but they are needed regardless by cabal. source-repository-package type: git location: https://github.com/input-output-hk/goblins diff --git a/code/week01/src/Week01/EnglishAuction.hs b/code/week01/src/Week01/EnglishAuction.hs index 765dad0..a915c81 100644 --- a/code/week01/src/Week01/EnglishAuction.hs +++ b/code/week01/src/Week01/EnglishAuction.hs @@ -15,19 +15,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week01.EnglishAuction - ( Auction (..) - , StartParams (..), BidParams (..), CloseParams (..) - , AuctionSchema - , start, bid, close - , endpoints - , schemas - , ensureKnownCurrencies - , printJson - , printSchemas - , registeredKnownCurrencies - , stage - ) where +module Week01.EnglishAuction where import Control.Monad hiding (fmap) import Data.Aeson (ToJSON, FromJSON) @@ -35,26 +23,26 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Map as Map import Data.Text (pack, Text) import GHC.Generics (Generic) -import Plutus.Contract hiding (when) +import Plutus.Contract import qualified PlutusTx as PlutusTx import PlutusTx.Prelude hiding (Semigroup(..), unless) import qualified PlutusTx.Prelude as Plutus import Ledger hiding (singleton) import Ledger.Constraints as Constraints import qualified Ledger.Scripts as Scripts -import qualified Ledger.Typed.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts hiding (validatorHash) import Ledger.Value as Value import Ledger.Ada as Ada import Playground.Contract (ensureKnownCurrencies, printSchemas, stage, printJson) import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) import Playground.Types (KnownCurrency (..)) -import Prelude (Semigroup (..)) +import Prelude (IO, Semigroup (..), Show (..), String) import Schema (ToSchema) import Text.Printf (printf) data Auction = Auction { aSeller :: !PubKeyHash - , aDeadline :: !Slot + , aDeadline :: !POSIXTime , aMinBid :: !Integer , aCurrency :: !CurrencySymbol , aToken :: !TokenName @@ -99,7 +87,7 @@ PlutusTx.unstableMakeIsData ''AuctionDatum PlutusTx.makeLift ''AuctionDatum data Auctioning -instance Scripts.ScriptType Auctioning where +instance Scripts.ValidatorTypes Auctioning where type instance RedeemerType Auctioning = AuctionAction type instance DatumType Auctioning = AuctionDatum @@ -212,24 +200,21 @@ mkAuctionValidator ad redeemer ctx = in txOutAddress o == pubKeyHashAddress h -auctionInstance :: Scripts.ScriptInstance Auctioning -auctionInstance = Scripts.validator @Auctioning +auctionTypedValidator :: Scripts.TypedValidator Auctioning +auctionTypedValidator = Scripts.mkTypedValidator @Auctioning $$(PlutusTx.compile [|| mkAuctionValidator ||]) $$(PlutusTx.compile [|| wrap ||]) where - wrap = Scripts.wrapValidator @AuctionDatum @AuctionAction + wrap = Scripts.wrapValidator auctionValidator :: Validator -auctionValidator = Scripts.validatorScript auctionInstance +auctionValidator = Scripts.validatorScript auctionTypedValidator -auctionHash :: Ledger.ValidatorHash -auctionHash = Scripts.validatorHash auctionValidator - -auctionAddress :: Ledger.Address -auctionAddress = scriptHashAddress auctionHash +auctionAddress :: Ledger.ValidatorHash +auctionAddress = Scripts.validatorHash auctionValidator data StartParams = StartParams - { spDeadline :: !Slot + { spDeadline :: !POSIXTime , spMinBid :: !Integer , spCurrency :: !CurrencySymbol , spToken :: !TokenName @@ -247,12 +232,11 @@ data CloseParams = CloseParams } deriving (Generic, ToJSON, FromJSON, ToSchema) type AuctionSchema = - BlockchainActions - .\/ Endpoint "start" StartParams + Endpoint "start" StartParams .\/ Endpoint "bid" BidParams .\/ Endpoint "close" CloseParams -start :: (HasBlockchainActions s, AsContractError e) => StartParams -> Contract w s e () +start :: AsContractError e => StartParams -> Contract w s e () start StartParams{..} = do pkh <- pubKeyHash <$> ownPubKey let a = Auction @@ -268,11 +252,11 @@ start StartParams{..} = do } v = Value.singleton spCurrency spToken 1 tx = mustPayToTheScript d v - ledgerTx <- submitTxConstraints auctionInstance tx + ledgerTx <- submitTxConstraints auctionTypedValidator tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "started auction %s for token %s" (show a) (show v) -bid :: forall w s. HasBlockchainActions s => BidParams -> Contract w s Text () +bid :: forall w s. BidParams -> Contract w s Text () bid BidParams{..} = do (oref, o, d@AuctionDatum{..}) <- findAuction bpCurrency bpToken logInfo @String $ printf "found auction utxo with datum %s" (show d) @@ -285,8 +269,8 @@ bid BidParams{..} = do v = Value.singleton bpCurrency bpToken 1 <> Ada.lovelaceValueOf bpBid r = Redeemer $ PlutusTx.toData $ MkBid b - lookups = Constraints.scriptInstanceLookups auctionInstance <> - Constraints.otherScript auctionValidator <> + lookups = Constraints.typedValidatorLookups auctionTypedValidator <> + Constraints.otherScript auctionValidator <> Constraints.unspentOutputs (Map.singleton oref o) tx = case adHighestBid of Nothing -> mustPayToTheScript d' v <> @@ -304,7 +288,7 @@ bid BidParams{..} = do (show bpCurrency) (show bpToken) -close :: forall w s. HasBlockchainActions s => CloseParams -> Contract w s Text () +close :: forall w s. CloseParams -> Contract w s Text () close CloseParams{..} = do (oref, o, d@AuctionDatum{..}) <- findAuction cpCurrency cpToken logInfo @String $ printf "found auction utxo with datum %s" (show d) @@ -313,8 +297,8 @@ close CloseParams{..} = do r = Redeemer $ PlutusTx.toData Close seller = aSeller adAuction - lookups = Constraints.scriptInstanceLookups auctionInstance <> - Constraints.otherScript auctionValidator <> + lookups = Constraints.typedValidatorLookups auctionTypedValidator <> + Constraints.otherScript auctionValidator <> Constraints.unspentOutputs (Map.singleton oref o) tx = case adHighestBid of Nothing -> mustPayToPubKey seller t <> @@ -331,12 +315,9 @@ close CloseParams{..} = do (show cpCurrency) (show cpToken) -findAuction :: HasBlockchainActions s - => CurrencySymbol - -> TokenName - -> Contract w s Text (TxOutRef, TxOutTx, AuctionDatum) +findAuction :: CurrencySymbol -> TokenName -> Contract w s Text (TxOutRef, TxOutTx, AuctionDatum) findAuction cs tn = do - utxos <- utxoAt $ scriptHashAddress auctionHash + utxos <- utxoAt $ scriptAddress auctionValidator let xs = [ (oref, o) | (oref, o) <- Map.toList utxos , Value.valueOf (txOutValue $ txOutTxOut o) cs tn == 1