Plutus Playground Smart Contract

Playground.hs

import           Control.Monad             (void)
import qualified Data.ByteString.Char8     as C
import           Language.Plutus.Contract
import qualified Language.PlutusTx         as PlutusTx
import           Language.PlutusTx.Prelude hiding (pure, (<$>))
import           Ledger                    (Address, Validator, ValidatorCtx, Value, scriptAddress, PubKeyHash, Slot (Slot), Datum(..), TxOutTx, PubKeyHash (..) )
import           Ledger.Contexts                   (TxInfo (..), ValidatorCtx (..))
import qualified Ledger.Constraints        as Constraints
import qualified Ledger.Contexts                   as Validation
import qualified Ledger.Interval                   as Interval
import qualified Ledger.Slot                       as Slot
import qualified Ledger.Typed.Scripts      as Scripts
import           Playground.Contract
import qualified Prelude


import           Control.Monad                     (void, when)
import qualified Data.Map                          as Map
import qualified Data.Text                         as T
import           Data.Maybe                        (fromJust, catMaybes)

import           Language.Plutus.Contract          hiding (when)
import qualified Language.Plutus.Contract.Typed.Tx as Typed
import qualified Language.PlutusTx                 as PlutusTx
import           Language.PlutusTx.Prelude         hiding (Semigroup (..), fold)
import           Ledger                            (Address, PubKeyHash, Slot (Slot), Validator, pubKeyHash, txOutTxDatum, txOutValue, txOutTxOut, TxOut)
import qualified Ledger.Ada                        as Ada
import           Ledger.Constraints                (TxConstraints, mustBeSignedBy, mustPayToTheScript, mustValidateIn)
import           Ledger.Contexts                   (TxInfo (..), ValidatorCtx (..))
import qualified Ledger.Contexts                   as Validation
import           Ledger.Interval                   (before, after, ivFrom, ivTo, interval) 
import qualified Ledger.Slot                       as Slot
import qualified Ledger.Tx                         as Tx
import qualified Ledger.Typed.Scripts              as Scripts
import           Ledger.Value                      (Value, currencySymbol, tokenName)
import qualified Ledger.Value                      as Value
import           Playground.Contract
import           Wallet.Emulator.Types             (walletPubKey)
import           Ledger.Ada
------------------------------------------------------------

bidIncrease  = 10
endSlot = Slot 20


lovelaceValue :: Value -> Integer
lovelaceValue value = getLovelace $ Ledger.Ada.fromValue value

-- | Datum and redeemer parameter types
data Auction
instance Scripts.ScriptType Auction where
    type instance RedeemerType Auction = PubKeyHash
    type instance DatumType Auction = AuctionData


data AuctionData = AuctionData{
      owner          :: PubKeyHash
    , previousBidder :: PubKeyHash
    } deriving (Generic)

PlutusTx.makeLift ''AuctionData
PlutusTx.makeIsData ''AuctionData

{-# INLINABLE validate #-}
validate :: AuctionData -> PubKeyHash -> ValidatorCtx -> Bool
validate AuctionData{owner=ownerInDatum,previousBidder} currentOwner ctx@ValidatorCtx{valCtxTxInfo=txInfo@TxInfo{txInfoValidRange=Interval.Interval{ivFrom=startRange, ivTo=endRange}}} =
    let
        newBid  =   lovelaceValue $ Validation.valueLockedBy txInfo (Validation.ownHash ctx) 
        oldBid = lovelaceValue $ Validation.valuePaidTo txInfo previousBidder 
        paidToOwner = lovelaceValue $ Validation.valuePaidTo txInfo ownerInDatum
        totalSpent = lovelaceValue $ Validation.valueSpent txInfo
    in
        if Interval.strictLowerBound endSlot < startRange then --the transaction is valid after the end slot
            oldBid == 0 && newBid == 0 
            && paidToOwner == totalSpent
        else
            newBid > (oldBid + bidIncrease) 
            && ownerInDatum == currentOwner



auctionInstance :: Scripts.ScriptInstance Auction
auctionInstance  = Scripts.validator @Auction
    $$(PlutusTx.compile [|| validate ||])
    $$(PlutusTx.compile [|| wrap ||]) where
        wrap = Scripts.wrapValidator @AuctionData @PubKeyHash

auctionAddress :: Address
auctionAddress = Ledger.scriptAddress (Scripts.validatorScript auctionInstance)

-- | Parameters for the "bid" endpoint
data BidParams = BidParams
    { bidAmount :: Integer
    }
    deriving stock (Prelude.Eq, Prelude.Show, Generic)
    deriving anyclass (FromJSON, ToJSON, IotsType, ToSchema, ToArgument)


type AuctionSchema =
    BlockchainActions
        .\/ Endpoint "1-startAuction" BidParams
        .\/ Endpoint "2-bid" BidParams
        .\/ Endpoint "3-collect" ()

{-# INLINABLE extractData #-}
extractData :: (PlutusTx.IsData a) => TxOutTx -> Maybe a
extractData txOut = do
                        datum <- txOutTxDatum txOut
                        let dat = getDatum datum
                        PlutusTx.fromData dat    


startAuction :: Contract AuctionSchema T.Text ()
startAuction = do
                BidParams basePrice <- endpoint @"1-startAuction" @BidParams
                owner <- pubKeyHash <$> ownPubKey
                let tx = Constraints.mustPayToTheScript AuctionData{owner,previousBidder=owner} ( Ledger.Ada.lovelaceValueOf basePrice)
                logInfo $ T.unwords [ "Owner " , T.pack (show (owner)) `T.append` "."]    
                void (submitTxConstraints auctionInstance tx)


-- | Bid in the auction
bid :: Contract AuctionSchema T.Text ()
bid = do
    BidParams newBid <- endpoint @"2-bid" @BidParams
    unspentOutputs <- utxoAt auctionAddress
    let 
        txOuts = Map.elems unspentOutputs
        AuctionData{owner, previousBidder} = head $ catMaybes ( map extractData  txOuts )  -- should be only one UTXO ? Anyway, all should have the same datum  
        previousBid  = getLovelace $ Ledger.Ada.fromValue $    foldl1 (<>) $ map (txOutValue.txOutTxOut) txOuts        
    if newBid > (previousBid + bidIncrease) then 
        do
            newBidder <- pubKeyHash <$> ownPubKey
            let 
                txAddBid        = Constraints.mustPayToTheScript AuctionData{owner,previousBidder=newBidder} $ ( Ledger.Ada.lovelaceValueOf newBid)
                txPayToPrevious = Constraints.mustPayToPubKey previousBidder (Ledger.Ada.lovelaceValueOf previousBid)
                txValidRange    = Constraints.mustValidateIn $ interval (Slot 1) endSlot  
                txCollect       = collectFromScript unspentOutputs owner
                tx = txCollect <> txAddBid <> txPayToPrevious <> txValidRange 
            logInfo $ T.unwords [ "Bid " , T.pack (show (newBid)) `T.append` "."]
            void (submitTxConstraintsSpending auctionInstance unspentOutputs tx)
    else 
        throwError $ T.unwords
            [ "Bid must be greater than"
            , T.pack (show (previousBid + bidIncrease)) `T.append` "."
            ]

collect :: Contract AuctionSchema T.Text ()
collect = do
            endpoint @"3-collect" @()
            unspentOutputs <- utxoAt auctionAddress
            let 
                txOuts = Map.elems unspentOutputs
                AuctionData{owner} = head $ catMaybes ( map extractData  txOuts )   
                winningBid  = foldl1 (<>) $ map (txOutValue.txOutTxOut) txOuts 
                txCollect       = collectFromScript unspentOutputs owner 
                payToOwner = Constraints.mustPayToPubKey owner winningBid      
                txValidRange    = Constraints.mustValidateIn $ Interval.from (endSlot + 1)
                tx        = txCollect <> payToOwner <> txValidRange
            logInfo $ T.unwords [ "Owner " , T.pack (show (owner)) `T.append` ".", "Range", T.pack (show (Interval.from (endSlot+1))), "Winnining", T.pack ( show (winningBid)) ]    
            void (submitTxConstraintsSpending auctionInstance unspentOutputs tx)

endpoints :: Contract AuctionSchema T.Text ()
endpoints = startAuction `select` bid `select` collect

mkSchemaDefinitions ''AuctionSchema

$(mkKnownCurrencies [])

Simulation.json

[0,[{"simulationWallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[]}]]