SCP-2669: Delete beAddressMap from BlockchainEnv in plutus-pab. (#50)

* New PAB action `valueAt` where we can query the value at a specific wallet which replaces the beAddressMap field in BlockchainEnv. * Deleted PubKeyHashFundsChange in Webserver stream. Upstream code which uses that should now use the new `valueAt` PAB action. * Added plutus-pab testing for `valueAt`. * More precise error message in cardano wallet code.
IntersectMBO · Oct 26, 2021 · 29bd7fa · 29bd7fa
1 parent f9b7773
commit 29bd7fa
Show file tree

Hide file tree

Showing 8 changed files with 62 additions and 86 deletions.
diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs
@@ -130,7 +130,11 @@ walletMockWallet (Wallet wid) = find ((==) wid . WalletId . CW.mwWalletId) CW.kn
 
 -- | The public key hash of a mock wallet.  (Fails if the wallet is not a mock wallet).
 walletPubKeyHash :: Wallet -> PubKeyHash
-walletPubKeyHash = CW.pubKeyHash . fromMaybe (error "walletPubKeyHash: Wallet is not a mock wallet") . walletMockWallet
+walletPubKeyHash w = CW.pubKeyHash
+                 $ fromMaybe (error $ "Wallet.Emulator.Wallet.walletPubKeyHash: Wallet "
+                                   <> show w
+                                   <> " is not a mock wallet")
+                 $ walletMockWallet w
 
 -- | Get the address of a mock wallet. (Fails if the wallet is not a mock wallet).
 walletAddress :: Wallet -> Address

diff --git a/plutus-ledger/src/Ledger/CardanoWallet.hs b/plutus-ledger/src/Ledger/CardanoWallet.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE NamedFieldPuns     #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE TypeApplications   #-}
 {-# LANGUAGE TypeFamilies       #-}
 
 {- Cardano wallet implementation for the emulator.
@@ -76,7 +75,7 @@ fromSeed bs = MockWallet{mwWalletId, mwKey} where
     missing = max 0 (32 - BS.length bs)
     bs' = bs <> BS.replicate missing 0
     mwWalletId = CW.WalletId
-        $ fromMaybe (error "CardanoWallet: fromSeed: digestFromByteString")
+        $ fromMaybe (error "Ledger.CardanoWallet.fromSeed: digestFromByteString")
         $ Crypto.digestFromByteString
         $ Crypto.hashWith Crypto.Blake2b_160
         $ getLedgerBytes
@@ -86,7 +85,10 @@ fromSeed bs = MockWallet{mwWalletId, mwKey} where
     mwKey = MockPrivateKey k
 
 toWalletNumber :: MockWallet -> WalletNumber
-toWalletNumber MockWallet{mwWalletId=w} = maybe (error "toWalletNumber: not a known wallet") (WalletNumber . toInteger . succ) $ findIndex ((==) w . mwWalletId) knownWallets
+toWalletNumber MockWallet{mwWalletId=w} =
+    maybe (error "Ledger.CardanoWallet.toWalletNumber: not a known wallet")
+          (WalletNumber . toInteger . succ)
+          $ findIndex ((==) w . mwWalletId) knownWallets
 
 -- | The wallets used in mockchain simulations by default. There are
 --   ten wallets by default.

diff --git a/plutus-pab/src/Plutus/PAB/Core.hs b/plutus-pab/src/Plutus/PAB/Core.hs
@@ -67,7 +67,6 @@ module Plutus.PAB.Core
     , finalResult
     , waitUntilFinished
     , blockchainEnv
-    , valueAtSTM
     , valueAt
     , askUserEnv
     , askBlockchainEnv
@@ -87,6 +86,7 @@ module Plutus.PAB.Core
 import           Control.Applicative                     (Alternative (..))
 import           Control.Concurrent.STM                  (STM)
 import qualified Control.Concurrent.STM                  as STM
+import           Control.Lens                            (view)
 import           Control.Monad                           (forM, guard, void)
 import           Control.Monad.Freer                     (Eff, LastMember, Member, interpret, reinterpret, runM, send,
                                                           subsume, type (~>))
@@ -96,18 +96,21 @@ import qualified Control.Monad.Freer.Extras.Modify       as Modify
 import           Control.Monad.Freer.Reader              (Reader (..), ask, asks, runReader)
 import           Control.Monad.IO.Class                  (MonadIO (..))
 import qualified Data.Aeson                              as JSON
+import           Data.Default                            (Default (def))
 import           Data.Foldable                           (traverse_)
 import           Data.Map                                (Map)
 import qualified Data.Map                                as Map
+import           Data.Maybe                              (catMaybes)
 import           Data.Proxy                              (Proxy (..))
 import           Data.Set                                (Set)
 import           Data.Text                               (Text)
-import           Ledger                                  (TxOutRef)
-import           Ledger.Tx                               (Address, CardanoTx)
+import           Ledger                                  (Address (addressCredential), TxOutRef)
+import           Ledger.Tx                               (CardanoTx, ciTxOutValue)
 import           Ledger.TxId                             (TxId)
 import           Ledger.Value                            (Value)
 import           Plutus.ChainIndex                       (ChainIndexQueryEffect, RollbackState (..), TxOutStatus,
                                                           TxStatus)
+import qualified Plutus.ChainIndex                       as ChainIndex
 import           Plutus.Contract.Effects                 (ActiveEndpoint (..), PABReq)
 import           Plutus.PAB.Core.ContractInstance        (ContractInstanceMsg, ContractInstanceState)
 import qualified Plutus.PAB.Core.ContractInstance        as ContractInstance
@@ -130,7 +133,7 @@ import qualified Wallet.API                              as WAPI
 import           Wallet.Effects                          (NodeClientEffect, WalletEffect)
 import           Wallet.Emulator.LogMessages             (RequestHandlerLogMsg, TxBalanceMsg)
 import           Wallet.Emulator.MultiAgent              (EmulatorEvent' (..), EmulatorTimeEvent (..))
-import           Wallet.Emulator.Wallet                  (Wallet, WalletEvent (..))
+import           Wallet.Emulator.Wallet                  (Wallet, WalletEvent (..), walletAddress)
 import           Wallet.Types                            (ContractActivityStatus, ContractInstanceId,
                                                           EndpointDescription (..), NotificationError)
 
@@ -249,25 +252,25 @@ activateContract' ::
     -> Wallet
     -> ContractDef t
     -> PABAction t env ContractInstanceId
-activateContract' state cid w def = do
+activateContract' state cid w contractDef = do
     PABRunner{runPABAction} <- pabRunner
 
     let handler :: forall a. Eff (ContractInstanceEffects t env '[IO]) a -> IO a
         handler x = fmap (either (error . show) id) (runPABAction $ handleAgentThread w x)
         args :: ContractActivationArgs (ContractDef t)
-        args = ContractActivationArgs{caWallet = Just w, caID = def}
+        args = ContractActivationArgs{caWallet = Just w, caID = contractDef}
     handleAgentThread w
         $ ContractInstance.startContractInstanceThread' @t @IO @(ContractInstanceEffects t env '[IO]) state cid handler args
 
 -- | Start a new instance of a contract
 activateContract :: forall t env. PABContract t => Wallet -> ContractDef t -> PABAction t env ContractInstanceId
-activateContract w def = do
+activateContract w contractDef = do
     PABRunner{runPABAction} <- pabRunner
 
     let handler :: forall a. Eff (ContractInstanceEffects t env '[IO]) a -> IO a
         handler x = fmap (either (error . show) id) (runPABAction $ handleAgentThread w x)
         args :: ContractActivationArgs (ContractDef t)
-        args = ContractActivationArgs{caWallet = Just w, caID = def}
+        args = ContractActivationArgs{caWallet = Just w, caID = contractDef}
     handleAgentThread w
         $ ContractInstance.activateContractSTM @t @IO @(ContractInstanceEffects t env '[IO]) handler args
 
@@ -562,15 +565,24 @@ 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
+-- | The value in a wallet.
+--
+-- TODO: Change from 'Wallet' to 'Address' (see SCP-2208).
+valueAt :: Wallet -> PABAction t env Value
+valueAt wallet = do
+  handleAgentThread wallet $ do
+    utxoRefs <- getAllUtxoRefs def
+    txOutsM <- traverse ChainIndex.txOutFromRef utxoRefs
+    pure $ foldMap (view ciTxOutValue) $ catMaybes txOutsM
+  where
+    cred = addressCredential $ walletAddress wallet
+    getAllUtxoRefs pq = do
+      utxoRefsPage <- snd <$> ChainIndex.utxoSetAtAddress pq cred
+      case ChainIndex.nextPageQuery utxoRefsPage of
+        Nothing -> pure $ ChainIndex.pageItems utxoRefsPage
+        Just newPageQuery -> do
+          restOfUtxoRefs <- getAllUtxoRefs newPageQuery
+          pure $ ChainIndex.pageItems utxoRefsPage <> restOfUtxoRefs
 
 -- | Wait until the contract is done, then return
 --   the error (if any)

diff --git a/plutus-pab/src/Plutus/PAB/Core/ContractInstance/BlockchainEnv.hs b/plutus-pab/src/Plutus/PAB/Core/ContractInstance/BlockchainEnv.hs
@@ -18,9 +18,7 @@ import qualified Cardano.Protocol.Socket.Client         as Client
 import qualified Cardano.Protocol.Socket.Mock.Client    as MockClient
 import qualified Data.Map                               as Map
 import           Data.Monoid                            (Last (..), Sum (..))
-import           Ledger                                 (Block, OnChainTx, Slot, TxId (..))
-import           Ledger.AddressMap                      (AddressMap)
-import qualified Ledger.AddressMap                      as AddressMap
+import           Ledger                                 (Block, Slot, TxId (..))
 import           Plutus.PAB.Core.ContractInstance.STM   (BlockchainEnv (..), InstanceClientEnv (..), InstancesState,
                                                          OpenTxOutProducedRequest (..), OpenTxOutSpentRequest (..),
                                                          emptyBlockchainEnv)
@@ -170,7 +168,7 @@ updateTransactionState
   -> STM (Either SyncActionFailure ())
 updateTransactionState tip BlockchainEnv{beTxChanges, beTxOutChanges, beCurrentBlock} xs = do
     txIdStateIndex <- STM.readTVar beTxChanges
-    let txIdState = _usTxUtxoData $ utxoState $ txIdStateIndex
+    let txIdState = _usTxUtxoData $ utxoState txIdStateIndex
     txUtxoBalanceIndex <- STM.readTVar beTxOutChanges
     let txUtxoBalance = _usTxUtxoData $ utxoState txUtxoBalanceIndex
     blockNumber <- STM.readTVar beCurrentBlock
@@ -204,17 +202,14 @@ insertNewTx blockNumber TxIdState{txnsConfirmed, txnsDeleted} (txi, _, txValidit
 -- | Go through the transactions in a block, updating the 'BlockchainEnv'
 --   when any interesting addresses or transactions have changed.
 processMockBlock :: InstancesState -> BlockchainEnv -> Block -> Slot -> STM (Either SyncActionFailure ())
-processMockBlock instancesState env@BlockchainEnv{beAddressMap, beCurrentSlot, beCurrentBlock} transactions slot = do
+processMockBlock instancesState env@BlockchainEnv{beCurrentSlot, beCurrentBlock} transactions slot = do
   lastSlot <- STM.readTVar beCurrentSlot
   when (slot > lastSlot) $ do
     STM.writeTVar beCurrentSlot slot
 
   if null transactions
      then pure $ Right ()
      else do
-      addressMap <- STM.readTVar beAddressMap
-      let addressMap' = foldl' (processTx slot) addressMap transactions
-      STM.writeTVar beAddressMap addressMap'
       blockNumber <- STM.readTVar beCurrentBlock
 
       instEnv <- S.instancesClientEnv instancesState
@@ -226,10 +221,3 @@ processMockBlock instancesState env@BlockchainEnv{beAddressMap, beCurrentSlot, b
                     }
 
       updateTransactionState tip env (txEvent <$> fmap fromOnChainTx transactions)
-
-processTx :: Slot -> AddressMap -> OnChainTx -> AddressMap
-processTx _ addressMap tx = addressMap' where
-  -- TODO: Will be removed in a future issue
-  addressMap' = AddressMap.updateAllAddresses tx addressMap
-  -- TODO: updateInstances
-  -- We need to switch to using 'ChainIndexTx' everyhwere first, though.
diff --git a/plutus-pab/src/Plutus/PAB/Core/ContractInstance/STM.hs b/plutus-pab/src/Plutus/PAB/Core/ContractInstance/STM.hs
@@ -15,7 +15,6 @@ module Plutus.PAB.Core.ContractInstance.STM(
     , awaitEndpointResponse
     , waitForTxStatusChange
     , waitForTxOutStatusChange
-    , valueAt
     , currentSlot
     -- * State of a contract instance
     , InstanceState(..)
@@ -52,7 +51,6 @@ 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.Default                   (def)
@@ -61,12 +59,9 @@ import           Data.List.NonEmpty             (NonEmpty)
 import           Data.Map                       (Map)
 import qualified Data.Map                       as Map
 import           Data.Set                       (Set)
-import           Ledger                         (Address, Slot, TxId, TxOutRef, txOutTxOut, txOutValue)
-import           Ledger.AddressMap              (AddressMap)
-import qualified Ledger.AddressMap              as AM
+import           Ledger                         (Address, Slot, TxId, TxOutRef)
 import           Ledger.Time                    (POSIXTime (..))
 import qualified Ledger.TimeSlot                as TimeSlot
-import qualified Ledger.Value                   as Value
 import           Plutus.ChainIndex              (BlockNumber (..), ChainIndexTx, TxIdState (..), TxOutBalance,
                                                  TxOutStatus, TxStatus, transactionStatus)
 import           Plutus.ChainIndex.TxOutBalance (transactionOutputStatus)
@@ -153,7 +148,6 @@ data OpenTxOutProducedRequest =
 data BlockchainEnv =
     BlockchainEnv
         { beCurrentSlot  :: TVar Slot -- ^ Current slot
-        , beAddressMap   :: TVar AddressMap -- ^ Address map used for updating the chain index. TODO: Should not be part of 'BlockchainEnv'
         , beTxChanges    :: TVar (UtxoIndex TxIdState) -- ^ Map holding metadata which determines the status of transactions.
         , beTxOutChanges :: TVar (UtxoIndex TxOutBalance) -- ^ Map holding metadata which determines the status of transaction outputs.
         , beCurrentBlock :: TVar BlockNumber -- ^ Current block
@@ -166,7 +160,6 @@ emptyBlockchainEnv =
         <$> STM.newTVar 0
         <*> STM.newTVar mempty
         <*> STM.newTVar mempty
-        <*> STM.newTVar mempty
         <*> STM.newTVar (BlockNumber 0)
 
 -- | Wait until the current slot is greater than or equal to the
@@ -413,13 +406,6 @@ waitForTxOutStatusChange oldStatus txOutRef BlockchainEnv{beTxChanges, beTxOutCh
       Right s | s /= oldStatus -> pure s
       _                        -> empty
 
--- | 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

diff --git a/plutus-pab/src/Plutus/PAB/Webserver/Types.hs b/plutus-pab/src/Plutus/PAB/Webserver/Types.hs
@@ -19,7 +19,6 @@ import           GHC.Generics                            (Generic)
 import           Ledger                                  (PubKeyHash, Tx, TxId)
 import           Ledger.Index                            (UtxoIndex)
 import           Ledger.Slot                             (Slot)
-import           Ledger.Value                            (Value)
 import           Playground.Types                        (FunctionSchema)
 import           Plutus.Contract.Effects                 (ActiveEndpoint, PABReq)
 import           Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse)
@@ -108,7 +107,6 @@ data InstanceStatusToClient
 data CombinedWSStreamToClient
     = InstanceUpdate ContractInstanceId InstanceStatusToClient
     | SlotChange Slot -- ^ New slot number
-    | PubKeyHashFundsChange PubKeyHash Value -- ^ The funds at the pubkeyhash address have changed
     deriving stock (Generic, Eq, Show)
     deriving anyclass (ToJSON, FromJSON)
 

diff --git a/plutus-pab/src/Plutus/PAB/Webserver/WebSocket.hs b/plutus-pab/src/Plutus/PAB/Webserver/WebSocket.hs
@@ -1,12 +1,10 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE GADTs               #-}
-{-# LANGUAGE InstanceSigs        #-}
 {-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 {-
@@ -21,7 +19,6 @@ module Plutus.PAB.Webserver.WebSocket
     -- * Reports
     , getContractReport
     -- ** Streams of PAB events
-    , pubKeyHashFundsChange
     , openEndpoints
     , slotChange
     , observableStateChange
@@ -46,7 +43,6 @@ import qualified Data.Set                                as Set
 import           Data.Text                               (Text)
 import qualified Data.Text                               as Text
 import           Ledger                                  (PubKeyHash)
-import qualified Ledger
 import           Ledger.Slot                             (Slot)
 import qualified Network.WebSockets                      as WS
 import           Network.WebSockets.Connection           (Connection, PendingConnection)
@@ -88,18 +84,12 @@ data WSState = WSState
     , wsWallets   :: STM.TVar (Set PubKeyHash) -- ^ Wallets whose funds we are watching
     }
 
-instancesAndWallets :: WSState -> STMStream (Set ContractInstanceId, Set PubKeyHash)
-instancesAndWallets WSState{wsInstances, wsWallets} =
-    (,) <$> unfold (STM.readTVar wsInstances) <*> unfold (STM.readTVar wsWallets)
-
 combinedWSStreamToClient :: WSState -> BlockchainEnv -> InstancesState -> STMStream CombinedWSStreamToClient
-combinedWSStreamToClient wsState blockchainEnv instancesState = do
-    (instances, pubKeyHashes) <- instancesAndWallets wsState
-    let mkWalletStream pubKeyHash = PubKeyHashFundsChange pubKeyHash <$> pubKeyHashFundsChange pubKeyHash blockchainEnv
-        mkInstanceStream instanceId = InstanceUpdate instanceId <$> instanceUpdates instanceId instancesState
+combinedWSStreamToClient WSState{wsInstances} blockchainEnv instancesState = do
+    instances <- unfold (STM.readTVar wsInstances)
+    let mkInstanceStream instanceId = InstanceUpdate instanceId <$> instanceUpdates instanceId instancesState
     fold
         [ SlotChange <$> slotChange blockchainEnv
-        , foldMap mkWalletStream pubKeyHashes
         , foldMap mkInstanceStream instances
         ]
 
@@ -109,11 +99,6 @@ initialWSState = WSState <$> STM.newTVar mempty <*> STM.newTVar mempty
 slotChange :: BlockchainEnv -> STMStream Slot
 slotChange = unfold . Instances.currentSlot
 
-pubKeyHashFundsChange :: PubKeyHash -> BlockchainEnv -> STMStream Ledger.Value
--- TODO: Change from 'Wallet' to 'Address' (see SCP-2208)
-pubKeyHashFundsChange pubKeyHash blockchainEnv =
-    unfold (Instances.valueAt (Ledger.pubKeyHashAddress pubKeyHash) blockchainEnv)
-
 observableStateChange :: ContractInstanceId -> InstancesState -> STMStream JSON.Value
 observableStateChange contractInstanceId instancesState =
     unfold (Instances.observableContractState contractInstanceId instancesState)