claudiomaradonna/plutus-pioneer-program
1
0
Fork 0
mirror of https://github.com/FiloSpaTeam/plutus-pioneer-program.git synced 2024-11-14 02:42:35 +01:00
Code Issues Projects Releases Packages Wiki Activity

using state token

Browse source
This commit is contained in:
Lars Brünjes 2021-05-18 16:11:29 +02:00
parent 1ab5906489
commit c9854d6a21
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
1 changed files with 81 additions and 91 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

172
code/week07/src/Week07/EvenOdd.hs
View file

@ -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