mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-14 02:42:35 +01:00
bumped Plutus and fixed EnglishAuction
This commit is contained in:
Lars Brünjes
parent
e530a9345d
commit
2ec71d7ecf
2 changed files with 101 additions and 64 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,7 +269,7 @@ bid BidParams{..} = do
|
|||
v = Value.singleton bpCurrency bpToken 1 <> Ada.lovelaceValueOf bpBid
|
||||
r = Redeemer $ PlutusTx.toData $ MkBid b
|
||||
|
||||
lookups = Constraints.scriptInstanceLookups auctionInstance <>
|
||||
lookups = Constraints.typedValidatorLookups auctionTypedValidator <>
|
||||
Constraints.otherScript auctionValidator <>
|
||||
Constraints.unspentOutputs (Map.singleton oref o)
|
||||
tx = case adHighestBid of
|
||||
|
|
@ -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,7 +297,7 @@ close CloseParams{..} = do
|
|||
r = Redeemer $ PlutusTx.toData Close
|
||||
seller = aSeller adAuction
|
||||
|
||||
lookups = Constraints.scriptInstanceLookups auctionInstance <>
|
||||
lookups = Constraints.typedValidatorLookups auctionTypedValidator <>
|
||||
Constraints.otherScript auctionValidator <>
|
||||
Constraints.unspentOutputs (Map.singleton oref o)
|
||||
tx = case adHighestBid of
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue