wip: try restoring old behavior using another Promise

input-output-hk · Jul 29, 2021 · 0bee7ea · 0bee7ea
1 parent 2e4e1fd
commit 0bee7ea
Show file tree

Hide file tree

Showing 2 changed files with 23 additions and 10 deletions.
diff --git a/examples/src/Plutus/Contracts/Game.hs b/examples/src/Plutus/Contracts/Game.hs
@@ -43,6 +43,7 @@ import           Control.Monad                  (void)
 import           Data.Aeson                     (FromJSON, ToJSON)
 import qualified Data.Map                       as Map
 import           GHC.Generics                   (Generic)
+import           GHC.Natural                    (Natural)
 import           Ledger                         (Address, Datum (Datum), ScriptContext, TxOutTx, Validator, Value)
 import qualified Ledger
 import qualified Ledger.Ada                     as Ada
@@ -51,6 +52,7 @@ import qualified Ledger.Constraints             as Constraints
 import qualified Ledger.Typed.Scripts           as Scripts
 import           Plutus.Contract
 import           Plutus.Contract.Schema         ()
+import           Plutus.Contract.Types
 import           Plutus.Trace.Emulator          (EmulatorTrace, observableState)
 import qualified Plutus.Trace.Emulator          as Trace
 import qualified PlutusTx
@@ -144,11 +146,24 @@ lock = endpoint @"lock" @LockParams $ \(LockParams secret amt) -> do
     let tx         = Constraints.mustPayToTheScript (hashString secret) amt
     void (submitTxConstraints gameInstance tx)
 
-guess :: (AsContractError e) => Promise () GameSchema e ()
-guess = endpoint @"guess" @GuessParams $ \(GuessParams theGuess) -> do
+delaySlots ::
+  forall w s e.
+  ( AsContractError e
+  )
+  => Natural
+  -> Promise w s e ()
+delaySlots n = Promise $ do
+  waitNSlots n
+  pure ()
+
+guess :: forall e . (AsContractError e) => Promise () GameSchema e ()
+guess = Promise $
+  fundsAtAddressGeq gameAddress (Ada.lovelaceValueOf 1) >>= awaitPromise . guess'
+
+guess' ::  forall e . (AsContractError e) => UtxoMap -> Promise () GameSchema e ()
+guess' utxos = endpoint @"guess" @GuessParams $ \(GuessParams theGuess) -> 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 (Ada.lovelaceValueOf 1)
 
     let redeemer = clearString theGuess
         tx       = collectFromScript utxos redeemer

diff --git a/examples/test/Spec/Game.hs b/examples/test/Spec/Game.hs
@@ -37,14 +37,12 @@ theContract = game
 tests :: TestTree
 tests = testGroup "game"
     [
--- Note: Used to be the case prior Promises but now we expose both at once
---
---      checkPredicate "Expose 'lock' endpoint, but not 'guess' endpoint"
---        (endpointAvailable @"lock" theContract t1
---          .&&. not (endpointAvailable @"guess" theContract t1))
---        $ void $ Trace.activateContractWallet w1 (lock @ContractError)
+      checkPredicate "Expose 'lock' endpoint, but not 'guess' endpoint"
+        (endpointAvailable @"lock" theContract t1
+          .&&. not (endpointAvailable @"guess" theContract t1))
+        $ void $ Trace.activateContractWallet w1 (lock @ContractError)
 
-      checkPredicate "'lock' endpoint submits a transaction"
+    , checkPredicate "'lock' endpoint submits a transaction"
         (anyTx theContract t1)
         $ do
             hdl <- Trace.activateContractWallet w1 theContract