Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
6 changed files
with
498 additions
and
6 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,162 @@ | ||
| {-# LANGUAGE AllowAmbiguousTypes #-} | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
| {-# LANGUAGE KindSignatures #-} | ||
| {-# LANGUAGE MonoLocalBinds #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE PartialTypeSignatures #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
| {-# LANGUAGE TypeFamilies #-} | ||
| {-# LANGUAGE TypeOperators #-} | ||
| {-# LANGUAGE TypeSynonymInstances #-} | ||
| {-# LANGUAGE ViewPatterns #-} | ||
| {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} | ||
| -- | A guessing game | ||
| module Plutus.Contracts.Game | ||
| ( lock | ||
| , guess | ||
| , game | ||
| , GameSchema | ||
| , GuessParams(..) | ||
| , LockParams(..) | ||
| -- * Scripts | ||
| , gameValidator | ||
| , hashString | ||
| , clearString | ||
| -- * Address | ||
| , gameAddress | ||
| , validateGuess | ||
| -- * Traces | ||
| , guessTrace | ||
| , guessWrongTrace | ||
| , lockTrace | ||
| ) where | ||
|
|
||
| import Control.Monad (void) | ||
| import Data.Aeson (FromJSON, ToJSON) | ||
| import GHC.Generics (Generic) | ||
| import Ledger (Address, Validator, ValidatorCtx, Value) | ||
| import qualified Ledger.Constraints as Constraints | ||
| import qualified Ledger.Typed.Scripts as Scripts | ||
| import Plutus.Contract | ||
| import Plutus.Contract.Schema () | ||
| import Plutus.Trace.Emulator (EmulatorTrace) | ||
| import qualified Plutus.Trace.Emulator as Trace | ||
| import qualified PlutusTx | ||
| import PlutusTx.Prelude | ||
| import Schema (ToArgument, ToSchema) | ||
| import Wallet.Emulator (Wallet (..)) | ||
|
|
||
| import qualified Ledger | ||
| import qualified Ledger.Ada as Ada | ||
|
|
||
| import qualified Data.ByteString.Char8 as C | ||
| import qualified Prelude | ||
|
|
||
| newtype HashedString = HashedString ByteString deriving newtype PlutusTx.IsData | ||
|
|
||
| PlutusTx.makeLift ''HashedString | ||
|
|
||
| newtype ClearString = ClearString ByteString deriving newtype PlutusTx.IsData | ||
|
|
||
| PlutusTx.makeLift ''ClearString | ||
|
|
||
| type GameSchema = | ||
| BlockchainActions | ||
| .\/ Endpoint "lock" LockParams | ||
| .\/ Endpoint "guess" GuessParams | ||
|
|
||
| -- | The validation function (DataValue -> RedeemerValue -> ValidatorCtx -> Bool) | ||
| validateGuess :: HashedString -> ClearString -> ValidatorCtx -> Bool | ||
| validateGuess (HashedString actual) (ClearString guess') _ = actual == sha2_256 guess' | ||
|
|
||
| -- | The validator script of the game. | ||
| gameValidator :: Validator | ||
| gameValidator = Scripts.validatorScript gameInstance | ||
|
|
||
| data Game | ||
| instance Scripts.ScriptType Game where | ||
| type instance RedeemerType Game = ClearString | ||
| type instance DatumType Game = HashedString | ||
|
|
||
| gameInstance :: Scripts.ScriptInstance Game | ||
| gameInstance = Scripts.validator @Game | ||
| $$(PlutusTx.compile [|| validateGuess ||]) | ||
| $$(PlutusTx.compile [|| wrap ||]) where | ||
| wrap = Scripts.wrapValidator @HashedString @ClearString | ||
|
|
||
| -- create a data script for the guessing game by hashing the string | ||
| -- and lifting the hash to its on-chain representation | ||
| hashString :: String -> HashedString | ||
| hashString = HashedString . sha2_256 . C.pack | ||
|
|
||
| -- create a redeemer script for the guessing game by lifting the | ||
| -- string to its on-chain representation | ||
| clearString :: String -> ClearString | ||
| clearString = ClearString . C.pack | ||
|
|
||
| -- | The address of the game (the hash of its validator script) | ||
| gameAddress :: Address | ||
| gameAddress = Ledger.scriptAddress gameValidator | ||
|
|
||
| -- | Parameters for the "lock" endpoint | ||
| data LockParams = LockParams | ||
| { secretWord :: String | ||
| , amount :: Value | ||
| } | ||
| deriving stock (Prelude.Eq, Prelude.Show, Generic) | ||
| deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument) | ||
|
|
||
| -- | Parameters for the "guess" endpoint | ||
| newtype GuessParams = GuessParams | ||
| { guessWord :: String | ||
| } | ||
| deriving stock (Prelude.Eq, Prelude.Show, Generic) | ||
| deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument) | ||
|
|
||
| lock :: AsContractError e => Contract () GameSchema e () | ||
| lock = do | ||
| LockParams secret amt <- endpoint @"lock" @LockParams | ||
| let tx = Constraints.mustPayToTheScript (hashString secret) amt | ||
| void (submitTxConstraints gameInstance tx) | ||
|
|
||
| guess :: AsContractError e => Contract () GameSchema e () | ||
| guess = do | ||
| GuessParams theGuess <- endpoint @"guess" @GuessParams | ||
| unspentOutputs <- utxoAt gameAddress | ||
| let redeemer = clearString theGuess | ||
| tx = collectFromScript unspentOutputs redeemer | ||
| void (submitTxConstraintsSpending gameInstance unspentOutputs tx) | ||
|
|
||
| game :: AsContractError e => Contract () GameSchema e () | ||
| game = lock `select` guess | ||
|
|
||
| lockTrace :: EmulatorTrace () | ||
| lockTrace = do | ||
| let w1 = Wallet 1 | ||
| hdl <- Trace.activateContractWallet w1 (game @ContractError) | ||
| Trace.callEndpoint @"lock" hdl (LockParams "secret" (Ada.lovelaceValueOf 10)) | ||
| void $ Trace.waitNSlots 1 | ||
|
|
||
| guessTrace :: EmulatorTrace () | ||
| guessTrace = do | ||
| lockTrace | ||
| let w2 = Wallet 2 | ||
| hdl <- Trace.activateContractWallet w2 (game @ContractError) | ||
| Trace.callEndpoint @"guess" hdl (GuessParams "secret") | ||
|
|
||
| guessWrongTrace :: EmulatorTrace () | ||
| guessWrongTrace = do | ||
| lockTrace | ||
| let w2 = Wallet 2 | ||
| hdl <- Trace.activateContractWallet w2 (game @ContractError) | ||
| Trace.callEndpoint @"guess" hdl (GuessParams "SECRET") |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,21 @@ | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| module Main(main) where | ||
|
|
||
| import qualified Spec.Game | ||
| import Test.Tasty | ||
| import Test.Tasty.Hedgehog (HedgehogTestLimit (..)) | ||
|
|
||
| main :: IO () | ||
| main = defaultMain tests | ||
|
|
||
| -- | Number of successful tests for each hedgehog property. | ||
| -- The default is 100 but we use a smaller number here in order to speed up | ||
| -- the test suite. | ||
| -- | ||
| limit :: HedgehogTestLimit | ||
| limit = HedgehogTestLimit (Just 5) | ||
|
|
||
| tests :: TestTree | ||
| tests = localOption limit $ testGroup "use cases" [ | ||
| Spec.Game.tests | ||
| ] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,60 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| module Spec.Game | ||
| ( tests | ||
| ) where | ||
|
|
||
| import Control.Monad (void) | ||
| import Ledger.Ada (adaValueOf) | ||
| import Plutus.Contract (Contract, ContractError) | ||
| import Plutus.Contract.Test | ||
| import Plutus.Contracts.Game | ||
| import Plutus.Trace.Emulator (ContractInstanceTag) | ||
| import qualified Plutus.Trace.Emulator as Trace | ||
| import qualified PlutusTx | ||
| import qualified PlutusTx.Prelude as PlutusTx | ||
| import Test.Tasty | ||
| import qualified Test.Tasty.HUnit as HUnit | ||
|
|
||
| w1, w2 :: Wallet | ||
| w1 = Wallet 1 | ||
| w2 = Wallet 2 | ||
|
|
||
| t1, t2 :: ContractInstanceTag | ||
| t1 = Trace.walletInstanceTag w1 | ||
| t2 = Trace.walletInstanceTag w2 | ||
|
|
||
| theContract :: Contract () GameSchema ContractError () | ||
| theContract = game | ||
|
|
||
| tests :: TestTree | ||
| tests = testGroup "game" | ||
| [ checkPredicate "Expose 'lock' and 'guess' endpoints" | ||
| (endpointAvailable @"lock" theContract (Trace.walletInstanceTag w1) | ||
| .&&. endpointAvailable @"guess" theContract (Trace.walletInstanceTag w1)) | ||
| $ void (Trace.activateContractWallet w1 theContract) | ||
|
|
||
| , checkPredicate "'lock' endpoint submits a transaction" | ||
| (anyTx theContract (Trace.walletInstanceTag w1)) | ||
| $ do | ||
| hdl <- Trace.activateContractWallet w1 theContract | ||
| Trace.callEndpoint @"lock" hdl (LockParams "secret" (adaValueOf 10)) | ||
|
|
||
| , checkPredicate "'guess' endpoint is available after locking funds" | ||
| (endpointAvailable @"guess" theContract (Trace.walletInstanceTag w2)) | ||
| lockTrace | ||
|
|
||
| , checkPredicate "guess right (unlock funds)" | ||
| (walletFundsChange w2 (1 `timesFeeAdjust` 10) | ||
| .&&. walletFundsChange w1 (1 `timesFeeAdjust` (-10))) | ||
| guessTrace | ||
|
|
||
| , checkPredicate "guess wrong" | ||
| (walletFundsChange w2 PlutusTx.zero | ||
| .&&. walletFundsChange w1 (1 `timesFeeAdjust` (-10))) | ||
| guessWrongTrace | ||
| , goldenPir "examples/test/Spec/game.pir" $$(PlutusTx.compile [|| validateGuess ||]) | ||
| , HUnit.testCase "script size is reasonable" (reasonable gameValidator 20000) | ||
| ] |
Oops, something went wrong.