diff --git a/code/week07/plutus-pioneer-program-week07.cabal b/code/week07/plutus-pioneer-program-week07.cabal index 5b9f027..3f9d784 100644 --- a/code/week07/plutus-pioneer-program-week07.cabal +++ b/code/week07/plutus-pioneer-program-week07.cabal @@ -11,7 +11,9 @@ License-files: LICENSE library hs-source-dirs: src exposed-modules: Week07.EvenOdd + , Week07.StateMachine , Week07.Test + , Week07.TestStateMachine build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week07/src/Week07/StateMachine.hs b/code/week07/src/Week07/StateMachine.hs new file mode 100644 index 0000000..f878911 --- /dev/null +++ b/code/week07/src/Week07/StateMachine.hs @@ -0,0 +1,273 @@ +{-# 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.StateMachine + ( 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 = 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 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 | 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 _), Reveal _) + | lovelaces v == (2 * gStake game) -> Just ( Constraints.mustBeSignedBy (gFirst game) <> + Constraints.mustValidateIn (to $ gRevealDeadline game) <> + Constraints.mustPayToPubKey (gFirst game) token + , 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 -> GameDatum -> GameRedeemer -> ScriptContext -> Bool +check bsZero' bsOne' (GameDatum bs (Just c)) (Reveal nonce) _ = + sha2_256 (nonce `concatenate` if c == Zero then bsZero' else bsOne') == bs +check _ _ _ _ _ = True + +{-# INLINABLE gameStateMachine #-} +gameStateMachine :: Game -> ByteString -> ByteString -> StateMachine GameDatum GameRedeemer +gameStateMachine game bsZero' bsOne' = StateMachine + { smTransition = transition game + , smFinal = final + , smCheck = check bsZero' bsOne' + , smThreadToken = Just $ gToken game + } + +{-# INLINABLE mkGameValidator #-} +mkGameValidator :: Game -> ByteString -> ByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool +mkGameValidator game bsZero' bsOne' = mkValidator $ gameStateMachine game bsZero' bsOne' + +type Gaming = StateMachine GameDatum GameRedeemer + +bsZero, bsOne :: ByteString +bsZero = "0" +bsOne = "1" + +gameStateMachine' :: Game -> StateMachine GameDatum GameRedeemer +gameStateMachine' game = gameStateMachine game bsZero bsOne + +gameInst :: Game -> Scripts.ScriptInstance Gaming +gameInst game = Scripts.validator @Gaming + ($$(PlutusTx.compile [|| mkGameValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode game + `PlutusTx.applyCode` PlutusTx.liftCode bsZero + `PlutusTx.applyCode` PlutusTx.liftCode bsOne) + $$(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 + bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne + void $ mapError @w @s @SMContractError (pack . show) $ 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' == c -> do + logInfo @String "second player played and lost" + void $ mapError' $ runStep client $ Reveal $ fpNonce fp + logInfo @String "first player revealed and won" + + _ -> 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" + 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/Test.hs b/code/week07/src/Week07/Test.hs index 54eebd0..199a013 100644 --- a/code/week07/src/Week07/Test.hs +++ b/code/week07/src/Week07/Test.hs @@ -16,19 +16,41 @@ module Week07.Test 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 hiding (Semigroup(..), unless) +import PlutusTx.Prelude import Wallet.Emulator.Wallet import Week07.EvenOdd test :: IO () test = do - runEmulatorTraceIO $ myTrace Zero Zero - runEmulatorTraceIO $ myTrace Zero One - runEmulatorTraceIO $ myTrace One Zero - runEmulatorTraceIO $ myTrace One One + test' Zero Zero + test' Zero One + test' One Zero + test' One One + +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 @@ -46,6 +68,8 @@ myTrace c1 c2 = do , fpPlayDeadline = 5 , fpRevealDeadline = 10 , fpNonce = "SECRETNONCE" + , fpCurrency = gameTokenCurrency + , fpTokenName = gameTokenName , fpChoice = c1 } sp = SecondParams @@ -53,6 +77,8 @@ myTrace c1 c2 = do , spStake = 5000000 , spPlayDeadline = 5 , spRevealDeadline = 10 + , spCurrency = gameTokenCurrency + , spTokenName = gameTokenName , spChoice = c2 } diff --git a/code/week07/src/Week07/TestStateMachine.hs b/code/week07/src/Week07/TestStateMachine.hs new file mode 100644 index 0000000..fb3b10c --- /dev/null +++ b/code/week07/src/Week07/TestStateMachine.hs @@ -0,0 +1,91 @@ +{-# 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.Test 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.StateMachine + +test :: IO () +test = do + test' Zero Zero + test' Zero One + test' One Zero + test' One One + +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