mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-14 19:02:53 +01:00
using state token
This commit is contained in:
Lars Brünjes
parent
1ab5906489
commit
c9854d6a21
1 changed files with 81 additions and 91 deletions
|
|
@ -32,6 +32,7 @@ import Ledger hiding (singleton)
|
||||||
import Ledger.Constraints as Constraints
|
import Ledger.Constraints as Constraints
|
||||||
import qualified Ledger.Typed.Scripts as Scripts
|
import qualified Ledger.Typed.Scripts as Scripts
|
||||||
import Ledger.Ada as Ada
|
import Ledger.Ada as Ada
|
||||||
|
import Ledger.Value
|
||||||
import Playground.Contract (ToSchema)
|
import Playground.Contract (ToSchema)
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import qualified Prelude
|
import qualified Prelude
|
||||||
|
|
@ -42,6 +43,7 @@ data Game = Game
|
||||||
, gStake :: !Integer
|
, gStake :: !Integer
|
||||||
, gPlayDeadline :: !Slot
|
, gPlayDeadline :: !Slot
|
||||||
, gRevealDeadline :: !Slot
|
, gRevealDeadline :: !Slot
|
||||||
|
, gToken :: !AssetClass
|
||||||
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
|
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
|
||||||
|
|
||||||
PlutusTx.makeLift ''Game
|
PlutusTx.makeLift ''Game
|
||||||
|
|
@ -84,28 +86,34 @@ gameDatum o f = do
|
||||||
|
|
||||||
{-# INLINABLE mkGameValidator #-}
|
{-# INLINABLE mkGameValidator #-}
|
||||||
mkGameValidator :: Game -> ByteString -> ByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool
|
mkGameValidator :: Game -> ByteString -> ByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool
|
||||||
mkGameValidator game bsZero' bsOne' dat red ctx = case (dat, red) of
|
mkGameValidator game bsZero' bsOne' dat red ctx =
|
||||||
(GameDatum bs Nothing, Play c) ->
|
traceIfFalse "token missing from input" (assetClassValueOf (txOutValue ownInput) (gToken game) == 1) &&
|
||||||
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
|
case (dat, red) of
|
||||||
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game) &&
|
(GameDatum bs Nothing, Play c) ->
|
||||||
traceIfFalse "second player's stake missing" (lovelaces (txOutValue ownOutput) == (2 * gStake game)) &&
|
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
|
||||||
traceIfFalse "wrong output datum" (outputDatum == GameDatum bs (Just c)) &&
|
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game) &&
|
||||||
traceIfFalse "missed deadline" (to (gPlayDeadline game) `contains` txInfoValidRange info)
|
traceIfFalse "second player's stake missing" (lovelaces (txOutValue ownOutput) == (2 * gStake game)) &&
|
||||||
|
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) ->
|
(GameDatum bs (Just c), Reveal nonce) ->
|
||||||
traceIfFalse "not signed by first player" (txSignedBy info (gFirst game)) &&
|
traceIfFalse "not signed by first player" (txSignedBy info (gFirst game)) &&
|
||||||
traceIfFalse "commit mismatch" (checkNonce bs nonce c) &&
|
traceIfFalse "commit mismatch" (checkNonce bs nonce c) &&
|
||||||
traceIfFalse "missed deadline" (to (gRevealDeadline game) `contains` txInfoValidRange info)
|
traceIfFalse "missed deadline" (to (gRevealDeadline game) `contains` txInfoValidRange info) &&
|
||||||
|
traceIfFalse "wrong stake" (lovelaces (txOutValue ownInput) == (2 * gStake game))
|
||||||
|
|
||||||
(GameDatum _ Nothing, ClaimFirst) ->
|
(GameDatum _ Nothing, ClaimFirst) ->
|
||||||
traceIfFalse "not signed by first player" (txSignedBy info (gFirst game)) &&
|
traceIfFalse "not signed by first player" (txSignedBy info (gFirst game)) &&
|
||||||
traceIfFalse "too early" (from (1 + gPlayDeadline game) `contains` txInfoValidRange info)
|
traceIfFalse "too early" (from (1 + gPlayDeadline game) `contains` txInfoValidRange info) &&
|
||||||
|
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game)
|
||||||
|
|
||||||
(GameDatum _ (Just _), ClaimSecond) ->
|
(GameDatum _ (Just _), ClaimSecond) ->
|
||||||
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
|
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
|
||||||
traceIfFalse "to early" (from (1 + gRevealDeadline game) `contains` txInfoValidRange info)
|
traceIfFalse "to early" (from (1 + gRevealDeadline game) `contains` txInfoValidRange info) &&
|
||||||
|
traceIfFalse "wrong stake" (lovelaces (txOutValue ownInput) == (2 * gStake game))
|
||||||
|
|
||||||
_ -> False
|
_ -> False
|
||||||
where
|
where
|
||||||
info :: TxInfo
|
info :: TxInfo
|
||||||
info = scriptContextTxInfo ctx
|
info = scriptContextTxInfo ctx
|
||||||
|
|
@ -158,12 +166,25 @@ gameValidator = Scripts.validatorScript . gameInst
|
||||||
gameAddress :: Game -> Ledger.Address
|
gameAddress :: Game -> Ledger.Address
|
||||||
gameAddress = scriptAddress . gameValidator
|
gameAddress = scriptAddress . gameValidator
|
||||||
|
|
||||||
|
findGameOutput :: HasBlockchainActions s => Game -> Contract w s Text (Maybe (TxOutRef, TxOutTx, GameDatum))
|
||||||
|
findGameOutput game = do
|
||||||
|
utxos <- utxoAt $ gameAddress game
|
||||||
|
return $ do
|
||||||
|
(oref, o) <- find f $ Map.toList utxos
|
||||||
|
dat <- gameDatum (txOutTxOut o) (`Map.lookup` txData (txOutTxTx o))
|
||||||
|
return (oref, o, dat)
|
||||||
|
where
|
||||||
|
f :: (TxOutRef, TxOutTx) -> Bool
|
||||||
|
f (_, o) = assetClassValueOf (txOutValue $ txOutTxOut o) (gToken game) == 1
|
||||||
|
|
||||||
data FirstParams = FirstParams
|
data FirstParams = FirstParams
|
||||||
{ fpSecond :: !PubKeyHash
|
{ fpSecond :: !PubKeyHash
|
||||||
, fpStake :: !Integer
|
, fpStake :: !Integer
|
||||||
, fpPlayDeadline :: !Slot
|
, fpPlayDeadline :: !Slot
|
||||||
, fpRevealDeadline :: !Slot
|
, fpRevealDeadline :: !Slot
|
||||||
, fpNonce :: !ByteString
|
, fpNonce :: !ByteString
|
||||||
|
, fpCurrency :: !CurrencySymbol
|
||||||
|
, fpTokenName :: !TokenName
|
||||||
, fpChoice :: !GameChoice
|
, fpChoice :: !GameChoice
|
||||||
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
|
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
|
||||||
|
|
||||||
|
|
@ -176,61 +197,50 @@ firstGame fp = do
|
||||||
, gStake = fpStake fp
|
, gStake = fpStake fp
|
||||||
, gPlayDeadline = fpPlayDeadline fp
|
, gPlayDeadline = fpPlayDeadline fp
|
||||||
, gRevealDeadline = fpRevealDeadline fp
|
, gRevealDeadline = fpRevealDeadline fp
|
||||||
|
, gToken = AssetClass (fpCurrency fp, fpTokenName fp)
|
||||||
}
|
}
|
||||||
v = lovelaceValueOf $ fpStake fp
|
v = lovelaceValueOf (fpStake fp) <> assetClassValue (gToken game) 1
|
||||||
c = fpChoice fp
|
c = fpChoice fp
|
||||||
bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne
|
bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne
|
||||||
tx = Constraints.mustPayToTheScript (GameDatum bs Nothing) v
|
tx = Constraints.mustPayToTheScript (GameDatum bs Nothing) v
|
||||||
ledgerTx <- submitTxConstraints (gameInst game) tx
|
ledgerTx <- submitTxConstraints (gameInst game) tx
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
logInfo @String $ "made first move: " ++ show (fpChoice fp)
|
logInfo @String $ "made first move: " ++ show (fpChoice fp)
|
||||||
|
|
||||||
void $ awaitSlot $ 1 + fpPlayDeadline fp
|
void $ awaitSlot $ 1 + fpPlayDeadline fp
|
||||||
|
|
||||||
m <- findOutput game bs c
|
m <- findGameOutput game
|
||||||
case m of
|
case m of
|
||||||
Nothing -> logInfo @String "no opportunity to win"
|
Nothing -> throwError "game output not found"
|
||||||
Just (oref, o, Nothing) -> do
|
Just (oref, o, dat) -> case dat of
|
||||||
logInfo @String "second player did not play"
|
GameDatum _ Nothing -> do
|
||||||
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
logInfo @String "second player did not play"
|
||||||
Constraints.otherScript (gameValidator game)
|
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||||
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData ClaimFirst)
|
Constraints.otherScript (gameValidator game)
|
||||||
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
|
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData ClaimFirst)
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx'
|
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
|
||||||
logInfo @String "reclaimed stake"
|
void $ awaitTxConfirmed $ txId ledgerTx'
|
||||||
Just (oref, o, Just _) -> do
|
logInfo @String "reclaimed stake"
|
||||||
logInfo @String "second player played and lost"
|
|
||||||
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
GameDatum _ (Just c') | c' == c -> do
|
||||||
Constraints.otherScript (gameValidator game)
|
logInfo @String "second player played and lost"
|
||||||
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Reveal $ fpNonce fp) <>
|
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||||
Constraints.mustValidateIn (to $ fpRevealDeadline fp)
|
Constraints.otherScript (gameValidator game)
|
||||||
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
|
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Reveal $ fpNonce fp) <>
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx'
|
Constraints.mustValidateIn (to $ fpRevealDeadline fp)
|
||||||
logInfo @String "victory"
|
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
|
||||||
where
|
void $ awaitTxConfirmed $ txId ledgerTx'
|
||||||
findOutput :: Game -> ByteString -> GameChoice -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Maybe GameChoice))
|
logInfo @String "victory"
|
||||||
findOutput game bs c = do
|
|
||||||
utxos <- utxoAt $ gameAddress game
|
_ -> logInfo @String "second player played and won"
|
||||||
return $ case mapMaybe f $ Map.toList utxos of
|
|
||||||
[] -> Nothing
|
|
||||||
xs -> case find (\(_, _, mc) -> isJust mc) xs of
|
|
||||||
Nothing -> Just $ head xs -- we know this list is not empty, because we are in the second case
|
|
||||||
Just x -> Just x
|
|
||||||
where
|
|
||||||
f :: (TxOutRef, TxOutTx) -> Maybe (TxOutRef, TxOutTx, Maybe GameChoice)
|
|
||||||
f (oref, o) = do
|
|
||||||
guard $ lovelaces (txOutValue $ txOutTxOut o) == 2 * fpStake fp
|
|
||||||
dat <- gameDatum (txOutTxOut o) (`Map.lookup` txData (txOutTxTx o))
|
|
||||||
case dat of
|
|
||||||
GameDatum bs' mc
|
|
||||||
| bs' == bs && (isNothing mc || mc == Just c) -> return (oref, o, mc)
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
data SecondParams = SecondParams
|
data SecondParams = SecondParams
|
||||||
{ spFirst :: !PubKeyHash
|
{ spFirst :: !PubKeyHash
|
||||||
, spStake :: !Integer
|
, spStake :: !Integer
|
||||||
, spPlayDeadline :: !Slot
|
, spPlayDeadline :: !Slot
|
||||||
, spRevealDeadline :: !Slot
|
, spRevealDeadline :: !Slot
|
||||||
|
, spCurrency :: !CurrencySymbol
|
||||||
|
, spTokenName :: !TokenName
|
||||||
, spChoice :: !GameChoice
|
, spChoice :: !GameChoice
|
||||||
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
|
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
|
||||||
|
|
||||||
|
|
@ -243,19 +253,20 @@ secondGame sp = do
|
||||||
, gStake = spStake sp
|
, gStake = spStake sp
|
||||||
, gPlayDeadline = spPlayDeadline sp
|
, gPlayDeadline = spPlayDeadline sp
|
||||||
, gRevealDeadline = spRevealDeadline sp
|
, gRevealDeadline = spRevealDeadline sp
|
||||||
|
, gToken = AssetClass (spCurrency sp, spTokenName sp)
|
||||||
}
|
}
|
||||||
m <- findOutput game
|
m <- findGameOutput game
|
||||||
case m of
|
case m of
|
||||||
Nothing -> logInfo @String "no running game found"
|
Just (oref, o, GameDatum bs Nothing) -> do
|
||||||
Just (oref, o, bs) -> do
|
|
||||||
logInfo @String "running game found"
|
logInfo @String "running game found"
|
||||||
let v = lovelaceValueOf $ spStake sp
|
let token = assetClassValue (gToken game) 1
|
||||||
|
let v = let x = lovelaceValueOf (spStake sp) in x <> x <> token
|
||||||
c = spChoice sp
|
c = spChoice sp
|
||||||
lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||||
Constraints.otherScript (gameValidator game) <>
|
Constraints.otherScript (gameValidator game) <>
|
||||||
Constraints.scriptInstanceLookups (gameInst game)
|
Constraints.scriptInstanceLookups (gameInst game)
|
||||||
tx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Play c) <>
|
tx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Play c) <>
|
||||||
Constraints.mustPayToTheScript (GameDatum bs $ Just c) (v <> v) <>
|
Constraints.mustPayToTheScript (GameDatum bs $ Just c) v <>
|
||||||
Constraints.mustValidateIn (to $ spPlayDeadline sp)
|
Constraints.mustValidateIn (to $ spPlayDeadline sp)
|
||||||
ledgerTx <- submitTxConstraintsWith @Gaming lookups tx
|
ledgerTx <- submitTxConstraintsWith @Gaming lookups tx
|
||||||
let tid = txId ledgerTx
|
let tid = txId ledgerTx
|
||||||
|
|
@ -264,42 +275,21 @@ secondGame sp = do
|
||||||
|
|
||||||
void $ awaitSlot $ 1 + spRevealDeadline sp
|
void $ awaitSlot $ 1 + spRevealDeadline sp
|
||||||
|
|
||||||
m' <- findOutput' game tid
|
m' <- findGameOutput game
|
||||||
case m' of
|
case m' of
|
||||||
Nothing -> logInfo @String "first player won"
|
Nothing -> logInfo @String "first player won"
|
||||||
Just (oref', o') -> do
|
Just (oref', o', _) -> do
|
||||||
logInfo @String "first player didn't reveal"
|
logInfo @String "first player didn't reveal"
|
||||||
let lookups' = Constraints.unspentOutputs (Map.singleton oref' o') <>
|
let lookups' = Constraints.unspentOutputs (Map.singleton oref' o') <>
|
||||||
Constraints.otherScript (gameValidator game)
|
Constraints.otherScript (gameValidator game)
|
||||||
tx' = Constraints.mustSpendScriptOutput oref' (Redeemer $ PlutusTx.toData ClaimSecond) <>
|
tx' = Constraints.mustSpendScriptOutput oref' (Redeemer $ PlutusTx.toData ClaimSecond) <>
|
||||||
Constraints.mustValidateIn (from $ 1 + spRevealDeadline sp)
|
Constraints.mustValidateIn (from $ 1 + spRevealDeadline sp) <>
|
||||||
|
Constraints.mustPayToPubKey (spFirst sp) token
|
||||||
ledgerTx' <- submitTxConstraintsWith @Gaming lookups' tx'
|
ledgerTx' <- submitTxConstraintsWith @Gaming lookups' tx'
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx'
|
void $ awaitTxConfirmed $ txId ledgerTx'
|
||||||
logInfo @String "second player won"
|
logInfo @String "second player won"
|
||||||
where
|
|
||||||
findOutput :: Game -> Contract w s Text (Maybe (TxOutRef, TxOutTx, ByteString))
|
|
||||||
findOutput game = do
|
|
||||||
now <- currentSlot
|
|
||||||
if now > spPlayDeadline sp
|
|
||||||
then return Nothing
|
|
||||||
else do
|
|
||||||
utxos <- utxoAt $ gameAddress game
|
|
||||||
return $ case mapMaybe f $ Map.toList utxos of
|
|
||||||
[] -> Nothing
|
|
||||||
x : _ -> Just x
|
|
||||||
where
|
|
||||||
f :: (TxOutRef, TxOutTx) -> Maybe (TxOutRef, TxOutTx, ByteString)
|
|
||||||
f (oref, o) = do
|
|
||||||
guard $ lovelaces (txOutValue $ txOutTxOut o) == spStake sp
|
|
||||||
dat <- gameDatum (txOutTxOut o) (`Map.lookup` txData (txOutTxTx o))
|
|
||||||
case dat of
|
|
||||||
GameDatum bs Nothing -> return (oref, o, bs)
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
findOutput' :: Game -> TxId -> Contract w s Text (Maybe (TxOutRef, TxOutTx))
|
_ -> logInfo @String "no running game found"
|
||||||
findOutput' game tid = do
|
|
||||||
utxos <- utxoAt $ gameAddress game
|
|
||||||
return $ find (\(oref, _) -> txOutRefId oref == tid) $ Map.toList utxos
|
|
||||||
|
|
||||||
type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams
|
type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue