SCP-2425: Can now access the SlotConfig in the Contract Monad which i…

…s specified by the Emulator config

marlowe/pab/Main.hs

@@ -143,5 +143,5 @@ handleMarloweContract = Builtin.handleBuiltin getSchema getContract where
 
 handlers :: SimulatorEffectHandlers (Builtin Marlowe)
 handlers =
-    Simulator.mkSimulatorHandlers @(Builtin Marlowe) def [MarloweApp]
+    Simulator.mkSimulatorHandlers @(Builtin Marlowe) def def [MarloweApp]
     $ interpret handleMarloweContract

marlowe/test/Spec/Marlowe/Marlowe.hs

@@ -240,7 +240,7 @@ trustFundTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 200) "Tr
                     $ run
                     $ runError @Folds.EmulatorFoldErr
                     $ foldEmulatorStreamM fld
-                    $ Trace.runEmulatorStream def def
+                    $ Trace.runEmulatorStream def
                     $ do
                         void $ Trace.activateContractWallet alice (void con)
                         Trace.waitNSlots 10

playground-common/src/Playground/Interpreter/Util.hs

@@ -124,12 +124,12 @@ stage contract programJson simulatorWalletsJson = do
         playgroundDecode "[Expression schema]" . BSL.pack $ simulationJson
     simulatorWallets :: [SimulatorWallet] <-
         playgroundDecode "[SimulatorWallet]" simulatorWalletsJson
-    let config = Plutus.Trace.Playground.EmulatorConfig (Left $ toInitialDistribution simulatorWallets)
+    let config = Plutus.Trace.Playground.EmulatorConfig (Left $ toInitialDistribution simulatorWallets) def def
         allWallets = simulatorWalletWallet <$> simulatorWallets
         final = run
             $ runError
             $ foldEmulatorStreamM @'[Error PlaygroundError] (evaluationResultFold allWallets)
-            $ runPlaygroundStream config def (void contract) (traverse_ expressionToTrace simulation)
+            $ runPlaygroundStream config (void contract) (traverse_ expressionToTrace simulation)
 
     case final of
         Left err     -> Left . OtherError . show $ err

plutus-contract/src/Plutus/Contract.hs

@@ -15,6 +15,7 @@ module Plutus.Contract(
     , mapError
     , runError
     -- * Dealing with time
+    , Request.getSlotConfig
     , Request.awaitSlot
     , Request.currentSlot
     , Request.waitNSlots

plutus-contract/src/Plutus/Contract/Effects.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE TemplateHaskell   #-}
 module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     PABReq(..),
+    _GetSlotConfigReq,
     _AwaitSlotReq,
     _AwaitTimeReq,
     _CurrentSlotReq,
@@ -19,6 +20,7 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     _WriteBalancedTxReq,
     _ExposeEndpointReq,
     PABResp(..),
+    _GetSlotConfigResp,
     _AwaitSlotResp,
     _AwaitTimeResp,
     _CurrentSlotResp,
@@ -54,13 +56,15 @@ import           Ledger.AddressMap           (UtxoMap)
 import           Ledger.Constraints.OffChain (UnbalancedTx)
 import           Ledger.Slot                 (Slot (..))
 import           Ledger.Time                 (POSIXTime (..))
+import           Ledger.TimeSlot             (SlotConfig)
 import           Wallet.API                  (WalletAPIError)
 import           Wallet.Types                (AddressChangeRequest, AddressChangeResponse, ContractInstanceId,
                                               EndpointDescription, EndpointValue)
 
 -- | Requests that 'Contract's can make
 data PABReq =
-    AwaitSlotReq Slot
+    GetSlotConfigReq
+    | AwaitSlotReq Slot
     | AwaitTimeReq POSIXTime
     | CurrentSlotReq
     | CurrentTimeReq
@@ -77,6 +81,7 @@ data PABReq =
 
 instance Pretty PABReq where
   pretty = \case
+    GetSlotConfigReq         -> "Slot config"
     AwaitSlotReq s           -> "Await slot:" <+> pretty s
     AwaitTimeReq s           -> "Await time:" <+> pretty s
     CurrentSlotReq           -> "Current slot"
@@ -92,7 +97,8 @@ instance Pretty PABReq where
 
 -- | Responses that 'Contract's receive
 data PABResp =
-    AwaitSlotResp Slot
+    GetSlotConfigResp SlotConfig
+    | AwaitSlotResp Slot
     | AwaitTimeResp POSIXTime
     | CurrentSlotResp Slot
     | CurrentTimeResp POSIXTime
@@ -110,6 +116,7 @@ data PABResp =
 
 instance Pretty PABResp where
   pretty = \case
+    GetSlotConfigResp s         -> "Slot config:" <+> pretty s
     AwaitSlotResp s             -> "Slot:" <+> pretty s
     AwaitTimeResp s             -> "Time:" <+> pretty s
     CurrentSlotResp s           -> "Current slot:" <+> pretty s

plutus-contract/src/Plutus/Contract/Request.hs

@@ -16,7 +16,8 @@
 module Plutus.Contract.Request(
     -- * PAB requests
     -- ** Waiting
-    awaitSlot
+    getSlotConfig
+    , awaitSlot
     , currentSlot
     , waitNSlots
     , awaitTime
@@ -95,6 +96,7 @@ import           Wallet.Types                (AddressChangeRequest (..), Address
 import           Plutus.Contract.Resumable
 import           Plutus.Contract.Types
 
+import           Ledger.TimeSlot             (SlotConfig)
 import           Prelude                     as Haskell
 
 -- | Constraints on the contract schema, ensuring that the labels of the schema
@@ -128,6 +130,14 @@ awaitSlot ::
     -> Contract w s e Slot
 awaitSlot s = pabReq (AwaitSlotReq s) E._AwaitSlotResp
 
+-- | Get the 'SlotConfig' which defines the length of 1 slot and the starting time.
+getSlotConfig ::
+    forall w s e.
+    ( AsContractError e
+    )
+    => Contract w s e SlotConfig
+getSlotConfig = pabReq GetSlotConfigReq E._GetSlotConfigResp
+
 -- | Get the current slot number
 currentSlot ::
     forall w s e.

plutus-contract/src/Plutus/Contract/Test.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns         #-}
+
 -- | Testing contracts with HUnit and Tasty
 module Plutus.Contract.Test(
       module X
@@ -62,7 +63,6 @@ module Plutus.Contract.Test(
     , minLogLevel
     , maxSlot
     , emulatorConfig
-    , feeConfig
     -- * Etc
     , goldenPir
     ) where
@@ -111,7 +111,6 @@ import qualified PlutusTx.Prelude                      as P
 import           Ledger                                (Validator)
 import qualified Ledger
 import           Ledger.Address                        (Address)
-import           Ledger.Fee                            (FeeConfig)
 import           Ledger.Generators                     (GeneratorModel, Mockchain (..))
 import qualified Ledger.Generators                     as Gen
 import           Ledger.Index                          (ScriptValidationEvent, ValidationError)
@@ -147,7 +146,6 @@ data CheckOptions =
         { _minLogLevel    :: LogLevel -- ^ Minimum log level for emulator log messages to be included in the test output (printed if the test fails)
         , _maxSlot        :: Slot -- ^ When to stop the emulator
         , _emulatorConfig :: EmulatorConfig
-        , _feeConfig      :: FeeConfig
         } deriving (Eq, Show)
 
 makeLenses ''CheckOptions
@@ -158,7 +156,6 @@ defaultCheckOptions =
         { _minLogLevel = Info
         , _maxSlot = 125
         , _emulatorConfig = def
-        , _feeConfig = def
         }
 
 type TestEffects = '[Reader InitialDistribution, Error EmulatorFoldErr, Writer (Doc Void)]
@@ -190,10 +187,10 @@ checkPredicateInner :: forall m.
     -> (String -> m ()) -- ^ Print out debug information in case of test failures
     -> (Bool -> m ()) -- ^ assert
     -> m ()
-checkPredicateInner CheckOptions{_minLogLevel, _maxSlot, _emulatorConfig, _feeConfig} predicate action annot assert = do
+checkPredicateInner CheckOptions{_minLogLevel, _maxSlot, _emulatorConfig} predicate action annot assert = do
     let dist = _emulatorConfig ^. initialChainState . to initialDist
         theStream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) ()
-        theStream = takeUntilSlot _maxSlot $ runEmulatorStream _emulatorConfig _feeConfig action
+        theStream = takeUntilSlot _maxSlot $ runEmulatorStream _emulatorConfig action
         consumeStream :: forall a. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff TestEffects) a -> Eff TestEffects (S.Of Bool a)
         consumeStream = foldEmulatorStreamM @TestEffects predicate
     result <- runM

plutus-contract/src/Plutus/Contract/Trace.hs

@@ -25,6 +25,7 @@ module Plutus.Contract.Trace
     , toNotifyError
     -- * Handle contract requests
     , handleBlockchainQueries
+    , handleGetSlotConfig
     , handleSlotNotifications
     , handleTimeNotifications
     , handleOwnPubKeyQueries
@@ -108,6 +109,14 @@ makeTimed e = do
     emulatorTime <- gets (view (EM.chainState . EM.currentSlot))
     pure $ review (EM.emulatorTimeEvent emulatorTime) (EM.NotificationEvent e)
 
+handleGetSlotConfig ::
+    ( Member (LogObserve (LogMessage Text)) effs
+    , Member NodeClientEffect effs
+    )
+    => RequestHandler effs PABReq PABResp
+handleGetSlotConfig =
+    generalise (preview E._GetSlotConfigReq) E.GetSlotConfigResp RequestHandler.handleGetSlotConfig
+
 handleSlotNotifications ::
     ( Member (LogObserve (LogMessage Text)) effs
     , Member (LogMsg RequestHandlerLogMsg) effs
@@ -155,6 +164,7 @@ handleBlockchainQueries =
     <> handleOwnPubKeyQueries
     <> handleAddressChangedAtQueries
     <> handleOwnInstanceIdQueries
+    <> handleGetSlotConfig
     <> handleSlotNotifications
     <> handleCurrentSlotQueries
     <> handleTimeNotifications

plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs

@@ -18,6 +18,7 @@ module Plutus.Contract.Trace.RequestHandler(
     , generalise
     -- * handlers for common requests
     , handleOwnPubKey
+    , handleGetSlotConfig
     , handleSlotNotifications
     , handleCurrentSlot
     , handleTimeNotifications
@@ -54,6 +55,7 @@ import           Control.Monad.Freer.Extras.Log (LogMessage, LogMsg, LogObserve,
 import           Ledger                         (Address, OnChainTx (Valid), POSIXTime, PubKey, Slot, Tx, TxId)
 import           Ledger.AddressMap              (AddressMap (..))
 import           Ledger.Constraints.OffChain    (UnbalancedTx)
+import           Ledger.TimeSlot                (SlotConfig)
 import qualified Ledger.TimeSlot                as TimeSlot
 import           Plutus.Contract.Effects        (TxConfirmed (..), UtxoAtAddress (..))
 import qualified Plutus.Contract.Wallet         as Wallet
@@ -126,6 +128,17 @@ handleOwnPubKey =
     RequestHandler $ \_ ->
         surroundDebug @Text "handleOwnPubKey" Wallet.Effects.ownPubKey
 
+handleGetSlotConfig ::
+    forall effs a.
+    ( Member NodeClientEffect effs
+    , Member (LogObserve (LogMessage Text)) effs
+    )
+    => RequestHandler effs a SlotConfig
+handleGetSlotConfig =
+    RequestHandler $ \_ ->
+        surroundDebug @Text "handleGetSlotConfig" $ do
+            Wallet.Effects.getClientSlotConfig
+
 handleSlotNotifications ::
     forall effs.
     ( Member NodeClientEffect effs

plutus-contract/src/Plutus/Trace/Effects/Waiting.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
+
 -- | Waiting for things to happen
 module Plutus.Trace.Effects.Waiting(
     Waiting(..)

plutus-contract/src/Plutus/Trace/Emulator.hs

@@ -57,6 +57,8 @@ module Plutus.Trace.Emulator(
     -- * Running traces
     , EmulatorConfig(..)
     , initialChainState
+    , slotConfig
+    , feeConfig
     , runEmulatorStream
     , TraceConfig(..)
     , runEmulatorTrace
@@ -91,12 +93,12 @@ import qualified Wallet.Emulator.Chain                   as ChainState
 import           Wallet.Emulator.MultiAgent              (EmulatorEvent, EmulatorEvent' (..), EmulatorState (..),
                                                           MultiAgentControlEffect, MultiAgentEffect, _eteEmulatorTime,
                                                           _eteEvent, schedulerEvent)
-import           Wallet.Emulator.Stream                  (EmulatorConfig (..), EmulatorErr (..), foldEmulatorStreamM,
-                                                          initialChainState, initialDist, runTraceStream)
+import           Wallet.Emulator.Stream                  (EmulatorConfig (..), EmulatorErr (..), feeConfig,
+                                                          foldEmulatorStreamM, initialChainState, initialDist,
+                                                          runTraceStream, slotConfig)
 import           Wallet.Emulator.Wallet                  (Entity, balances)
 import qualified Wallet.Emulator.Wallet                  as Wallet
 
-import           Ledger.Fee                              (FeeConfig)
 import           Plutus.Trace.Effects.ContractInstanceId (ContractInstanceIdEff, handleDeterministicIds)
 import           Plutus.Trace.Effects.EmulatedWalletAPI  (EmulatedWalletAPI, handleEmulatedWalletAPI)
 import qualified Plutus.Trace.Effects.EmulatedWalletAPI  as EmulatedWalletAPI
@@ -165,10 +167,9 @@ handleEmulatorTrace action = do
 -- | Run a 'Trace Emulator', streaming the log messages as they arrive
 runEmulatorStream :: forall effs a.
     EmulatorConfig
-    -> FeeConfig
     -> EmulatorTrace a
     -> Stream (Of (LogMessage EmulatorEvent)) (Eff effs) (Maybe EmulatorErr, EmulatorState)
-runEmulatorStream conf feeCfg = runTraceStream conf feeCfg . interpretEmulatorTrace conf
+runEmulatorStream conf = runTraceStream conf . interpretEmulatorTrace conf
 
 -- | Interpret a 'Trace Emulator' action in the multi agent and emulated
 --   blockchain effects.
@@ -230,27 +231,25 @@ defaultShowEvent = \case
 -- of the emulator, the events, and any error, if any.
 runEmulatorTrace
     :: EmulatorConfig
-    -> FeeConfig
     -> EmulatorTrace ()
     -> ([EmulatorEvent], Maybe EmulatorErr, EmulatorState)
-runEmulatorTrace cfg feeCfg trace =
+runEmulatorTrace cfg trace =
     (\(xs :> (y, z)) -> (xs, y, z))
     $ run
     $ runReader ((initialDist . _initialChainState) cfg)
     $ foldEmulatorStreamM (generalize list)
-    $ runEmulatorStream cfg feeCfg trace
+    $ runEmulatorStream cfg trace
 
 
 -- | Run the emulator trace returning an effect that can be evaluated by
 -- interpreting the 'PrintEffect's.
 runEmulatorTraceEff :: forall effs. Member PrintEffect effs
     => TraceConfig
     -> EmulatorConfig
-    -> FeeConfig
     -> EmulatorTrace ()
     -> Eff effs ()
-runEmulatorTraceEff tcfg cfg feeCfg trace =
-  let (xs, me, e) = runEmulatorTrace cfg feeCfg trace
+runEmulatorTraceEff tcfg cfg trace =
+  let (xs, me, e) = runEmulatorTrace cfg trace
       balances' = balances (_chainState e) (_walletStates e)
    in do
       case me of
@@ -276,7 +275,7 @@ runEmulatorTraceEff tcfg cfg feeCfg trace =
 runEmulatorTraceIO
     :: EmulatorTrace ()
     -> IO ()
-runEmulatorTraceIO = runEmulatorTraceIO' def def def
+runEmulatorTraceIO = runEmulatorTraceIO' def def
 
 --- | Runs the trace with a given configuration for the trace and the config.
 --
@@ -286,11 +285,10 @@ runEmulatorTraceIO = runEmulatorTraceIO' def def def
 runEmulatorTraceIO'
     :: TraceConfig
     -> EmulatorConfig
-    -> FeeConfig
     -> EmulatorTrace ()
     -> IO ()
-runEmulatorTraceIO' tcfg cfg feeCfg trace
-  = runPrintEffect (outputHandle tcfg) $ runEmulatorTraceEff tcfg cfg feeCfg trace
+runEmulatorTraceIO' tcfg cfg trace
+  = runPrintEffect (outputHandle tcfg) $ runEmulatorTraceEff tcfg cfg trace
 
 runPrintEffect :: Handle
          -> Eff '[PrintEffect, IO] r

plutus-contract/src/Plutus/Trace/Playground.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE GADTs             #-}
-{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -39,7 +38,6 @@ import           Data.Map                                   (Map)
 import qualified Data.Map                                   as Map
 import           Data.Maybe                                 (fromMaybe)
 
-import           Ledger.Fee                                 (FeeConfig)
 import           Plutus.Contract                            (Contract (..))
 import           Plutus.Trace.Effects.ContractInstanceId    (ContractInstanceIdEff, handleDeterministicIds)
 import           Plutus.Trace.Effects.EmulatedWalletAPI     (EmulatedWalletAPI, handleEmulatedWalletAPI)
@@ -128,13 +126,12 @@ runPlaygroundStream :: forall w s e effs a.
     , Monoid w
     )
     => EmulatorConfig
-    -> FeeConfig
     -> Contract w s e ()
     -> PlaygroundTrace a
     -> Stream (Of (LogMessage EmulatorEvent)) (Eff effs) (Maybe EmulatorErr, EmulatorState)
-runPlaygroundStream conf feeCfg contract =
+runPlaygroundStream conf contract =
     let wallets = fromMaybe (Wallet <$> [1..10]) (preview (initialChainState . _Left . to Map.keys) conf)
-    in runTraceStream conf feeCfg . interpretPlaygroundTrace contract wallets
+    in runTraceStream conf . interpretPlaygroundTrace contract wallets
 
 interpretPlaygroundTrace :: forall w s e effs a.
     ( Member MultiAgentEffect effs
@@ -163,6 +160,6 @@ interpretPlaygroundTrace contract wallets action =
             void
                 $ handlePlaygroundTrace contract
                 $ do
-                    void $ Waiting.nextSlot
+                    void Waiting.nextSlot
                     traverse_ RunContractPlayground.launchContract wallets
                     action