using state token

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

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,26 +86,32 @@ 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 =
traceIfFalse "token missing from input" (assetClassValueOf (txOutValue ownInput) (gToken game) == 1) &&
case (dat, red) of
(GameDatum bs Nothing, Play c) -> (GameDatum bs Nothing, Play c) ->
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) && traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game) && traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game) &&
traceIfFalse "second player's stake missing" (lovelaces (txOutValue ownOutput) == (2 * gStake game)) && traceIfFalse "second player's stake missing" (lovelaces (txOutValue ownOutput) == (2 * gStake game)) &&
traceIfFalse "wrong output datum" (outputDatum == GameDatum bs (Just c)) && traceIfFalse "wrong output datum" (outputDatum == GameDatum bs (Just c)) &&
traceIfFalse "missed deadline" (to (gPlayDeadline game) `contains` txInfoValidRange info) 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
@ -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,8 +197,9 @@ 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
@ -187,10 +209,11 @@ firstGame fp = do
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
GameDatum _ Nothing -> do
logInfo @String "second player did not play" logInfo @String "second player did not play"
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <> let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
Constraints.otherScript (gameValidator game) Constraints.otherScript (gameValidator game)
@ -198,7 +221,8 @@ firstGame fp = do
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx' ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
void $ awaitTxConfirmed $ txId ledgerTx' void $ awaitTxConfirmed $ txId ledgerTx'
logInfo @String "reclaimed stake" logInfo @String "reclaimed stake"
Just (oref, o, Just _) -> do
GameDatum _ (Just c') | c' == c -> do
logInfo @String "second player played and lost" logInfo @String "second player played and lost"
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <> let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
Constraints.otherScript (gameValidator game) Constraints.otherScript (gameValidator game)
@ -207,30 +231,16 @@ firstGame fp = do
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx' ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
void $ awaitTxConfirmed $ txId ledgerTx' void $ awaitTxConfirmed $ txId ledgerTx'
logInfo @String "victory" logInfo @String "victory"
where
findOutput :: Game -> ByteString -> GameChoice -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Maybe GameChoice)) _ -> logInfo @String "second player played and won"
findOutput game bs c = do
utxos <- utxoAt $ gameAddress game
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