Provisional websockets implementation

plutus-pab/src/Plutus/PAB/Core.hs

@@ -65,7 +65,12 @@ module Plutus.PAB.Core
     , activeContracts
     , finalResult
     , waitUntilFinished
-    , userEnv
+    , blockchainEnv
+    , valueAtSTM
+    , valueAt
+    , askUserEnv
+    , askBlockchainEnv
+    , askInstancesState
     -- * Run PAB effects in separate threads
     , PABRunner(..)
     , pabRunner
@@ -101,7 +106,7 @@ import           Data.Text.Prettyprint.Doc                       (Pretty, colon,
 import qualified Data.Text.Prettyprint.Doc.Render.Text           as Render
 import           GHC.Generics                                    (Generic)
 import           Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint (..))
-import           Ledger.Tx                                       (Tx)
+import           Ledger.Tx                                       (Address, Tx)
 import           Ledger.Value                                    (Value)
 import           Plutus.PAB.Core.ContractInstance                (ContractInstanceMsg)
 import qualified Plutus.PAB.Core.ContractInstance                as ContractInstance
@@ -487,14 +492,32 @@ finalResult instanceId = do
     instancesState <- asks @(PABEnvironment t env) instancesState
     pure $ Instances.finalResult instanceId instancesState
 
+-- | An STM transaction returning the value at an address
+valueAtSTM :: forall t env. Address -> PABAction t env (STM Value)
+valueAtSTM address = do
+    blockchainEnv <- asks @(PABEnvironment t env) blockchainEnv
+    return $ Instances.valueAt address blockchainEnv
+
+-- | The value at an address
+valueAt :: forall t env. Address -> PABAction t env Value
+valueAt address = valueAtSTM address >>= liftIO . STM.atomically
+
 -- | Wait until the contract is done, then return
 --   the error (if any)
 waitUntilFinished :: forall t env. ContractInstanceId -> PABAction t env (Maybe JSON.Value)
 waitUntilFinished i = finalResult i >>= liftIO . STM.atomically
 
 -- | Read the 'env' from the environment
-userEnv :: forall t env effs. Member (Reader (PABEnvironment t env)) effs => Eff effs env
-userEnv = interpret (handleUserEnvReader @t @env) ask
+askUserEnv :: forall t env effs. Member (Reader (PABEnvironment t env)) effs => Eff effs env
+askUserEnv = interpret (handleUserEnvReader @t @env) ask
+
+-- | Read the 'BlockchainEnv' from the environment
+askBlockchainEnv :: forall t env effs. Member (Reader (PABEnvironment t env)) effs => Eff effs BlockchainEnv
+askBlockchainEnv = interpret (handleBlockchainEnvReader @t @env) ask
+
+-- | Read the 'InstancesState' from the environment
+askInstancesState :: forall t env effs. Member (Reader (PABEnvironment t env)) effs => Eff effs InstancesState
+askInstancesState = interpret (handleInstancesStateReader @t @env) ask
 
 handleMappedReader :: forall f g effs.
     Member (Reader f) effs

plutus-pab/src/Plutus/PAB/Core/ContractInstance/STM.hs

@@ -12,6 +12,8 @@ module Plutus.PAB.Core.ContractInstance.STM(
     , awaitEndpointResponse
     , waitForAddressChange
     , waitForTxConfirmed
+    , valueAt
+    , currentSlot
     -- * State of a contract instance
     , InstanceState(..)
     , emptyInstanceState
@@ -42,6 +44,7 @@ module Plutus.PAB.Core.ContractInstance.STM(
 import           Control.Applicative                               (Alternative (..))
 import           Control.Concurrent.STM                            (STM, TMVar, TVar)
 import qualified Control.Concurrent.STM                            as STM
+import           Control.Lens                                      (view)
 import           Control.Monad                                     (guard)
 import           Data.Aeson                                        (Value)
 import           Data.Foldable                                     (fold)
@@ -52,8 +55,10 @@ import qualified Data.Set                                          as Set
 import           Plutus.Contract.Effects.AwaitTxConfirmed (TxConfirmed (..))
 import           Plutus.Contract.Effects.ExposeEndpoint   (ActiveEndpoint (..), EndpointValue (..))
 import           Plutus.Contract.Resumable                (IterationID, Request (..), RequestID)
-import           Ledger                                            (Address, Slot, TxId)
+import           Ledger                                            (Address, Slot, TxId, txOutTxOut, txOutValue)
 import           Ledger.AddressMap                                 (AddressMap)
+import qualified Ledger.AddressMap                                 as AM
+import qualified Ledger.Value                                      as Value
 import           Wallet.Emulator.ChainIndex.Index                  (ChainIndex)
 import qualified Wallet.Emulator.ChainIndex.Index                  as Index
 import           Wallet.Types                                      (AddressChangeRequest (..),
@@ -334,3 +339,14 @@ waitForTxConfirmed tx BlockchainEnv{beTxChanges} = do
     idx <- STM.readTVar beTxChanges
     guard $ maybe False isConfirmed (Map.lookup tx idx)
     pure (TxConfirmed tx)
+
+-- | The value at an address
+valueAt :: Address -> BlockchainEnv -> STM Value.Value
+valueAt addr BlockchainEnv{beAddressMap} = do
+    am <- STM.readTVar beAddressMap
+    let utxos = view (AM.fundsAt addr) am
+    return $ foldMap (txOutValue . txOutTxOut) utxos
+
+-- | The current slot number
+currentSlot :: BlockchainEnv -> STM Slot
+currentSlot BlockchainEnv{beCurrentSlot} = STM.readTVar beCurrentSlot

plutus-pab/src/Plutus/PAB/Simulator.hs

@@ -174,7 +174,7 @@ simulatorHandlers =
                 Contract.AddDefinition _ -> pure () -- not supported
                 Contract.GetDefinitions  -> pure [Game, Currency, AtomicSwap]
         , onStartup = do
-            SimulatorState{_logMessages} <- Core.userEnv @TestContracts @(SimulatorState TestContracts)
+            SimulatorState{_logMessages} <- Core.askUserEnv @TestContracts @(SimulatorState TestContracts)
             void $ liftIO $ forkIO (printLogMessages _logMessages)
             Core.PABRunner{Core.runPABAction} <- Core.pabRunner
             void
@@ -547,18 +547,18 @@ handleContractStore ::
     ~> Eff effs
 handleContractStore = \case
     Contract.PutState def instanceId state -> do
-        instancesTVar <- view instances <$> (Core.userEnv @t @(SimulatorState t))
+        instancesTVar <- view instances <$> (Core.askUserEnv @t @(SimulatorState t))
         liftIO $ STM.atomically $ do
             let instState = SimulatorContractInstanceState{_contractDef = def, _contractState = state}
             STM.modifyTVar instancesTVar (set (at instanceId) (Just instState))
     Contract.GetState instanceId -> do
-        instancesTVar <- view instances <$> (Core.userEnv @t @(SimulatorState t))
+        instancesTVar <- view instances <$> (Core.askUserEnv @t @(SimulatorState t))
         result <- preview (at instanceId . _Just . contractState) <$> liftIO (STM.readTVarIO instancesTVar)
         case result of
             Just s  -> pure s
             Nothing -> throwError (ContractInstanceNotFound instanceId)
     Contract.ActiveContracts -> do
-        instancesTVar <- view instances <$> (Core.userEnv @t @(SimulatorState t))
+        instancesTVar <- view instances <$> (Core.askUserEnv @t @(SimulatorState t))
         fmap _contractDef <$> liftIO (STM.readTVarIO instancesTVar)
 
 render :: forall a. Pretty a => a -> Text
@@ -580,7 +580,7 @@ makeLenses ''TxCounts
 -- | Get the 'TxCounts' of the emulated blockchain
 txCounts :: forall t. Simulation t TxCounts
 txCounts = do
-    SimulatorState{_chainState} <- Core.userEnv @t @(SimulatorState t)
+    SimulatorState{_chainState} <- Core.askUserEnv @t @(SimulatorState t)
     Chain.ChainState{Chain._chainNewestFirst, Chain._txPool} <- liftIO $ STM.readTVarIO _chainState
     return
         $ TxCounts
@@ -595,7 +595,7 @@ activeContracts = Core.activeContracts
 -- | The total value currently at an address
 valueAtSTM :: forall t. Address -> Simulation t (STM Value)
 valueAtSTM address = do
-    SimulatorState{_chainState} <- Core.userEnv @t @(SimulatorState t)
+    SimulatorState{_chainState} <- Core.askUserEnv @t @(SimulatorState t)
     pure $ do
         Chain.ChainState{Chain._index=UtxoIndex.UtxoIndex mp} <- STM.readTVar _chainState
         pure $ foldMap txOutValue $ filter (\TxOut{txOutAddress} -> txOutAddress == address) $ fmap snd $ Map.toList mp
@@ -609,6 +609,6 @@ valueAt address = do
 -- | The entire chain (newest transactions first)
 blockchain :: forall t. Simulation t [[Tx]]
 blockchain = do
-    SimulatorState{_chainState} <- Core.userEnv @t @(SimulatorState t)
+    SimulatorState{_chainState} <- Core.askUserEnv @t @(SimulatorState t)
     Chain.ChainState{Chain._chainNewestFirst} <- liftIO $ STM.readTVarIO _chainState
     pure _chainNewestFirst

plutus-pab/src/Plutus/PAB/Webserver/Server.hs

@@ -53,7 +53,6 @@ type CombinedAPI t =
       API (Contract.ContractDef t)
       :<|> WSAPI
       :<|> NewAPI (Contract.ContractDef t)
-      -- :<|> Raw
 
 app ::
     forall t env.
@@ -71,7 +70,7 @@ app fp pabRunner = do
             Servant.hoistServer
                 (Proxy @(CombinedAPI t))
                 (asHandler pabRunner)
-                (handlerOld :<|> WS.combinedWebsocket :<|> handlerNew) -- :<|> fileServer)
+                (handlerOld :<|> WS.combinedWebsocket :<|> handlerNew)
 
     case fp of
         Nothing -> do