bumped Plutus and fixed EnglishAuction

This commit is contained in:
Lars Brünjes 2021-06-23 00:12:31 +02:00
parent e530a9345d
commit 2ec71d7ecf
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
2 changed files with 101 additions and 64 deletions

View file

@ -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

View file

@ -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