From 475c6eda3f47449d63160af0f261b089eaabae0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Thu, 20 May 2021 00:31:25 +0200 Subject: [PATCH] solution for week 7 --- .../plutus-pioneer-program-week07.cabal | 2 + code/week07/src/Week07/RockPaperScissors.hs | 302 ++++++++++++++++++ .../src/Week07/TestRockPaperScissors.hs | 96 ++++++ 3 files changed, 400 insertions(+) create mode 100644 code/week07/src/Week07/RockPaperScissors.hs create mode 100644 code/week07/src/Week07/TestRockPaperScissors.hs diff --git a/code/week07/plutus-pioneer-program-week07.cabal b/code/week07/plutus-pioneer-program-week07.cabal index 3f9d784..c42c2be 100644 --- a/code/week07/plutus-pioneer-program-week07.cabal +++ b/code/week07/plutus-pioneer-program-week07.cabal @@ -11,8 +11,10 @@ License-files: LICENSE library hs-source-dirs: src exposed-modules: Week07.EvenOdd + , Week07.RockPaperScissors , Week07.StateMachine , Week07.Test + , Week07.TestRockPaperScissors , Week07.TestStateMachine build-depends: aeson , base ^>=4.14.1.0 diff --git a/code/week07/src/Week07/RockPaperScissors.hs b/code/week07/src/Week07/RockPaperScissors.hs new file mode 100644 index 0000000..1b1db18 --- /dev/null +++ b/code/week07/src/Week07/RockPaperScissors.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week07.RockPaperScissors + ( Game (..) + , GameChoice (..) + , FirstParams (..) + , SecondParams (..) + , GameSchema + , endpoints + ) where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Contract.StateMachine +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), check, unless) +import Ledger hiding (singleton) +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import Ledger.Typed.Tx +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Playground.Contract (ToSchema) +import Prelude (Semigroup (..)) +import qualified Prelude + +data Game = Game + { gFirst :: !PubKeyHash + , gSecond :: !PubKeyHash + , gStake :: !Integer + , gPlayDeadline :: !Slot + , gRevealDeadline :: !Slot + , gToken :: !AssetClass + } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord) + +PlutusTx.makeLift ''Game + +data GameChoice = Rock | Paper | Scissors + deriving (Show, Generic, FromJSON, ToJSON, ToSchema, Prelude.Eq, Prelude.Ord) + +instance Eq GameChoice where + {-# INLINABLE (==) #-} + Rock == Rock = True + Paper == Paper = True + Scissors == Scissors = True + _ == _ = False + +PlutusTx.unstableMakeIsData ''GameChoice + +{-# INLINABLE beats #-} +beats :: GameChoice -> GameChoice -> Bool +beats Rock Scissors = True +beats Paper Rock = True +beats Scissors Paper = True +beats _ _ = False + +data GameDatum = GameDatum ByteString (Maybe GameChoice) | Finished + deriving Show + +instance Eq GameDatum where + {-# INLINABLE (==) #-} + GameDatum bs mc == GameDatum bs' mc' = (bs == bs') && (mc == mc') + Finished == Finished = True + _ == _ = False + +PlutusTx.unstableMakeIsData ''GameDatum + +data GameRedeemer = Play GameChoice | Reveal ByteString GameChoice | ClaimFirst | ClaimSecond + deriving Show + +PlutusTx.unstableMakeIsData ''GameRedeemer + +{-# INLINABLE lovelaces #-} +lovelaces :: Value -> Integer +lovelaces = Ada.getLovelace . Ada.fromValue + +{-# INLINABLE gameDatum #-} +gameDatum :: TxOut -> (DatumHash -> Maybe Datum) -> Maybe GameDatum +gameDatum o f = do + dh <- txOutDatum o + Datum d <- f dh + PlutusTx.fromData d + +{-# INLINABLE transition #-} +transition :: Game -> State GameDatum -> GameRedeemer -> Maybe (TxConstraints Void Void, State GameDatum) +transition game s r = case (stateValue s, stateData s, r) of + (v, GameDatum bs Nothing, Play c) + | lovelaces v == gStake game -> Just ( Constraints.mustBeSignedBy (gSecond game) <> + Constraints.mustValidateIn (to $ gPlayDeadline game) + , State (GameDatum bs $ Just c) (lovelaceValueOf $ 2 * gStake game) + ) + (v, GameDatum _ (Just c), Reveal _ c') + | (lovelaces v == (2 * gStake game)) && + (c' `beats` c) -> Just ( Constraints.mustBeSignedBy (gFirst game) <> + Constraints.mustValidateIn (to $ gRevealDeadline game) <> + Constraints.mustPayToPubKey (gFirst game) token + , State Finished mempty + ) + + | (lovelaces v == (2 * gStake game)) && + (c' == c) -> Just ( Constraints.mustBeSignedBy (gFirst game) <> + Constraints.mustValidateIn (to $ gRevealDeadline game) <> + Constraints.mustPayToPubKey (gFirst game) token <> + Constraints.mustPayToPubKey (gSecond game) + (lovelaceValueOf $ gStake game) + , State Finished mempty + ) + (v, GameDatum _ Nothing, ClaimFirst) + | lovelaces v == gStake game -> Just ( Constraints.mustBeSignedBy (gFirst game) <> + Constraints.mustValidateIn (from $ 1 + gPlayDeadline game) <> + Constraints.mustPayToPubKey (gFirst game) token + , State Finished mempty + ) + (v, GameDatum _ (Just _), ClaimSecond) + | lovelaces v == (2 * gStake game) -> Just ( Constraints.mustBeSignedBy (gSecond game) <> + Constraints.mustValidateIn (from $ 1 + gRevealDeadline game) <> + Constraints.mustPayToPubKey (gFirst game) token + , State Finished mempty + ) + _ -> Nothing + where + token :: Value + token = assetClassValue (gToken game) 1 + +{-# INLINABLE final #-} +final :: GameDatum -> Bool +final Finished = True +final _ = False + +{-# INLINABLE check #-} +check :: ByteString -> ByteString -> ByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool +check bsRock' bsPaper' bsScissors' (GameDatum bs (Just _)) (Reveal nonce c) _ = + sha2_256 (nonce `concatenate` toBS c) == bs + where + toBS :: GameChoice -> ByteString + toBS Rock = bsRock' + toBS Paper = bsPaper' + toBS Scissors = bsScissors' +check _ _ _ _ _ _ = True + +{-# INLINABLE gameStateMachine #-} +gameStateMachine :: Game -> ByteString -> ByteString -> ByteString -> StateMachine GameDatum GameRedeemer +gameStateMachine game bsRock' bsPaper' bsScissors' = StateMachine + { smTransition = transition game + , smFinal = final + , smCheck = check bsRock' bsPaper' bsScissors' + , smThreadToken = Just $ gToken game + } + +{-# INLINABLE mkGameValidator #-} +mkGameValidator :: Game -> ByteString -> ByteString -> ByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool +mkGameValidator game bsRock' bsPaper' bsScissors' = mkValidator $ gameStateMachine game bsRock' bsPaper' bsScissors' + +type Gaming = StateMachine GameDatum GameRedeemer + +bsRock, bsPaper, bsScissors :: ByteString +bsRock = "R" +bsPaper = "P" +bsScissors = "S" + +gameStateMachine' :: Game -> StateMachine GameDatum GameRedeemer +gameStateMachine' game = gameStateMachine game bsRock bsPaper bsScissors + +gameInst :: Game -> Scripts.ScriptInstance Gaming +gameInst game = Scripts.validator @Gaming + ($$(PlutusTx.compile [|| mkGameValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode game + `PlutusTx.applyCode` PlutusTx.liftCode bsRock + `PlutusTx.applyCode` PlutusTx.liftCode bsPaper + `PlutusTx.applyCode` PlutusTx.liftCode bsScissors) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @GameDatum @GameRedeemer + +gameValidator :: Game -> Validator +gameValidator = Scripts.validatorScript . gameInst + +gameAddress :: Game -> Ledger.Address +gameAddress = scriptAddress . gameValidator + +gameClient :: Game -> StateMachineClient GameDatum GameRedeemer +gameClient game = mkStateMachineClient $ StateMachineInstance (gameStateMachine' game) (gameInst game) + +data FirstParams = FirstParams + { fpSecond :: !PubKeyHash + , fpStake :: !Integer + , fpPlayDeadline :: !Slot + , fpRevealDeadline :: !Slot + , fpNonce :: !ByteString + , fpCurrency :: !CurrencySymbol + , fpTokenName :: !TokenName + , fpChoice :: !GameChoice + } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) + +mapError' :: Contract w s SMContractError a -> Contract w s Text a +mapError' = mapError $ pack . show + +firstGame :: forall w s. HasBlockchainActions s => FirstParams -> Contract w s Text () +firstGame fp = do + pkh <- pubKeyHash <$> Contract.ownPubKey + let game = Game + { gFirst = pkh + , gSecond = fpSecond fp + , gStake = fpStake fp + , gPlayDeadline = fpPlayDeadline fp + , gRevealDeadline = fpRevealDeadline fp + , gToken = AssetClass (fpCurrency fp, fpTokenName fp) + } + client = gameClient game + v = lovelaceValueOf (fpStake fp) + c = fpChoice fp + x = case c of + Rock -> bsRock + Paper -> bsPaper + Scissors -> bsScissors + bs = sha2_256 $ fpNonce fp `concatenate` x + void $ mapError' $ runInitialise client (GameDatum bs Nothing) v + logInfo @String $ "made first move: " ++ show (fpChoice fp) + + void $ awaitSlot $ 1 + fpPlayDeadline fp + + m <- mapError' $ getOnChainState client + case m of + Nothing -> throwError "game output not found" + Just ((o, _), _) -> case tyTxOutData o of + + GameDatum _ Nothing -> do + logInfo @String "second player did not play" + void $ mapError' $ runStep client ClaimFirst + logInfo @String "first player reclaimed stake" + + GameDatum _ (Just c') | c `beats` c' || c' == c -> do + logInfo @String "second player played and lost or drew" + void $ mapError' $ runStep client $ Reveal (fpNonce fp) c + logInfo @String "first player revealed and won or drew" + + _ -> logInfo @String "second player played and won" + +data SecondParams = SecondParams + { spFirst :: !PubKeyHash + , spStake :: !Integer + , spPlayDeadline :: !Slot + , spRevealDeadline :: !Slot + , spCurrency :: !CurrencySymbol + , spTokenName :: !TokenName + , spChoice :: !GameChoice + } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) + +secondGame :: forall w s. HasBlockchainActions s => SecondParams -> Contract w s Text () +secondGame sp = do + pkh <- pubKeyHash <$> Contract.ownPubKey + let game = Game + { gFirst = spFirst sp + , gSecond = pkh + , gStake = spStake sp + , gPlayDeadline = spPlayDeadline sp + , gRevealDeadline = spRevealDeadline sp + , gToken = AssetClass (spCurrency sp, spTokenName sp) + } + client = gameClient game + m <- mapError' $ getOnChainState client + case m of + Nothing -> logInfo @String "no running game found" + Just ((o, _), _) -> case tyTxOutData o of + GameDatum _ Nothing -> do + logInfo @String "running game found" + void $ mapError' $ runStep client $ Play $ spChoice sp + logInfo @String $ "made second move: " ++ show (spChoice sp) + + void $ awaitSlot $ 1 + spRevealDeadline sp + + m' <- mapError' $ getOnChainState client + case m' of + Nothing -> logInfo @String "first player won or drew" + Just _ -> do + logInfo @String "first player didn't reveal" + void $ mapError' $ runStep client ClaimSecond + logInfo @String "second player won" + + _ -> throwError "unexpected datum" + +type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams + +endpoints :: Contract () GameSchema Text () +endpoints = (first `select` second) >> endpoints + where + first = endpoint @"first" >>= firstGame + second = endpoint @"second" >>= secondGame diff --git a/code/week07/src/Week07/TestRockPaperScissors.hs b/code/week07/src/Week07/TestRockPaperScissors.hs new file mode 100644 index 0000000..150e755 --- /dev/null +++ b/code/week07/src/Week07/TestRockPaperScissors.hs @@ -0,0 +1,96 @@ +{-# 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.TestRockPaperScissors where + +import Control.Monad hiding (fmap) +import Control.Monad.Freer.Extras as Extras +import Data.Default (Default (..)) +import qualified Data.Map as Map +import Ledger +import Ledger.Value +import Ledger.Ada as Ada +import Plutus.Trace.Emulator as Emulator +import PlutusTx.Prelude +import Wallet.Emulator.Wallet + +import Week07.RockPaperScissors + +test :: IO () +test = do + test' Rock Rock + test' Rock Paper + test' Rock Scissors + test' Paper Rock + test' Paper Paper + test' Paper Scissors + test' Scissors Rock + test' Scissors Paper + test' Scissors Scissors + +test' :: GameChoice -> GameChoice -> IO () +test' c1 c2 = runEmulatorTraceIO' def emCfg $ myTrace c1 c2 + where + emCfg :: EmulatorConfig + emCfg = EmulatorConfig $ Left $ Map.fromList + [ (Wallet 1, v <> assetClassValue (AssetClass (gameTokenCurrency, gameTokenName)) 1) + , (Wallet 2, v) + ] + + v :: Value + v = Ada.lovelaceValueOf 1000_000_000 + +gameTokenCurrency :: CurrencySymbol +gameTokenCurrency = "ff" + +gameTokenName :: TokenName +gameTokenName = "STATE TOKEN" + +myTrace :: GameChoice -> GameChoice -> EmulatorTrace () +myTrace c1 c2 = do + Extras.logInfo $ "first move: " ++ show c1 ++ ", second move: " ++ show c2 + + h1 <- activateContractWallet (Wallet 1) endpoints + h2 <- activateContractWallet (Wallet 2) endpoints + + let pkh1 = pubKeyHash $ walletPubKey $ Wallet 1 + pkh2 = pubKeyHash $ walletPubKey $ Wallet 2 + + fp = FirstParams + { fpSecond = pkh2 + , fpStake = 5000000 + , fpPlayDeadline = 5 + , fpRevealDeadline = 10 + , fpNonce = "SECRETNONCE" + , fpCurrency = gameTokenCurrency + , fpTokenName = gameTokenName + , fpChoice = c1 + } + sp = SecondParams + { spFirst = pkh1 + , spStake = 5000000 + , spPlayDeadline = 5 + , spRevealDeadline = 10 + , spCurrency = gameTokenCurrency + , spTokenName = gameTokenName + , spChoice = c2 + } + + callEndpoint @"first" h1 fp + + void $ Emulator.waitNSlots 3 + + callEndpoint @"second" h2 sp + + void $ Emulator.waitNSlots 10