first complete implementation

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

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

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
+    test' Zero Zero
-    runEmulatorTraceIO $ myTrace Zero One
+    test' Zero One
-    runEmulatorTraceIO $ myTrace One Zero
+    test' One Zero
-    runEmulatorTraceIO $ myTrace One One
+    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
                 }
 

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