In week07 lecture Lars refers that Week07.EvenOdd contract is a bit unfair with player2 in the case of player2 wins .
Why 😢 ?
Well, player2 has to pay minAdaTxOut (2 ADA) to player1 in order to send back the token to player1. (Remember: an UTXO must include a minimum value of 2 ADAs ) Therefore, player2 wins 2 ADAs less than he/she should. 😒
Lars says that a possible solution is to create some kind of deposit from player1 locked in the validator.
Here, I've implemented a possible solution following Lars' approach.
Basically:
When player1 starts the contract, apart from locking the game stake value, player1 will lock a value player1Deposit consisting of 2 ADAs (minAdaTxOut).
Add extra constraints to the validator script, which will check that player1Deposit keeps locked into the contract until the contracts terminates.
This way, when the token gets sent back to player1 along with the mandatory minAdaTxOut, player2 won't have to pay minAdaTxOut because that value is already in the contract (the mentioned player1Deposit). 🥳
The evidence.
Here's the code.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week07.EvenOdd
( Game (..)
, GameChoice (..)
, FirstParams (..)
, SecondParams (..)
, GameSchema
, endpoints
) where
import Control.Monad hiding (fmap)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Map as Map
import Data.Text (Text)
import GHC.Generics (Generic)
import Ledger hiding (singleton)
import Ledger.Constraints as Constraints
import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Ada as Ada
import Ledger.Value
import Playground.Contract (ToSchema)
import Plutus.Contract as Contract
import qualified PlutusTx
import PlutusTx.Prelude hiding (Semigroup(..), unless)
import Prelude (Semigroup (..), Show (..), String)
import qualified Prelude
data Game = Game
{ gFirst :: !PaymentPubKeyHash
, gSecond :: !PaymentPubKeyHash
, gStake :: !Integer
, gPlayDeadline :: !POSIXTime
, gRevealDeadline :: !POSIXTime
, gToken :: !AssetClass
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
PlutusTx.makeLift ''Game
data GameChoice = Zero | One
deriving (Show, Generic, FromJSON, ToJSON, ToSchema, Prelude.Eq, Prelude.Ord)
instance Eq GameChoice where
{-# INLINABLE (==) #-}
Zero == Zero = True
One == One = True
_ == _ = False
PlutusTx.unstableMakeIsData ''GameChoice
data GameDatum = GameDatum BuiltinByteString (Maybe GameChoice)
deriving Show
instance Eq GameDatum where
{-# INLINABLE (==) #-}
GameDatum bs mc == GameDatum bs' mc' = (bs == bs') && (mc == mc')
PlutusTx.unstableMakeIsData ''GameDatum
data GameRedeemer = Play GameChoice | Reveal BuiltinByteString | ClaimFirst | ClaimSecond
deriving Show
PlutusTx.unstableMakeIsData ''GameRedeemer
{-# INLINABLE lovelaces #-}
lovelaces :: Value -> Integer
lovelaces = Ada.getLovelace . Ada.fromValue
{-# INLINABLE gameDatum #-}
gameDatum :: Maybe Datum -> Maybe GameDatum
gameDatum md = do
Datum d <- md
PlutusTx.fromBuiltinData d
{-# INLINABLE choiceToBuiltinByteString #-}
choiceToBuiltinByteString :: GameChoice -> BuiltinByteString
choiceToBuiltinByteString Zero = "0"
choiceToBuiltinByteString One = "1"
{-# INLINABLE player1Deposit #-}
player1Deposit :: Integer
player1Deposit = Ada.getLovelace minAdaTxOut
{-# INLINABLE mkGameValidator #-}
mkGameValidator :: Game -> GameDatum -> GameRedeemer -> ScriptContext -> Bool
mkGameValidator game dat red ctx =
traceIfFalse "token missing from input" (assetClassValueOf (txOutValue ownInput) (gToken game) == 1) &&
case (dat, red) of
(GameDatum bs Nothing, Play c) ->
traceIfFalse "not signed by second player" (txSignedBy info (unPaymentPubKeyHash $ gSecond game)) &&
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game + player1Deposit) &&
traceIfFalse "second player's stake missing" (lovelaces (txOutValue ownOutput) == (2 * gStake game + player1Deposit)) &&
traceIfFalse "wrong output datum" (outputDatum == GameDatum bs (Just c)) &&
traceIfFalse "missed deadline" (to (gPlayDeadline game) `contains` txInfoValidRange info) &&
traceIfFalse "token missing from output" (assetClassValueOf (txOutValue ownOutput) (gToken game) == 1)
(GameDatum bs (Just c), Reveal nonce) ->
traceIfFalse "not signed by first player" (txSignedBy info (unPaymentPubKeyHash $ gFirst game)) &&
traceIfFalse "commit mismatch" (checkNonce bs nonce c) &&
traceIfFalse "missed deadline" (to (gRevealDeadline game) `contains` txInfoValidRange info) &&
traceIfFalse "wrong stake" (lovelaces (txOutValue ownInput) == (2 * gStake game + player1Deposit)) &&
traceIfFalse "NFT must go to first player" nftToFirst &&
traceIfFalse "Player1 must get back the deposit" player1DepositBack
-- Here we mustn't set player1Deposit constraint.
-- If we did it and player1 didn't put the deposit at the beginning, the funds would block forever in the validator.
(GameDatum _ Nothing, ClaimFirst) ->
traceIfFalse "not signed by first player" (txSignedBy info (unPaymentPubKeyHash $ gFirst game)) &&
traceIfFalse "too early" (from (1 + gPlayDeadline game) `contains` txInfoValidRange info) &&
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game) &&
traceIfFalse "NFT must go to first player" nftToFirst
(GameDatum _ (Just _), ClaimSecond) ->
traceIfFalse "not signed by second player" (txSignedBy info (unPaymentPubKeyHash $ gSecond game)) &&
traceIfFalse "too early" (from (1 + gRevealDeadline game) `contains` txInfoValidRange info) &&
traceIfFalse "wrong stake" (lovelaces (txOutValue ownInput) == (2 * gStake game + player1Deposit)) &&
traceIfFalse "NFT must go to first player" nftToFirst &&
traceIfFalse "Player1 must get back the deposit" player1DepositBack
_ -> False
where
info :: TxInfo
info = scriptContextTxInfo ctx
ownInput :: TxOut
ownInput = case findOwnInput ctx of
Nothing -> traceError "game input missing"
Just i -> txInInfoResolved i
ownOutput :: TxOut
ownOutput = case getContinuingOutputs ctx of
[o] -> o
_ -> traceError "expected exactly one game output"
outputDatum :: GameDatum
outputDatum = case gameDatum $ txOutDatumHash ownOutput >>= flip findDatum info of
Nothing -> traceError "game output datum not found"
Just d -> d
checkNonce :: BuiltinByteString -> BuiltinByteString -> GameChoice -> Bool
checkNonce bs nonce cSecond = sha2_256 (nonce `appendByteString` choiceToBuiltinByteString cSecond) == bs
nftToFirst :: Bool
nftToFirst = assetClassValueOf (valuePaidTo info $ unPaymentPubKeyHash $ gFirst game) (gToken game) == 1
player1DepositBack :: Bool
player1DepositBack = valuePaidTo info (unPaymentPubKeyHash $ gFirst game) `geq` Ada.lovelaceValueOf player1Deposit
data Gaming
instance Scripts.ValidatorTypes Gaming where
type instance DatumType Gaming = GameDatum
type instance RedeemerType Gaming = GameRedeemer
typedGameValidator :: Game -> Scripts.TypedValidator Gaming
typedGameValidator game = Scripts.mkTypedValidator @Gaming
($$(PlutusTx.compile [|| mkGameValidator ||])
`PlutusTx.applyCode` PlutusTx.liftCode game)
$$(PlutusTx.compile [|| wrap ||])
where
wrap = Scripts.wrapValidator @GameDatum @GameRedeemer
gameValidator :: Game -> Validator
gameValidator = Scripts.validatorScript . typedGameValidator
gameAddress :: Game -> Ledger.Address
gameAddress = scriptAddress . gameValidator
findGameOutput :: Game -> Contract w s Text (Maybe (TxOutRef, ChainIndexTxOut, GameDatum))
findGameOutput game = do
utxos <- utxosAt $ gameAddress game
return $ do
(oref, o) <- find f $ Map.toList utxos
dat <- gameDatum $ either (const Nothing) Just $ _ciTxOutDatum o
return (oref, o, dat)
where
f :: (TxOutRef, ChainIndexTxOut) -> Bool
f (_, o) = assetClassValueOf (_ciTxOutValue o) (gToken game) == 1
waitUntilTimeHasPassed :: AsContractError e => POSIXTime -> Contract w s e ()
waitUntilTimeHasPassed t = do
s1 <- currentSlot
logInfo @String $ "current slot: " ++ show s1 ++ ", waiting until " ++ show t
void $ awaitTime t >> waitNSlots 1
s2 <- currentSlot
logInfo @String $ "waited until: " ++ show s2
data FirstParams = FirstParams
{ fpSecond :: !PaymentPubKeyHash
, fpStake :: !Integer
, fpPlayDeadline :: !POSIXTime
, fpRevealDeadline :: !POSIXTime
, fpNonce :: !BuiltinByteString
, fpCurrency :: !CurrencySymbol
, fpTokenName :: !TokenName
, fpChoice :: !GameChoice
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
firstGame :: forall w s. FirstParams -> Contract w s Text ()
firstGame fp = do
pkh <- Contract.ownPaymentPubKeyHash
let game = Game
{ gFirst = pkh
, gSecond = fpSecond fp
, gStake = fpStake fp
, gPlayDeadline = fpPlayDeadline fp
, gRevealDeadline = fpRevealDeadline fp
, gToken = AssetClass (fpCurrency fp, fpTokenName fp)
}
v = lovelaceValueOf (fpStake fp) <> assetClassValue (gToken game) 1 <> Ada.lovelaceValueOf player1Deposit
c = fpChoice fp
bs = sha2_256 $ fpNonce fp `appendByteString` choiceToBuiltinByteString c
tx = Constraints.mustPayToTheScript (GameDatum bs Nothing) v
ledgerTx <- submitTxConstraints (typedGameValidator game) tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @String $ "made first move: " ++ show (fpChoice fp)
waitUntilTimeHasPassed $ fpPlayDeadline fp
m <- findGameOutput game
now <- currentTime
case m of
Nothing -> throwError "game output not found"
Just (oref, o, dat) -> case dat of
GameDatum _ Nothing -> do
logInfo @String "second player did not play"
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
Constraints.otherScript (gameValidator game)
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData ClaimFirst) <>
Constraints.mustValidateIn (from now)
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx'
logInfo @String "reclaimed stake"
GameDatum _ (Just c') | c' == c -> do
logInfo @String "second player played and lost"
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
Constraints.otherScript (gameValidator game)
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData $ Reveal $ fpNonce fp) <>
Constraints.mustValidateIn (to $ now + 1000)
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx'
logInfo @String "victory"
_ -> logInfo @String "second player played and won"
data SecondParams = SecondParams
{ spFirst :: !PaymentPubKeyHash
, spStake :: !Integer
, spPlayDeadline :: !POSIXTime
, spRevealDeadline :: !POSIXTime
, spCurrency :: !CurrencySymbol
, spTokenName :: !TokenName
, spChoice :: !GameChoice
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
secondGame :: forall w s. SecondParams -> Contract w s Text ()
secondGame sp = do
pkh <- Contract.ownPaymentPubKeyHash
let game = Game
{ gFirst = spFirst sp
, gSecond = pkh
, gStake = spStake sp
, gPlayDeadline = spPlayDeadline sp
, gRevealDeadline = spRevealDeadline sp
, gToken = AssetClass (spCurrency sp, spTokenName sp)
}
m <- findGameOutput game
case m of
Just (oref, o, GameDatum bs Nothing) -> do
logInfo @String "running game found"
now <- currentTime
let token = assetClassValue (gToken game) 1
let v = let x = lovelaceValueOf (spStake sp) in x <> x <> token <> Ada.lovelaceValueOf player1Deposit
c = spChoice sp
lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
Constraints.otherScript (gameValidator game) <>
Constraints.typedValidatorLookups (typedGameValidator game)
tx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData $ Play c) <>
Constraints.mustPayToTheScript (GameDatum bs $ Just c) v <>
Constraints.mustValidateIn (to now)
ledgerTx <- submitTxConstraintsWith @Gaming lookups tx
let tid = getCardanoTxId ledgerTx
void $ awaitTxConfirmed tid
logInfo @String $ "made second move: " ++ show (spChoice sp)
waitUntilTimeHasPassed $ spRevealDeadline sp
m' <- findGameOutput game
now' <- currentTime
case m' of
Nothing -> logInfo @String "first player won"
Just (oref', o', _) -> do
logInfo @String "first player didn't reveal"
let lookups' = Constraints.unspentOutputs (Map.singleton oref' o') <>
Constraints.otherScript (gameValidator game)
tx' = Constraints.mustSpendScriptOutput oref' (Redeemer $ PlutusTx.toBuiltinData ClaimSecond) <>
Constraints.mustValidateIn (from now') <>
Constraints.mustPayToPubKey (spFirst sp) (token <> Ada.lovelaceValueOf player1Deposit)
ledgerTx' <- submitTxConstraintsWith @Gaming lookups' tx'
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx'
logInfo @String "second player won"
_ -> logInfo @String "no running game found"
type GameSchema = Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams
endpoints :: Contract () GameSchema Text ()
endpoints = awaitPromise (first `select` second) >> endpoints
where
first = endpoint @"first" firstGame
second = endpoint @"second" secondGame