first complete implementation

This commit is contained in:
Lars Brünjes 2021-05-19 00:28:36 +02:00
parent c9854d6a21
commit a4f2ba21ea
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
4 changed files with 397 additions and 5 deletions

View file

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

View file

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

View file

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

View file

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