Plutus Playground Smart Contract

Playground.hs

-- A game with two players. Player 1 thinks of a secret word
-- and uses its hash, and the game validator script, to lock
-- some funds (the prize) in a pay-to-script transaction output.
-- Player 2 guesses the word by attempting to spend the transaction
-- output. If the guess is correct, the validator script releases the funds.
-- If it isn't, the funds stay locked.
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           Prelude                           (Semigroup (..))
import           Wallet.Emulator.Types             (walletPubKey)
import           Ledger.Ada
------------------------------------------------------------

bidIncrease :: Integer = 10
endSlot = Slot 20


-- | 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 }} =
    let
        -- spent = getLovelace $ Ledger.Ada.fromValue $ Validation.valueSpent txInfo 
        newBid  = getLovelace $ Ledger.Ada.fromValue $ Validation.valueLockedBy txInfo (Validation.ownHash ctx) 
        oldBid = getLovelace $ Ledger.Ada.fromValue $ Validation.valuePaidTo txInfo previousBidder 
        -- ownerInDatum == currOwner
    in
      --  endSlot `Interval.member` txInfoValidRange && newBid >0 && oldBid >0 && newBid > oldBid && newBid == 30  && oldBid ==10 && spent > ( newBid + oldBid)       
        -- if endSlot `Interval.member` txInfoValidRange then --begining of tx range  <= end slot
        --     newBid > (oldBid + bidIncrease)
        --     -- &&  valuePaidToPrev == currentBid
        -- else 
        --     not (endSlot `Interval.member` txInfoValidRange)
        --     && oldBid == (getLovelace $ Ledger.Ada.fromValue $ Validation.valuePaidTo txInfo owner ) 
        if endSlot `Interval.before` txInfoValidRange then
            newBid == (getLovelace $ Ledger.Ada.fromValue $ Validation.valuePaidTo txInfo ownerInDatum ) 
        else
            newBid > (oldBid + bidIncrease) 
            && ownerInDatum == currentOwner
        
-- double check date ranges and slot comparation



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":""},1000]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},1000]]]]}},{"simulatorWalletWallet":{"getWallet":3},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},1000]]]]}},{"simulatorWalletWallet":{"getWallet":4},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},1000]]]]}},{"simulatorWalletWallet":{"getWallet":5},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},1000]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[{"caller":{"getWallet":1},"argumentValues":{"endpointDescription":{"getEndpointDescription":"1-startAuction"},"argument":{"contents":[["bidAmount",{"s":1,"e":1,"c":[10],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":1,"tag":"AddBlocks"},{"caller":{"getWallet":2},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-bid"},"argument":{"contents":[["bidAmount",{"s":1,"e":1,"c":[30],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":1,"tag":"AddBlocks"},{"caller":{"getWallet":3},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-bid"},"argument":{"contents":[["bidAmount",{"s":1,"e":1,"c":[40],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":1,"tag":"AddBlocks"},{"caller":{"getWallet":4},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-bid"},"argument":{"contents":[["bidAmount",{"s":1,"e":2,"c":[100],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":40,"tag":"AddBlocks"},{"caller":{"getWallet":5},"argumentValues":{"endpointDescription":{"getEndpointDescription":"3-collect"},"argument":{"tag":"FormUnitF"}},"tag":"CallEndpoint"},{"blocks":1,"tag":"AddBlocks"}]}]]