mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-21 22:32:00 +01:00
first complete implementation
This commit is contained in:
Lars Brünjes
parent
c9854d6a21
commit
a4f2ba21ea
4 changed files with 397 additions and 5 deletions
|
|
@ -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
|
||||
|
|
|
|||
273
code/week07/src/Week07/StateMachine.hs
Normal file
273
code/week07/src/Week07/StateMachine.hs
Normal 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
|
||||
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
|
|||
91
code/week07/src/Week07/TestStateMachine.hs
Normal file
91
code/week07/src/Week07/TestStateMachine.hs
Normal 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
|
||||
Loading…
Reference in a new issue