SCP-3196: Added a new Game contract (simplified version of GameStateM…

…achine)

* Parameterized the GameStateMachine contract

* Added Game contract which is compatible with remote wallets by using `yieldUnbalancedTx`.

plutus-use-cases/plutus-use-cases.cabal

@@ -35,6 +35,7 @@ library
         Plutus.Contracts.Escrow
         Plutus.Contracts.SimpleEscrow
         Plutus.Contracts.Future
+        Plutus.Contracts.Game
         Plutus.Contracts.GameStateMachine
         Plutus.Contracts.Governance
         Plutus.Contracts.MultiSig
@@ -109,6 +110,7 @@ test-suite plutus-use-cases-test
         Spec.Escrow
         Spec.SimpleEscrow
         Spec.Future
+        Spec.Game
         Spec.GameStateMachine
         Spec.Governance
         Spec.MultiSig
@@ -175,6 +177,7 @@ executable plutus-use-cases-scripts
         Spec.Escrow
         Spec.SimpleEscrow
         Spec.Future
+        Spec.Game
         Spec.GameStateMachine
         Spec.Governance
         Spec.MultiSig

plutus-use-cases/scripts/Main.hs

@@ -1,10 +1,6 @@
-{-# LANGUAGE DeriveAnyClass     #-}
-{-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE NamedFieldPuns     #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies       #-}
 
 module Main(main, ExportTx(..)) where
@@ -21,6 +17,7 @@ import Plutus.Trace (Command (..), ScriptsConfig (..), showStats, writeScriptsTo
 import Spec.Currency qualified as Currency
 import Spec.Escrow qualified as Escrow
 import Spec.Future qualified as Future
+import Spec.Game qualified as Game
 import Spec.GameStateMachine qualified as GameStateMachine
 import Spec.MultiSig qualified as MultiSig
 import Spec.MultiSigStateMachine qualified as MultiSigStateMachine
@@ -102,6 +99,7 @@ writeScripts config = do
         , ("future-increase-margin", Future.increaseMarginTrace, def)
         , ("future-settle-early", Future.settleEarlyTrace, def)
         , ("future-pay-out", Future.payOutTrace, def)
+        , ("game-success", Game.successTrace, def)
         , ("game-sm-success_1", GameStateMachine.successTrace, def)
         , ("game-sm-success_2", GameStateMachine.successTrace2, def)
         , ("multisig-success", MultiSig.succeedingTrace, def)

plutus-use-cases/src/Plutus/Contracts/Game.hs

@@ -0,0 +1,192 @@
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE ViewPatterns               #-}
+
+-- | A guessing game. A simplified version of 'Plutus.Contract.GameStateMachine'
+-- not using 'Plutus.Contract.StateMachine' and using `yieldUnbalancedTx' for
+-- balancing, signing and submitting transactions.
+--
+-- Currently, remote wallets (anything other than WBE) can only handles
+-- `yieldUnbalancedTx` requests, and not `balanceTx`, `signTx` and `submitTx`
+-- requests.
+module Plutus.Contracts.Game
+    ( contract
+    , GameParam(..)
+    , GameSchema
+    , LockArgs(..)
+    , GuessArgs(..)
+    -- * Scripts
+    , gameInstance
+    , mkValidator
+    -- * Address
+    , gameAddress
+    , covIdx
+    ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.ByteString.Char8 qualified as C
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Maybe (catMaybes)
+import GHC.Generics (Generic)
+import Ledger (Address, Datum (Datum), POSIXTime, PaymentPubKeyHash, ScriptContext, TxOutRef, Validator, Value)
+import Ledger qualified
+import Ledger.Ada qualified as Ada
+import Ledger.Constraints qualified as Constraints
+import Ledger.Tx (ChainIndexTxOut (..))
+import Ledger.Typed.Scripts qualified as Scripts
+import Playground.Contract (ToSchema)
+import Plutus.Contract (AsContractError, Contract, Endpoint, Promise, collectFromScript, endpoint, fundsAtAddressGeq,
+                        logInfo, mkTxConstraints, selectList, type (.\/), yieldUnbalancedTx)
+import PlutusTx qualified
+import PlutusTx.Code (getCovIdx)
+import PlutusTx.Coverage (CoverageIndex)
+import PlutusTx.Prelude hiding (pure, (<$>))
+import Prelude qualified as Haskell
+
+-- | Datatype for creating a parameterized validator.
+data GameParam = GameParam
+    { gameParamPayeePkh  :: PaymentPubKeyHash
+    -- ^ Payment public key hash of the wallet locking some funds
+    , gameParamStartTime :: POSIXTime
+    -- ^ Starting time of the game
+    } deriving (Haskell.Show, Generic)
+      deriving anyclass (ToJSON, FromJSON, ToSchema)
+
+PlutusTx.makeLift ''GameParam
+
+newtype HashedString = HashedString BuiltinByteString
+    deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+PlutusTx.makeLift ''HashedString
+
+newtype ClearString = ClearString BuiltinByteString
+    deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+PlutusTx.makeLift ''ClearString
+
+type GameSchema =
+        Endpoint "lock" LockArgs
+        .\/ Endpoint "guess" GuessArgs
+
+data Game
+instance Scripts.ValidatorTypes Game where
+    type instance RedeemerType Game = ClearString
+    type instance DatumType Game = HashedString
+
+-- | The address of the game (the hash of its validator script)
+gameAddress :: GameParam -> Address
+gameAddress = Ledger.scriptAddress . gameValidator
+
+-- | The validator script of the game.
+gameValidator :: GameParam -> Validator
+gameValidator = Scripts.validatorScript . gameInstance
+
+gameInstance :: GameParam -> Scripts.TypedValidator Game
+gameInstance = Scripts.mkTypedValidatorParam @Game
+    $$(PlutusTx.compile [|| mkValidator ||])
+    $$(PlutusTx.compile [|| wrap ||]) where
+        wrap = Scripts.wrapValidator @HashedString @ClearString
+
+-- | The validation function (Datum -> Redeemer -> ScriptContext -> Bool)
+{-# INLINABLE mkValidator #-}
+mkValidator :: GameParam -> HashedString -> ClearString -> ScriptContext -> Bool
+mkValidator _ hs cs _ = isGoodGuess hs cs
+
+{-# INLINABLE isGoodGuess #-}
+isGoodGuess :: HashedString -> ClearString -> Bool
+isGoodGuess (HashedString actual) (ClearString guess') = actual == sha2_256 guess'
+
+-- TODO: Ideas welcome for how to make this interface suck less.
+-- Doing it this way actually generates coverage locations that we don't care about(!)
+covIdx :: GameParam -> CoverageIndex
+covIdx gameParam =
+    getCovIdx ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode gameParam)
+
+-- create a data script for the guessing game by hashing the string
+-- and lifting the hash to its on-chain representation
+hashString :: Haskell.String -> HashedString
+hashString = HashedString . sha2_256 . toBuiltin . C.pack
+
+-- create a redeemer script for the guessing game by lifting the
+-- string to its on-chain representation
+clearString :: Haskell.String -> ClearString
+clearString = ClearString . toBuiltin . C.pack
+
+-- | Arguments for the @"lock"@ endpoint
+data LockArgs =
+    LockArgs
+        { lockArgsGameParam :: GameParam
+        -- ^ The parameters for parameterizing the validator.
+        , lockArgsSecret    :: Haskell.String -- SecretArgument Haskell.String
+        -- ^ The secret
+        , lockArgsValue     :: Value
+        -- ^ Value that is locked by the contract initially
+        } deriving stock (Haskell.Show, Generic)
+          deriving anyclass (ToJSON, FromJSON, ToSchema)
+
+-- | Arguments for the @"guess"@ endpoint
+data GuessArgs =
+    GuessArgs
+        { guessArgsGameParam :: GameParam
+        -- ^ The parameters for parameterizing the validator.
+        , guessArgsSecret    :: Haskell.String
+        -- ^ The guess
+        } deriving stock (Haskell.Show, Generic)
+          deriving anyclass (ToJSON, FromJSON, ToSchema)
+
+-- | The "lock" contract endpoint. See note [Contract endpoints]
+lock :: AsContractError e => Promise () GameSchema e ()
+lock = endpoint @"lock" $ \LockArgs { lockArgsGameParam, lockArgsSecret, lockArgsValue } -> do
+    logInfo @Haskell.String $ "Pay " <> Haskell.show lockArgsValue <> " to the script"
+    let lookups = Constraints.typedValidatorLookups (gameInstance lockArgsGameParam)
+        tx       = Constraints.mustPayToTheScript (hashString lockArgsSecret) lockArgsValue
+    unbalancedTx <- mkTxConstraints lookups tx
+    yieldUnbalancedTx $ Constraints.adjustUnbalancedTx unbalancedTx
+
+-- | The "guess" contract endpoint. See note [Contract endpoints]
+guess :: AsContractError e => Promise () GameSchema e ()
+guess = endpoint @"guess" $ \GuessArgs { guessArgsGameParam, guessArgsSecret } -> do
+    -- Wait for script to have a UTxO of a least 1 lovelace
+    logInfo @Haskell.String "Waiting for script to have a UTxO of at least 1 lovelace"
+    utxos <- fundsAtAddressGeq (gameAddress guessArgsGameParam) (Ada.lovelaceValueOf 1)
+
+    let lookups = Constraints.typedValidatorLookups (gameInstance guessArgsGameParam)
+               Haskell.<> Constraints.unspentOutputs utxos
+        redeemer = clearString guessArgsSecret
+        tx       = collectFromScript utxos redeemer
+
+    unbalancedTx <- mkTxConstraints lookups tx
+    yieldUnbalancedTx unbalancedTx
+
+-- | Find the secret word in the Datum of the UTxOs
+findSecretWordValue :: Map TxOutRef ChainIndexTxOut -> Maybe HashedString
+findSecretWordValue =
+  listToMaybe . catMaybes . Map.elems . Map.map secretWordValue
+
+-- | Extract the secret word in the Datum of a given transaction output is possible
+secretWordValue :: ChainIndexTxOut -> Maybe HashedString
+secretWordValue o = do
+  Datum d <- either (const Nothing) Just (_ciTxOutDatum o)
+  PlutusTx.fromBuiltinData d
+
+contract :: AsContractError e => Contract () GameSchema e ()
+contract = do
+    logInfo @Haskell.String "Waiting for lock or guess endpoint..."
+    selectList [lock, guess] >> contract