diff --git a/.github/workflows/build-devcontainer.yml b/.github/workflows/build-devcontainer.yml index bde4a72..6017f60 100644 --- a/.github/workflows/build-devcontainer.yml +++ b/.github/workflows/build-devcontainer.yml @@ -20,4 +20,4 @@ jobs: -v ./.:/workspaces/plutus-tx-template \ -w /workspaces/plutus-tx-template \ -i ghcr.io/input-output-hk/devx-devcontainer:x86_64-linux.ghc96-iog \ - bash -ic "cabal update && cabal run plutus-tx-template && test -e validator.uplc" + bash -ic "cabal update && cabal build all" diff --git a/app/AuctionValidator.hs b/app/AuctionValidator.hs deleted file mode 100644 index 5d0bcc6..0000000 --- a/app/AuctionValidator.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-full-laziness #-} -{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# OPTIONS_GHC -fno-spec-constr #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fno-strictness #-} -{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} -{-# OPTIONS_GHC -fno-unbox-strict-fields #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} - -{- -Note that we imports `ScriptContext` from `PlutusLedgerApi.V2`, which means that -the script created from it will be a PlutusV2 script. -PlutusV2 only supports Plutus Core v1.0.0 (currently the highest and default -version is v1.1.0), which is why the `target-version=1.0.0` flag is needed. --} - -module AuctionValidator where - -import PlutusCore.Version (plcVersion100) -import PlutusLedgerApi.V1 (Lovelace, POSIXTime, PubKeyHash, Value) -import PlutusLedgerApi.V1.Address (pubKeyHashAddress) -import PlutusLedgerApi.V1.Interval (contains) -import PlutusLedgerApi.V1.Value (lovelaceValue) -import PlutusLedgerApi.V2 ( - Datum (..), - OutputDatum (..), - ScriptContext (..), - TxInfo (..), - TxOut (..), - from, - to, - ) -import PlutusLedgerApi.V2.Contexts (getContinuingOutputs) -import PlutusTx -import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Show qualified as PlutusTx - --- BLOCK1 -data AuctionParams = AuctionParams - { apSeller :: PubKeyHash - -- ^ Seller's wallet address. The highest bid (if exists) will be sent to the seller. - -- If there is no bid, the asset auctioned will be sent to the seller. - , apAsset :: Value - -- ^ The asset being auctioned. It can be a single token, multiple tokens of the same - -- kind, or tokens of different kinds, and the token(s) can be fungible or non-fungible. - -- These can all be encoded as a `Value`. - , apMinBid :: Lovelace - -- ^ The minimum bid in Lovelace. - , apEndTime :: POSIXTime - -- ^ The deadline for placing a bid. This is the earliest time the auction can be closed. - } - -PlutusTx.makeLift ''AuctionParams - -data Bid = Bid - { bBidder :: PubKeyHash - -- ^ Bidder's wallet address. - , bAmount :: Lovelace - -- ^ Bid amount in Lovelace. - } - -PlutusTx.deriveShow ''Bid -PlutusTx.unstableMakeIsData ''Bid - -instance PlutusTx.Eq Bid where - {-# INLINEABLE (==) #-} - bid == bid' = - bBidder bid - PlutusTx.== bBidder bid' - PlutusTx.&& bAmount bid - PlutusTx.== bAmount bid' - -{- | Datum represents the state of a smart contract. In this case -it contains the highest bid so far (if exists). --} -newtype AuctionDatum = AuctionDatum {adHighestBid :: Maybe Bid} - -PlutusTx.unstableMakeIsData ''AuctionDatum - -{- | Redeemer is the input that changes the state of a smart contract. -In this case it is either a new bid, or a request to close the auction -and pay out the seller and the highest bidder. --} -data AuctionRedeemer = NewBid Bid | Payout - -PlutusTx.unstableMakeIsData ''AuctionRedeemer - --- BLOCK2 - -{-# INLINEABLE auctionTypedValidator #-} - -{- | Given the auction parameters, determines whether the transaction is allowed to -spend the UTXO. --} -auctionTypedValidator :: - AuctionParams -> - AuctionDatum -> - AuctionRedeemer -> - ScriptContext -> - Bool -auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx@(ScriptContext txInfo _) = - PlutusTx.and conditions - where - conditions :: [Bool] - conditions = case redeemer of - NewBid bid -> - [ -- The new bid must be higher than the highest bid. - -- If this is the first bid, it must be at least as high as the minimum bid. - sufficientBid bid - , -- The bid is not too late. - validBidTime - , -- The previous highest bid should be refunded. - refundsPreviousHighestBid - , -- A correct new datum is produced, containing the new highest bid. - correctNewDatum bid - ] - Payout -> - [ -- The payout is not too early. - validPayoutTime - , -- The seller gets the highest bid. - sellerGetsHighestBid - , -- The highest bidder gets the asset. - highestBidderGetsAsset - ] - -- BLOCK3 - sufficientBid :: Bid -> Bool - sufficientBid (Bid _ amt) = case highestBid of - Just (Bid _ amt') -> amt PlutusTx.> amt' - Nothing -> amt PlutusTx.>= apMinBid params - -- BLOCK4 - validBidTime :: Bool - validBidTime = to (apEndTime params) `contains` txInfoValidRange txInfo - -- BLOCK5 - refundsPreviousHighestBid :: Bool - refundsPreviousHighestBid = case highestBid of - Nothing -> True - Just (Bid bidder amt) -> - case PlutusTx.find - ( \o -> - txOutAddress o - PlutusTx.== pubKeyHashAddress bidder - PlutusTx.&& txOutValue o - PlutusTx.== lovelaceValue amt - ) - (txInfoOutputs txInfo) of - Just _ -> True - Nothing -> PlutusTx.traceError ("Not found: refund output") - -- BLOCK6 - correctNewDatum :: Bid -> Bool - correctNewDatum bid = case getContinuingOutputs ctx of - [o] -> case txOutDatum o of - OutputDatum (Datum newDatum) -> case PlutusTx.fromBuiltinData newDatum of - Just bid' -> - PlutusTx.traceIfFalse - ( "Invalid output datum: expected " - PlutusTx.<> PlutusTx.show bid - PlutusTx.<> ", but got " - PlutusTx.<> PlutusTx.show bid' - ) - (bid PlutusTx.== bid') - Nothing -> - PlutusTx.traceError - ( "Failed to decode output datum: " - PlutusTx.<> PlutusTx.show newDatum - ) - OutputDatumHash _ -> - PlutusTx.traceError "Expected OutputDatum, got OutputDatumHash" - NoOutputDatum -> - PlutusTx.traceError "Expected OutputDatum, got NoOutputDatum" - os -> - PlutusTx.traceError - ( "Expected exactly one continuing output, got " - PlutusTx.<> PlutusTx.show (PlutusTx.length os) - ) - -- BLOCK7 - validPayoutTime :: Bool - validPayoutTime = from (apEndTime params) `contains` txInfoValidRange txInfo - - sellerGetsHighestBid :: Bool - sellerGetsHighestBid = case highestBid of - Nothing -> True - Just (Bid _ amt) -> - case PlutusTx.find - ( \o -> - txOutAddress o - PlutusTx.== pubKeyHashAddress (apSeller params) - PlutusTx.&& txOutValue o - PlutusTx.== lovelaceValue amt - ) - (txInfoOutputs txInfo) of - Just _ -> True - Nothing -> PlutusTx.traceError ("Not found: Output paid to seller") - - highestBidderGetsAsset :: Bool - highestBidderGetsAsset = case highestBid of - Nothing -> True - Just (Bid bidder _) -> - case PlutusTx.find - ( \o -> - txOutAddress o - PlutusTx.== pubKeyHashAddress bidder - PlutusTx.&& txOutValue o - PlutusTx.== apAsset params - ) - (txInfoOutputs txInfo) of - Just _ -> True - Nothing -> PlutusTx.traceError ("Not found: Output paid to highest bidder") - --- BLOCK8 -{-# INLINEABLE auctionUntypedValidator #-} -auctionUntypedValidator :: AuctionParams -> BuiltinData -> BuiltinData -> BuiltinData -> PlutusTx.BuiltinUnit -auctionUntypedValidator params datum redeemer ctx = - PlutusTx.check - ( auctionTypedValidator - params - (PlutusTx.unsafeFromBuiltinData datum) - (PlutusTx.unsafeFromBuiltinData redeemer) - (PlutusTx.unsafeFromBuiltinData ctx) - ) - -auctionValidatorScript :: - AuctionParams -> - CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> PlutusTx.BuiltinUnit) -auctionValidatorScript params = - $$(PlutusTx.compile [||auctionUntypedValidator||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 params - --- BLOCK9 diff --git a/app/GenAuctionValidatorBlueprint.hs b/app/GenAuctionValidatorBlueprint.hs new file mode 100644 index 0000000..84e8340 --- /dev/null +++ b/app/GenAuctionValidatorBlueprint.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import AuctionValidator +import Data.ByteString.Short qualified as Short +import Data.Set qualified as Set +import PlutusLedgerApi.Common (serialiseCompiledCode) +import PlutusTx.Blueprint +import System.Environment (getArgs) + +auctionParams :: AuctionParams +auctionParams = + AuctionParams + { apSeller = error "Replace with seller public key hash" + , apCurrencySymbol = error "Replace with currency symbol" + , apTokenName = "TokenToBeAuctioned" + , apMinBid = 100 + , apEndTime = error "Replace with the auction's end time" + } + +myContractBlueprint :: ContractBlueprint +myContractBlueprint = + MkContractBlueprint + { contractId = Just "auction-validator" + , contractPreamble = myPreamble + , contractValidators = Set.singleton myValidator + , contractDefinitions = deriveDefinitions @[AuctionParams, AuctionDatum, AuctionRedeemer] + } + +myPreamble :: Preamble +myPreamble = + MkPreamble + { preambleTitle = "Auction Validator" + , preambleDescription = Just "Blueprint for a Plutus script validating auction transactions" + , preambleVersion = "1.0.0" + , preamblePlutusVersion = PlutusV2 + , preambleLicense = Just "MIT" + } + +myValidator :: ValidatorBlueprint referencedTypes +myValidator = + MkValidatorBlueprint + { validatorTitle = "Auction Validator" + , validatorDescription = Just "Plutus script validating auction transactions" + , validatorParameters = + [ MkParameterBlueprint + { parameterTitle = Just "Parameters" + , parameterDescription = Just "Compile-time validator parameters" + , parameterPurpose = Set.singleton Spend + , parameterSchema = definitionRef @AuctionParams + } + ] + , validatorRedeemer = + MkArgumentBlueprint + { argumentTitle = Just "Redeemer" + , argumentDescription = Just "Redeemer for the auction validator" + , argumentPurpose = Set.fromList [Spend] + , argumentSchema = definitionRef @() + } + , validatorDatum = Nothing + , validatorCompiledCode = + Just . Short.fromShort . serialiseCompiledCode $ + auctionValidatorScript auctionParams + } + +writeBlueprintToFile :: FilePath -> IO () +writeBlueprintToFile path = writeBlueprint path myContractBlueprint + +main :: IO () +main = + getArgs >>= \case + [arg] -> writeBlueprintToFile arg + args -> fail $ "Expects one argument, got " <> show (length args) diff --git a/app/GenMintingPolicyBlueprint.hs b/app/GenMintingPolicyBlueprint.hs new file mode 100644 index 0000000..19379ef --- /dev/null +++ b/app/GenMintingPolicyBlueprint.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import AuctionMintingPolicy +import Data.ByteString.Short qualified as Short +import Data.Set qualified as Set +import PlutusLedgerApi.Common (serialiseCompiledCode) +import PlutusTx.Blueprint +import System.Environment (getArgs) + +myContractBlueprint :: ContractBlueprint +myContractBlueprint = + MkContractBlueprint + { contractId = Just "auction-minting-policy" + , contractPreamble = myPreamble + , contractValidators = Set.singleton myValidator + , contractDefinitions = deriveDefinitions @[AuctionMintingParams, ()] + } + +myPreamble :: Preamble +myPreamble = + MkPreamble + { preambleTitle = "Auction Minting Policy" + , preambleDescription = Just "A simple minting policy" + , preambleVersion = "1.0.0" + , preamblePlutusVersion = PlutusV2 + , preambleLicense = Just "MIT" + } + +myValidator :: ValidatorBlueprint referencedTypes +myValidator = + MkValidatorBlueprint + { validatorTitle = "Auction Minting Validator" + , validatorDescription = Just "A simple minting validator" + , validatorParameters = + [ MkParameterBlueprint + { parameterTitle = Just "Minting Validator Parameters" + , parameterDescription = Just "Compile-time validator parameters" + , parameterPurpose = Set.singleton Mint + , parameterSchema = definitionRef @AuctionMintingParams + } + ] + , validatorRedeemer = + MkArgumentBlueprint + { argumentTitle = Just "Redeemer for the minting policy" + , argumentDescription = Just "The minting policy does not use a redeemer, hence ()" + , argumentPurpose = Set.fromList [Mint] + , argumentSchema = definitionRef @() + } + , validatorDatum = Nothing + , validatorCompiledCode = + Just . Short.fromShort . serialiseCompiledCode $ + auctionMintingPolicyScript (error "Replace with seller pkh") + } + +writeBlueprintToFile :: FilePath -> IO () +writeBlueprintToFile path = writeBlueprint path myContractBlueprint + +main :: IO () +main = + getArgs >>= \case + [arg] -> writeBlueprintToFile arg + args -> fail $ "Expects one argument, got " <> show (length args) diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index 771ac8e..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import AuctionValidator -import Data.ByteString qualified as B -import Data.ByteString.Base16 qualified as Base16 -import Data.ByteString.Short qualified as B -import PlutusLedgerApi.V2 qualified as V2 - - -main :: IO () -main = B.writeFile "validator.uplc" . Base16.encode $ B.fromShort serialisedScript - where - script = auctionValidatorScript params - serialisedScript = V2.serialiseCompiledCode script - params = - AuctionParams - { apSeller = V2.PubKeyHash "addr_test1vqe09nt0rxgwn83upxuhqzs4aqrzdjqmhrh5l4g5hh4kc6qsncmku" - , -- The asset to be auctioned is 10000 lovelaces - apAsset = V2.singleton V2.adaSymbol V2.adaToken 10000 - , -- The minimum bid is 100 lovelaces - apMinBid = 100 - , apEndTime = 4102416000000 -- 01/01/2100 - } diff --git a/app/QUICKSTART.md b/app/QUICKSTART.md index 1e1e6da..4805314 100644 --- a/app/QUICKSTART.md +++ b/app/QUICKSTART.md @@ -6,9 +6,9 @@ The `main` function in `Main.hs` does two things: * Serialise the instantiated validator and write it to a file -Replace `apSeller` with the seller's [PubKeyHash](https://intersectmbo.github.io/plutus/master/plutus-ledger-api/html/PlutusLedgerApi-V2.html#t:PubKeyHash), which can be generated using Cardano CLI, Cardano API or an off-chain library for Cardano. +Replace `apSeller` with the seller's [PubKeyHash](https://plutus.cardano.intersectmbo.org/haddock/master/plutus-ledger-api/PlutusLedgerApi-V2.html#t:PubKeyHash), which can be generated using Cardano CLI, Cardano API or an off-chain library for Cardano. -Replace `apEndTime` with your desired [POSIXTime](https://intersectmbo.github.io/plutus/master/plutus-ledger-api/html/PlutusLedgerApi-V2.html#t:POSIXTime). +Replace `apEndTime` with your desired [POSIXTime](https://plutus.cardano.intersectmbo.org/haddock/master/plutus-ledger-api/PlutusLedgerApi-V2.html#t:POSIXTime). Now, build it: ``` diff --git a/cabal.project b/cabal.project index d8ae319..b4872a4 100644 --- a/cabal.project +++ b/cabal.project @@ -11,9 +11,9 @@ repository cardano-haskell-packages index-state: -- Bump both the following dates if you need newer packages from Hackage - , hackage.haskell.org 2024-09-12T00:00:00Z + , hackage.haskell.org 2024-09-10T13:49:28Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2024-09-12T00:00:00Z + , cardano-haskell-packages 2024-09-10T13:49:28Z -packages: +packages: ./. diff --git a/plutus-tx-template.cabal b/plutus-tx-template.cabal index a0f0a80..a7d8379 100644 --- a/plutus-tx-template.cabal +++ b/plutus-tx-template.cabal @@ -8,20 +8,48 @@ extra-doc-files: README.md common warnings ghc-options: -Wall -executable plutus-tx-template +library scripts + import: warnings + hs-source-dirs: src + exposed-modules: + AuctionMintingPolicy + AuctionValidator + + build-depends: + , base + , plutus-core ^>=1.34 + , plutus-ledger-api ^>=1.34 + , plutus-tx ^>=1.34 + + if !(impl(ghcjs) || os(ghcjs)) + build-depends: plutus-tx-plugin + +executable gen-auction-validator-blueprint import: warnings hs-source-dirs: app default-language: Haskell2010 - main-is: Main.hs + main-is: GenAuctionValidatorBlueprint.hs build-depends: , base - , base16-bytestring , bytestring + , containers , plutus-core ^>=1.34.0.0 , plutus-ledger-api ^>=1.34.0.0 , plutus-tx ^>=1.34.0.0 , plutus-tx-plugin ^>=1.34.0.0 - , text - , time + , scripts - other-modules: AuctionValidator +executable gen-minting-policy-blueprint + import: warnings + hs-source-dirs: app + default-language: Haskell2010 + main-is: GenMintingPolicyBlueprint.hs + build-depends: + , base + , bytestring + , containers + , plutus-core ^>=1.34.0.0 + , plutus-ledger-api ^>=1.34.0.0 + , plutus-tx ^>=1.34.0.0 + , plutus-tx-plugin ^>=1.34.0.0 + , scripts diff --git a/src/AuctionMintingPolicy.hs b/src/AuctionMintingPolicy.hs new file mode 100644 index 0000000..388f63e --- /dev/null +++ b/src/AuctionMintingPolicy.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} +{-# OPTIONS_GHC -fno-unbox-strict-fields #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} + +module AuctionMintingPolicy where + +import PlutusCore.Version (plcVersion100) +import PlutusLedgerApi.V1.Value (flattenValue) +import PlutusLedgerApi.V2 (PubKeyHash, ScriptContext (..), TxInfo (..)) +import PlutusLedgerApi.V2.Contexts (ownCurrencySymbol, txSignedBy) +import PlutusTx +import PlutusTx.Prelude qualified as PlutusTx + +-- BLOCK1 +type AuctionMintingParams = PubKeyHash +type AuctionMintingRedeemer = () + +{-# INLINEABLE auctionTypedMintingPolicy #-} +auctionTypedMintingPolicy :: + AuctionMintingParams -> + AuctionMintingRedeemer -> + ScriptContext -> + Bool +auctionTypedMintingPolicy pkh _redeemer ctx = + txSignedBy txInfo pkh PlutusTx.&& mintedExactlyOneToken + where + txInfo = scriptContextTxInfo ctx + mintedExactlyOneToken = case flattenValue (txInfoMint txInfo) of + [(currencySymbol, _tokenName, quantity)] -> + currencySymbol PlutusTx.== ownCurrencySymbol ctx PlutusTx.&& quantity PlutusTx.== 1 + _ -> False +-- BLOCK2 + +auctionUntypedMintingPolicy :: + AuctionMintingParams -> + BuiltinData -> + BuiltinData -> + PlutusTx.BuiltinUnit +auctionUntypedMintingPolicy pkh redeemer ctx = + PlutusTx.check + ( auctionTypedMintingPolicy + pkh + (PlutusTx.unsafeFromBuiltinData redeemer) + (PlutusTx.unsafeFromBuiltinData ctx) + ) + +auctionMintingPolicyScript :: + AuctionMintingParams -> + CompiledCode (BuiltinData -> BuiltinData -> PlutusTx.BuiltinUnit) +auctionMintingPolicyScript pkh = + $$(PlutusTx.compile [||auctionUntypedMintingPolicy||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 pkh diff --git a/src/AuctionValidator.hs b/src/AuctionValidator.hs new file mode 100644 index 0000000..6496c05 --- /dev/null +++ b/src/AuctionValidator.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} +{-# OPTIONS_GHC -fno-unbox-strict-fields #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} + +module AuctionValidator where + +import GHC.Generics (Generic) + +import PlutusCore.Version (plcVersion100) +import PlutusLedgerApi.V1 (Lovelace, POSIXTime, PubKeyHash) +import PlutusLedgerApi.V1.Address (toPubKeyHash) +import PlutusLedgerApi.V1.Interval (contains) +import PlutusLedgerApi.V1.Value (lovelaceValueOf, valueOf) +import PlutusLedgerApi.V2 (CurrencySymbol, Datum (..), OutputDatum (..), ScriptContext (..), + TokenName, TxInfo (..), TxOut (..), from, to) +import PlutusLedgerApi.V2.Contexts (getContinuingOutputs) +import PlutusTx +import PlutusTx.AsData qualified as PlutusTx +import PlutusTx.Blueprint +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Show qualified as PlutusTx + +-- BLOCK1 +-- AuctionValidator.hs +data AuctionParams = AuctionParams + { apSeller :: PubKeyHash + -- ^ Seller's public key hash. The highest bid (if exists) will be sent to the seller. + -- If there is no bid, the asset auctioned will be sent to the seller. + , apCurrencySymbol :: CurrencySymbol + -- ^ The currency symbol of the token being auctioned. + , apTokenName :: TokenName + -- ^ The name of the token being auctioned. + -- These can all be encoded as a `Value`. + , apMinBid :: Lovelace + -- ^ The minimum bid in Lovelace. + , apEndTime :: POSIXTime + -- ^ The deadline for placing a bid. This is the earliest time the auction can be closed. + } + deriving stock (Generic) + deriving anyclass (HasBlueprintDefinition) + +PlutusTx.makeLift ''AuctionParams +PlutusTx.makeIsDataSchemaIndexed ''AuctionParams [('AuctionParams, 0)] + +data Bid = Bid + { bAddr :: PlutusTx.BuiltinByteString + -- ^ Bodder's wallet address + , bPkh :: PubKeyHash + -- ^ Bidder's public key hash. + , bAmount :: Lovelace + -- ^ Bid amount in Lovelace. + } + deriving stock (Generic) + deriving anyclass (HasBlueprintDefinition) + +PlutusTx.deriveShow ''Bid +PlutusTx.makeIsDataSchemaIndexed ''Bid [('Bid, 0)] + +instance PlutusTx.Eq Bid where + {-# INLINEABLE (==) #-} + bid == bid' = + bPkh bid + PlutusTx.== bPkh bid' + PlutusTx.&& bAmount bid + PlutusTx.== bAmount bid' + +{- | Datum represents the state of a smart contract. In this case +it contains the highest bid so far (if exists). +-} +newtype AuctionDatum = AuctionDatum {adHighestBid :: Maybe Bid} + deriving stock (Generic) + deriving newtype + ( HasBlueprintDefinition + , PlutusTx.ToData + , PlutusTx.FromData + , PlutusTx.UnsafeFromData + ) + +{- | Redeemer is the input that changes the state of a smart contract. +In this case it is either a new bid, or a request to close the auction +and pay out the seller and the highest bidder. +-} +data AuctionRedeemer = NewBid Bid | Payout + deriving stock (Generic) + deriving anyclass (HasBlueprintDefinition) + +PlutusTx.makeIsDataSchemaIndexed ''AuctionRedeemer [('NewBid, 0), ('Payout, 1)] + +-- BLOCK2 +-- AuctionValidator.hs +{-# INLINEABLE auctionTypedValidator #-} + +{- | Given the auction parameters, determines whether the transaction is allowed to +spend the UTXO. +-} +auctionTypedValidator :: + AuctionParams -> + AuctionDatum -> + AuctionRedeemer -> + ScriptContext -> + Bool +auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx@(ScriptContext txInfo _) = + PlutusTx.and conditions + where + conditions :: [Bool] + conditions = case redeemer of + NewBid bid -> + [ -- The new bid must be higher than the highest bid. + -- If this is the first bid, it must be at least as high as the minimum bid. + sufficientBid bid + , -- The bid is not too late. + validBidTime + , -- The previous highest bid should be refunded. + refundsPreviousHighestBid + , -- A correct new datum is produced, containing the new highest bid. + correctOutput bid + ] + Payout -> + [ -- The payout is not too early. + validPayoutTime + , -- The seller gets the highest bid. + sellerGetsHighestBid + , -- The highest bidder gets the asset. + highestBidderGetsAsset + ] +-- BLOCK3 +-- AuctionValidator.hs + sufficientBid :: Bid -> Bool + sufficientBid (Bid _ _ amt) = case highestBid of + Just (Bid _ _ amt') -> amt PlutusTx.> amt' + Nothing -> amt PlutusTx.>= apMinBid params +-- BLOCK4 +-- AuctionValidator.hs + validBidTime :: Bool + ~validBidTime = to (apEndTime params) `contains` txInfoValidRange txInfo +-- BLOCK5 +-- AuctionValidator.hs + refundsPreviousHighestBid :: Bool + ~refundsPreviousHighestBid = case highestBid of + Nothing -> True + Just (Bid _ bidderPkh amt) -> + case PlutusTx.find + ( \o -> + (toPubKeyHash (txOutAddress o) PlutusTx.== Just bidderPkh) + PlutusTx.&& (lovelaceValueOf (txOutValue o) PlutusTx.== amt) + ) + (txInfoOutputs txInfo) of + Just _ -> True + Nothing -> PlutusTx.traceError "Not found: refund output" +-- BLOCK6 +-- AuctionValidator.hs + currencySymbol :: CurrencySymbol + currencySymbol = apCurrencySymbol params + + tokenName :: TokenName + tokenName = apTokenName params + + correctOutput :: Bid -> Bool + correctOutput bid = case getContinuingOutputs ctx of + [o] -> + let correctOutputDatum = case txOutDatum o of + OutputDatum (Datum newDatum) -> case PlutusTx.fromBuiltinData newDatum of + Just (AuctionDatum (Just bid')) -> + PlutusTx.traceIfFalse + "Invalid output datum: contains a different Bid than expected" + (bid PlutusTx.== bid') + Just (AuctionDatum Nothing) -> + PlutusTx.traceError "Invalid output datum: expected Just Bid, got Nothing" + Nothing -> + PlutusTx.traceError "Failed to decode output datum" + OutputDatumHash _ -> + PlutusTx.traceError "Expected OutputDatum, got OutputDatumHash" + NoOutputDatum -> + PlutusTx.traceError "Expected OutputDatum, got NoOutputDatum" + + outValue = txOutValue o + + correctOutputValue = + (lovelaceValueOf outValue PlutusTx.== bAmount bid) + PlutusTx.&& (valueOf outValue currencySymbol tokenName PlutusTx.== 1) + in correctOutputDatum PlutusTx.&& correctOutputValue + os -> + PlutusTx.traceError + ( "Expected exactly one continuing output, got " + PlutusTx.<> PlutusTx.show (PlutusTx.length os) + ) +-- BLOCK7 +-- AuctionValidator.hs + validPayoutTime :: Bool + ~validPayoutTime = from (apEndTime params) `contains` txInfoValidRange txInfo + + sellerGetsHighestBid :: Bool + ~sellerGetsHighestBid = case highestBid of + Nothing -> True + Just bid -> + case PlutusTx.find + ( \o -> + (toPubKeyHash (txOutAddress o) PlutusTx.== Just (apSeller params)) + PlutusTx.&& (lovelaceValueOf (txOutValue o) PlutusTx.== bAmount bid) + ) + (txInfoOutputs txInfo) of + Just _ -> True + Nothing -> PlutusTx.traceError "Not found: Output paid to seller" + + highestBidderGetsAsset :: Bool + ~highestBidderGetsAsset = + let highestBidder = case highestBid of + -- If there are no bids, the asset should go back to the seller + Nothing -> apSeller params + Just bid -> bPkh bid + in case PlutusTx.find + ( \o -> + (toPubKeyHash (txOutAddress o) PlutusTx.== Just highestBidder) + PlutusTx.&& (valueOf (txOutValue o) currencySymbol tokenName PlutusTx.== 1) + ) + (txInfoOutputs txInfo) of + Just _ -> True + Nothing -> PlutusTx.traceError "Not found: Output paid to highest bidder" + +-- BLOCK8 +-- AuctionValidator.hs +{-# INLINEABLE auctionUntypedValidator #-} +auctionUntypedValidator :: + AuctionParams -> + BuiltinData -> + BuiltinData -> + BuiltinData -> + PlutusTx.BuiltinUnit +auctionUntypedValidator params datum redeemer ctx = + PlutusTx.check + ( auctionTypedValidator + params + (PlutusTx.unsafeFromBuiltinData datum) + (PlutusTx.unsafeFromBuiltinData redeemer) + (PlutusTx.unsafeFromBuiltinData ctx) + ) + +auctionValidatorScript :: + AuctionParams -> + CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> PlutusTx.BuiltinUnit) +auctionValidatorScript params = + $$(PlutusTx.compile [||auctionUntypedValidator||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 params + +-- BLOCK9 +-- AuctionValidator.hs +PlutusTx.asData + [d| + data Bid' = Bid' + { bPkh' :: PubKeyHash + , -- \^ Bidder's wallet address. + bAmount' :: Lovelace + } + -- \^ Bid amount in Lovelace. + + -- We can derive instances with the newtype strategy, and they + -- will be based on the instances for 'Data' + deriving newtype (Eq, Ord, PlutusTx.ToData, FromData, UnsafeFromData) + + -- don't do this for the datum, since it's just a newtype so + -- simply delegates to the underlying type + + -- \| Redeemer is the input that changes the state of a smart contract. + -- In this case it is either a new bid, or a request to close the auction + -- and pay out the seller and the highest bidder. + data AuctionRedeemer' = NewBid' Bid | Payout' + deriving newtype (Eq, Ord, PlutusTx.ToData, FromData, UnsafeFromData) + |] + +-- BLOCK10 +-- AuctionValidator.hs