Skip to main content

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