Mã code mẫu - Plutus
Thông tin thêm
- Dưới đây là các ví dụ mẫu cho các Bài giảng trong chương trình Plutus Pioneer Program, lần thứ 3
- Chỉ sử dụng các code này cho mục đích học tập
English Auction
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week01.EnglishAuction
( Auction (..)
, StartParams (..), BidParams (..), CloseParams (..)
, AuctionSchema
, start, bid, close
, endpoints
, schemas
, ensureKnownCurrencies
, printJson
, printSchemas
, registeredKnownCurrencies
, stage
) where
import Control.Monad hiding (fmap)
import Data.Aeson (ToJSON, FromJSON)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map as Map
import Data.Text (pack, Text)
import GHC.Generics (Generic)
import Ledger hiding (singleton)
import qualified Ledger.Constraints as Constraints
import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Value as Value
import Ledger.Ada as Ada
import Playground.Contract (IO, ensureKnownCurrencies, printSchemas, stage, printJson)
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Plutus.Contract
import qualified PlutusTx
import PlutusTx.Prelude hiding (unless)
import qualified Prelude as P
import Schema (ToSchema)
import Text.Printf (printf)
minLovelace :: Integer
minLovelace = 2000000
data Auction = Auction
{ aSeller :: !PaymentPubKeyHash
, aDeadline :: !POSIXTime
, aMinBid :: !Integer
, aCurrency :: !CurrencySymbol
, aToken :: !TokenName
} deriving (P.Show, Generic, ToJSON, FromJSON, ToSchema)
instance Eq Auction where
{-# INLINABLE (==) #-}
a == b = (aSeller a == aSeller b) &&
(aDeadline a == aDeadline b) &&
(aMinBid a == aMinBid b) &&
(aCurrency a == aCurrency b) &&
(aToken a == aToken b)
PlutusTx.unstableMakeIsData ''Auction
PlutusTx.makeLift ''Auction
data Bid = Bid
{ bBidder :: !PaymentPubKeyHash
, bBid :: !Integer
} deriving P.Show
instance Eq Bid where
{-# INLINABLE (==) #-}
b == c = (bBidder b == bBidder c) &&
(bBid b == bBid c)
PlutusTx.unstableMakeIsData ''Bid
PlutusTx.makeLift ''Bid
data AuctionAction = MkBid Bid | Close
deriving P.Show
PlutusTx.unstableMakeIsData ''AuctionAction
PlutusTx.makeLift ''AuctionAction
data AuctionDatum = AuctionDatum
{ adAuction :: !Auction
, adHighestBid :: !(Maybe Bid)
} deriving P.Show
PlutusTx.unstableMakeIsData ''AuctionDatum
PlutusTx.makeLift ''AuctionDatum
data Auctioning
instance Scripts.ValidatorTypes Auctioning where
type instance RedeemerType Auctioning = AuctionAction
type instance DatumType Auctioning = AuctionDatum
{-# INLINABLE minBid #-}
minBid :: AuctionDatum -> Integer
minBid AuctionDatum{..} = case adHighestBid of
Nothing -> aMinBid adAuction
Just Bid{..} -> bBid + 1
{-# INLINABLE mkAuctionValidator #-}
mkAuctionValidator :: AuctionDatum -> AuctionAction -> ScriptContext -> Bool
mkAuctionValidator ad redeemer ctx =
traceIfFalse "wrong input value" correctInputValue &&
case redeemer of
MkBid b@Bid{..} ->
traceIfFalse "bid too low" (sufficientBid bBid) &&
traceIfFalse "wrong output datum" (correctBidOutputDatum b) &&
traceIfFalse "wrong output value" (correctBidOutputValue bBid) &&
traceIfFalse "wrong refund" correctBidRefund &&
traceIfFalse "too late" correctBidSlotRange
Close ->
traceIfFalse "too early" correctCloseSlotRange &&
case adHighestBid ad of
Nothing ->
traceIfFalse "expected seller to get token" (getsValue (aSeller auction) $ tokenValue <> Ada.lovelaceValueOf minLovelace)
Just Bid{..} ->
traceIfFalse "expected highest bidder to get token" (getsValue bBidder $ tokenValue <> Ada.lovelaceValueOf minLovelace) &&
traceIfFalse "expected seller to get highest bid" (getsValue (aSeller auction) $ Ada.lovelaceValueOf bBid)
where
info :: TxInfo
info = scriptContextTxInfo ctx
input :: TxInInfo
input =
let
isScriptInput i = case (txOutDatumHash . txInInfoResolved) i of
Nothing -> False
Just _ -> True
xs = [i | i <- txInfoInputs info, isScriptInput i]
in
case xs of
[i] -> i
_ -> traceError "expected exactly one script input"
inVal :: Value
inVal = txOutValue . txInInfoResolved $ input
auction :: Auction
auction = adAuction ad
tokenValue :: Value
tokenValue = Value.singleton (aCurrency auction) (aToken auction) 1
correctInputValue :: Bool
correctInputValue = inVal == case adHighestBid ad of
Nothing -> tokenValue <> Ada.lovelaceValueOf minLovelace
Just Bid{..} -> tokenValue <> Ada.lovelaceValueOf (minLovelace + bBid)
sufficientBid :: Integer -> Bool
sufficientBid amount = amount >= minBid ad
ownOutput :: TxOut
outputDatum :: AuctionDatum
(ownOutput, outputDatum) = case getContinuingOutputs ctx of
[o] -> case txOutDatumHash o of
Nothing -> traceError "wrong output type"
Just h -> case findDatum h info of
Nothing -> traceError "datum not found"
Just (Datum d) -> case PlutusTx.fromBuiltinData d of
Just ad' -> (o, ad')
Nothing -> traceError "error decoding data"
_ -> traceError "expected exactly one continuing output"
correctBidOutputDatum :: Bid -> Bool
correctBidOutputDatum b = (adAuction outputDatum == auction) &&
(adHighestBid outputDatum == Just b)
correctBidOutputValue :: Integer -> Bool
correctBidOutputValue amount =
txOutValue ownOutput == tokenValue <> Ada.lovelaceValueOf (minLovelace + amount)
correctBidRefund :: Bool
correctBidRefund = case adHighestBid ad of
Nothing -> True
Just Bid{..} ->
let
os = [ o
| o <- txInfoOutputs info
, txOutAddress o == pubKeyHashAddress bBidder Nothing
]
in
case os of
[o] -> txOutValue o == Ada.lovelaceValueOf bBid
_ -> traceError "expected exactly one refund output"
correctBidSlotRange :: Bool
correctBidSlotRange = to (aDeadline auction) `contains` txInfoValidRange info
correctCloseSlotRange :: Bool
correctCloseSlotRange = from (aDeadline auction) `contains` txInfoValidRange info
getsValue :: PaymentPubKeyHash -> Value -> Bool
getsValue h v =
let
[o] = [ o'
| o' <- txInfoOutputs info
, txOutValue o' == v
]
in
txOutAddress o == pubKeyHashAddress h Nothing
typedAuctionValidator :: Scripts.TypedValidator Auctioning
typedAuctionValidator = Scripts.mkTypedValidator @Auctioning
$$(PlutusTx.compile [|| mkAuctionValidator ||])
$$(PlutusTx.compile [|| wrap ||])
where
wrap = Scripts.wrapValidator @AuctionDatum @AuctionAction
auctionValidator :: Validator
auctionValidator = Scripts.validatorScript typedAuctionValidator
auctionHash :: Ledger.ValidatorHash
auctionHash = Scripts.validatorHash typedAuctionValidator
auctionAddress :: Ledger.Address
auctionAddress = scriptHashAddress auctionHash
data StartParams = StartParams
{ spDeadline :: !POSIXTime
, spMinBid :: !Integer
, spCurrency :: !CurrencySymbol
, spToken :: !TokenName
} deriving (Generic, ToJSON, FromJSON, ToSchema)
data BidParams = BidParams
{ bpCurrency :: !CurrencySymbol
, bpToken :: !TokenName
, bpBid :: !Integer
} deriving (Generic, ToJSON, FromJSON, ToSchema)
data CloseParams = CloseParams
{ cpCurrency :: !CurrencySymbol
, cpToken :: !TokenName
} deriving (Generic, ToJSON, FromJSON, ToSchema)
type AuctionSchema =
Endpoint "start" StartParams
.\/ Endpoint "bid" BidParams
.\/ Endpoint "close" CloseParams
start :: AsContractError e => StartParams -> Contract w s e ()
start StartParams{..} = do
pkh <- ownPaymentPubKeyHash
let a = Auction
{ aSeller = pkh
, aDeadline = spDeadline
, aMinBid = spMinBid
, aCurrency = spCurrency
, aToken = spToken
}
d = AuctionDatum
{ adAuction = a
, adHighestBid = Nothing
}
v = Value.singleton spCurrency spToken 1 <> Ada.lovelaceValueOf minLovelace
tx = Constraints.mustPayToTheScript d v
ledgerTx <- submitTxConstraints typedAuctionValidator tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @P.String $ printf "started auction %s for token %s" (P.show a) (P.show v)
bid :: forall w s. BidParams -> Contract w s Text ()
bid BidParams{..} = do
(oref, o, d@AuctionDatum{..}) <- findAuction bpCurrency bpToken
logInfo @P.String $ printf "found auction utxo with datum %s" (P.show d)
when (bpBid < minBid d) $
throwError $ pack $ printf "bid lower than minimal bid %d" (minBid d)
pkh <- ownPaymentPubKeyHash
let b = Bid {bBidder = pkh, bBid = bpBid}
d' = d {adHighestBid = Just b}
v = Value.singleton bpCurrency bpToken 1 <> Ada.lovelaceValueOf (minLovelace + bpBid)
r = Redeemer $ PlutusTx.toBuiltinData $ MkBid b
lookups = Constraints.typedValidatorLookups typedAuctionValidator P.<>
Constraints.otherScript auctionValidator P.<>
Constraints.unspentOutputs (Map.singleton oref o)
tx = case adHighestBid of
Nothing -> Constraints.mustPayToTheScript d' v <>
Constraints.mustValidateIn (to $ aDeadline adAuction) <>
Constraints.mustSpendScriptOutput oref r
Just Bid{..} -> Constraints.mustPayToTheScript d' v <>
Constraints.mustPayToPubKey bBidder (Ada.lovelaceValueOf bBid) <>
Constraints.mustValidateIn (to $ aDeadline adAuction) <>
Constraints.mustSpendScriptOutput oref r
ledgerTx <- submitTxConstraintsWith lookups tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @P.String $ printf "made bid of %d lovelace in auction %s for token (%s, %s)"
bpBid
(P.show adAuction)
(P.show bpCurrency)
(P.show bpToken)
close :: forall w s. CloseParams -> Contract w s Text ()
close CloseParams{..} = do
(oref, o, d@AuctionDatum{..}) <- findAuction cpCurrency cpToken
logInfo @P.String $ printf "found auction utxo with datum %s" (P.show d)
let t = Value.singleton cpCurrency cpToken 1
r = Redeemer $ PlutusTx.toBuiltinData Close
seller = aSeller adAuction
lookups = Constraints.typedValidatorLookups typedAuctionValidator P.<>
Constraints.otherScript auctionValidator P.<>
Constraints.unspentOutputs (Map.singleton oref o)
tx = case adHighestBid of
Nothing -> Constraints.mustPayToPubKey seller (t <> Ada.lovelaceValueOf minLovelace) <>
Constraints.mustValidateIn (from $ aDeadline adAuction) <>
Constraints.mustSpendScriptOutput oref r
Just Bid{..} -> Constraints.mustPayToPubKey bBidder (t <> Ada.lovelaceValueOf minLovelace) <>
Constraints.mustPayToPubKey seller (Ada.lovelaceValueOf bBid) <>
Constraints.mustValidateIn (from $ aDeadline adAuction) <>
Constraints.mustSpendScriptOutput oref r
ledgerTx <- submitTxConstraintsWith lookups tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @P.String $ printf "closed auction %s for token (%s, %s)"
(P.show adAuction)
(P.show cpCurrency)
(P.show cpToken)
findAuction :: CurrencySymbol
-> TokenName
-> Contract w s Text (TxOutRef, ChainIndexTxOut, AuctionDatum)
findAuction cs tn = do
utxos <- utxosAt $ scriptHashAddress auctionHash
let xs = [ (oref, o)
| (oref, o) <- Map.toList utxos
, Value.valueOf (_ciTxOutValue o) cs tn == 1
]
case xs of
[(oref, o)] -> case _ciTxOutDatum o of
Left _ -> throwError "datum missing"
Right (Datum e) -> case PlutusTx.fromBuiltinData e of
Nothing -> throwError "datum has wrong type"
Just d@AuctionDatum{..}
| aCurrency adAuction == cs && aToken adAuction == tn -> return (oref, o, d)
| otherwise -> throwError "auction token missmatch"
_ -> throwError "auction utxo not found"
endpoints :: Contract () AuctionSchema Text ()
endpoints = awaitPromise (start' `select` bid' `select` close') >> endpoints
where
start' = endpoint @"start" start
bid' = endpoint @"bid" bid
close' = endpoint @"close" close
mkSchemaDefinitions ''AuctionSchema
myToken :: KnownCurrency
myToken = KnownCurrency (ValidatorHash "f") "Token" (TokenName "T" :| [])
Simple Validation
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.Burn where
import Control.Monad hiding (fmap)
import Data.Map as Map
import Data.Text (Text)
import Data.Void (Void)
import Plutus.Contract
import PlutusTx (Data (..))
import qualified PlutusTx
import qualified PlutusTx.Builtins as Builtins
import PlutusTx.Prelude hiding (Semigroup(..), unless)
import Ledger hiding (singleton)
import Ledger.Constraints as Constraints
import qualified Ledger.Scripts as Scripts
import Ledger.Ada as Ada
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage)
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Prelude (IO, Semigroup (..), String)
import Text.Printf (printf)
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# INLINABLE mkValidator #-}
mkValidator :: BuiltinData -> BuiltinData -> BuiltinData -> ()
mkValidator _ _ _ = traceError "BURNT!"
validator :: Validator
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
scrAddress :: Ledger.Address
scrAddress = scriptAddress validator
type GiftSchema =
Endpoint "give" Integer
.\/ Endpoint "grab" ()
give :: AsContractError e => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToOtherScript valHash (Datum $ Builtins.mkConstr 0 []) $ Ada.lovelaceValueOf amount
ledgerTx <- submitTx tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. AsContractError e => Contract w s e ()
grab = do
utxos <- utxosAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ Builtins.mkI 17 | oref <- orefs]
ledgerTx <- submitTxConstraintsWith @Void lookups tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @String $ "collected gifts"
endpoints :: Contract () GiftSchema Text ()
endpoints = awaitPromise (give' `select` grab') >> endpoints
where
give' = endpoint @"give" give
grab' = endpoint @"grab" $ const grab
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []
StateMachine.hs
{-# 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
, Last (..)
, ThreadToken
, Text
, endpoints
) where
import Control.Monad hiding (fmap)
import Data.Aeson (FromJSON, ToJSON)
import Data.Monoid (Last (..))
import Data.Text (Text, pack)
import GHC.Generics (Generic)
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 Plutus.Contract as Contract
import Plutus.Contract.StateMachine
import qualified PlutusTx
import PlutusTx.Prelude hiding (Semigroup(..), check, unless)
import Playground.Contract (ToSchema)
import Prelude (Semigroup (..), Show (..), String)
import qualified Prelude
data Game = Game
{ gFirst :: !PaymentPubKeyHash
, gSecond :: !PaymentPubKeyHash
, gStake :: !Integer
, gPlayDeadline :: !POSIXTime
, gRevealDeadline :: !POSIXTime
, gToken :: !ThreadToken
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq)
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 BuiltinByteString (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 BuiltinByteString | 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.fromBuiltinData 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)
, State Finished mempty
)
(v, GameDatum _ Nothing, ClaimFirst)
| lovelaces v == gStake game -> Just ( Constraints.mustBeSignedBy (gFirst game) <>
Constraints.mustValidateIn (from $ 1 + gPlayDeadline game)
, State Finished mempty
)
(v, GameDatum _ (Just _), ClaimSecond)
| lovelaces v == (2 * gStake game) -> Just ( Constraints.mustBeSignedBy (gSecond game) <>
Constraints.mustValidateIn (from $ 1 + gRevealDeadline game)
, State Finished mempty
)
_ -> Nothing
{-# INLINABLE final #-}
final :: GameDatum -> Bool
final Finished = True
final _ = False
{-# INLINABLE check #-}
check :: BuiltinByteString -> BuiltinByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool
check bsZero' bsOne' (GameDatum bs (Just c)) (Reveal nonce) _ =
sha2_256 (nonce `appendByteString` if c == Zero then bsZero' else bsOne') == bs
check _ _ _ _ _ = True
{-# INLINABLE gameStateMachine #-}
gameStateMachine :: Game -> BuiltinByteString -> BuiltinByteString -> 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 -> BuiltinByteString -> BuiltinByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool
mkGameValidator game bsZero' bsOne' = mkValidator $ gameStateMachine game bsZero' bsOne'
type Gaming = StateMachine GameDatum GameRedeemer
bsZero, bsOne :: BuiltinByteString
bsZero = "0"
bsOne = "1"
gameStateMachine' :: Game -> StateMachine GameDatum GameRedeemer
gameStateMachine' game = gameStateMachine game bsZero bsOne
typedGameValidator :: Game -> Scripts.TypedValidator Gaming
typedGameValidator game = Scripts.mkTypedValidator @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 . typedGameValidator
gameAddress :: Game -> Ledger.Address
gameAddress = scriptAddress . gameValidator
gameClient :: Game -> StateMachineClient GameDatum GameRedeemer
gameClient game = mkStateMachineClient $ StateMachineInstance (gameStateMachine' game) (typedGameValidator game)
data FirstParams = FirstParams
{ fpSecond :: !PaymentPubKeyHash
, fpStake :: !Integer
, fpPlayDeadline :: !POSIXTime
, fpRevealDeadline :: !POSIXTime
, fpNonce :: !BuiltinByteString
, fpChoice :: !GameChoice
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
mapError' :: Contract w s SMContractError a -> Contract w s Text a
mapError' = mapError $ pack . show
waitUntilTimeHasPassed :: AsContractError e => POSIXTime -> Contract w s e ()
waitUntilTimeHasPassed t = void $ awaitTime t >> waitNSlots 1
firstGame :: forall s. FirstParams -> Contract (Last ThreadToken) s Text ()
firstGame fp = do
pkh <- Contract.ownPaymentPubKeyHash
tt <- mapError' getThreadToken
let game = Game
{ gFirst = pkh
, gSecond = fpSecond fp
, gStake = fpStake fp
, gPlayDeadline = fpPlayDeadline fp
, gRevealDeadline = fpRevealDeadline fp
, gToken = tt
}
client = gameClient game
v = lovelaceValueOf (fpStake fp)
c = fpChoice fp
bs = sha2_256 $ fpNonce fp `appendByteString` if c == Zero then bsZero else bsOne
void $ mapError' $ runInitialise client (GameDatum bs Nothing) v
logInfo @String $ "made first move: " ++ show (fpChoice fp)
tell $ Last $ Just tt
waitUntilTimeHasPassed $ fpPlayDeadline fp
m <- mapError' $ getOnChainState client
case m of
Nothing -> throwError "game output not found"
Just (o, _) -> case tyTxOutData $ ocsTxOut 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 :: !PaymentPubKeyHash
, spStake :: !Integer
, spPlayDeadline :: !POSIXTime
, spRevealDeadline :: !POSIXTime
, spChoice :: !GameChoice
, spToken :: !ThreadToken
} deriving (Show, Generic, FromJSON, ToJSON)
secondGame :: forall w s. SecondParams -> Contract w s Text ()
secondGame sp = do
pkh <- Contract.ownPaymentPubKeyHash
let game = Game
{ gFirst = spFirst sp
, gSecond = pkh
, gStake = spStake sp
, gPlayDeadline = spPlayDeadline sp
, gRevealDeadline = spRevealDeadline sp
, gToken = spToken sp
}
client = gameClient game
m <- mapError' $ getOnChainState client
case m of
Nothing -> logInfo @String "no running game found"
Just (o, _) -> case tyTxOutData $ ocsTxOut 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)
waitUntilTimeHasPassed $ 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 = Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams
endpoints :: Contract (Last ThreadToken) GameSchema Text ()
endpoints = awaitPromise (first `select` second) >> endpoints
where
first = endpoint @"first" firstGame
second = endpoint @"second" secondGame
Staking
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week10.Staking
( stakeValidator
) where
import Ledger
import Ledger.Typed.Scripts as Scripts
import Plutus.V1.Ledger.Ada (Ada (..), fromValue)
import Plutus.V1.Ledger.Credential (StakingCredential)
import qualified PlutusTx
import PlutusTx.Prelude
{-# INLINABLE mkStakingValidator #-}
mkStakingValidator :: Address -> () -> ScriptContext -> Bool
mkStakingValidator addr () ctx = case scriptContextPurpose ctx of
Certifying _ -> True
Rewarding cred -> traceIfFalse "insufficient reward sharing" $ 2 * paidToAddress >= amount cred
_ -> False
where
info :: TxInfo
info = scriptContextTxInfo ctx
amount :: StakingCredential -> Integer
amount cred = go $ txInfoWdrl info
where
go :: [(StakingCredential, Integer)] -> Integer
go [] = traceError "withdrawal not found"
go ((cred', amt) : xs)
| cred' == cred = amt
| otherwise = go xs
paidToAddress :: Integer
paidToAddress = foldl f 0 $ txInfoOutputs info
where
f :: Integer -> TxOut -> Integer
f n o
| txOutAddress o == addr = n + getLovelace (fromValue $ txOutValue o)
| otherwise = n
stakeValidator :: Address -> StakeValidator
stakeValidator addr = mkStakeValidatorScript $
$$(PlutusTx.compile [|| wrapStakeValidator . mkStakingValidator ||])
`PlutusTx.applyCode`
PlutusTx.liftCode addr