SCP-2569: Await tx status change

playground-common/src/PSGenerator/Common.hs

@@ -36,8 +36,9 @@ import           Ledger.Typed.Tx                           (ConnectionError, Wro
 import           Ledger.Value                              (AssetClass, CurrencySymbol, TokenName, Value)
 import           Playground.Types                          (ContractCall, FunctionSchema, KnownCurrency)
 import           Plutus.Contract.Checkpoint                (CheckpointError)
-import           Plutus.Contract.Effects                   (ActiveEndpoint, BalanceTxResponse, PABReq, PABResp,
-                                                            UtxoAtAddress, WriteBalancedTxResponse)
+import           Plutus.Contract.Effects                   (ActiveEndpoint, BalanceTxResponse, Depth, PABReq, PABResp,
+                                                            TxStatus, TxValidity, UtxoAtAddress,
+                                                            WriteBalancedTxResponse)
 import           Plutus.Contract.Resumable                 (IterationID, Request, RequestID, Response)
 import           Plutus.Trace.Emulator.Types               (ContractInstanceLog, ContractInstanceMsg,
                                                             ContractInstanceTag, EmulatorRuntimeError, UserThreadMsg)
@@ -335,6 +336,9 @@ ledgerTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @UtxoAtAddress)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @ActiveEndpoint)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @UnbalancedTx)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxValidity)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxStatus)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @Depth)
     ]
 
 walletTypes :: [SumType 'Haskell]

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

@@ -46,7 +46,8 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     TxStatus(..),
     Depth(..),
     isConfirmed,
-    increaseDepth
+    increaseDepth,
+    initialStatus
     ) where
 
 import           Control.Lens                     (Iso', Prism', iso, makePrisms, prism')
@@ -56,7 +57,7 @@ import qualified Data.Map                         as Map
 import           Data.Text.Prettyprint.Doc        (Pretty (..), colon, indent, viaShow, vsep, (<+>))
 import           Data.Text.Prettyprint.Doc.Extras (PrettyShow (..))
 import           GHC.Generics                     (Generic)
-import           Ledger                           (Address, PubKey, Tx, TxId, TxOutTx (..), txId)
+import           Ledger                           (Address, OnChainTx, PubKey, Tx, TxId, TxOutTx (..), eitherTx, txId)
 import           Ledger.AddressMap                (UtxoMap)
 import           Ledger.Constraints.OffChain      (UnbalancedTx)
 import           Ledger.Slot                      (Slot (..))
@@ -185,7 +186,7 @@ The initial state after submitting the transaction is Unknown.
 
 -- | How many blocks deep the tx is on the chain
 newtype Depth = Depth Int
-    deriving stock (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show, Generic)
     deriving newtype (Num, Real, Enum, Integral, Pretty, ToJSON, FromJSON)
 
 -- | The status of a Cardano transaction
@@ -197,6 +198,11 @@ data TxStatus =
   deriving anyclass (ToJSON, FromJSON)
   deriving Pretty via (PrettyShow TxStatus)
 
+-- | The 'TxStatus' of a transaction right after it was added to the chain
+initialStatus :: OnChainTx -> TxStatus
+initialStatus =
+  TentativelyConfirmed 0 . eitherTx (const TxInvalid) (const TxValid)
+
 -- | Whether a 'TxStatus' counts as confirmed given the minimum depth
 isConfirmed :: Depth -> TxStatus -> Bool
 isConfirmed minDepth = \case

plutus-pab/src/Cardano/ChainIndex/Server.hs

@@ -48,7 +48,7 @@ app trace stateVar =
     hoistServer
         (Proxy @API)
         (liftIO . processIndexEffects trace stateVar)
-        (healthcheck :<|> startWatching :<|> watchedAddresses :<|> confirmedBlocks :<|> WalletEffects.transactionConfirmed :<|> WalletEffects.addressChanged)
+        (healthcheck :<|> startWatching :<|> watchedAddresses :<|> confirmedBlocks :<|> WalletEffects.addressChanged)
 
 main :: ChainIndexTrace -> ChainIndexConfig -> FilePath -> SlotConfig -> Availability -> IO ()
 main trace ChainIndexConfig{ciBaseUrl} socketPath slotConfig availability = runLogEffects trace $ do

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

@@ -56,7 +56,7 @@ module Plutus.PAB.Core
     , instanceState
     , observableState
     , waitForState
-    , waitForTxConfirmed
+    , waitForTxStatusChange
     , activeEndpoints
     , waitForEndpoint
     , currentSlot
@@ -103,7 +103,7 @@ import           Data.Text                               (Text)
 import           Ledger.Tx                               (Address, Tx)
 import           Ledger.TxId                             (TxId)
 import           Ledger.Value                            (Value)
-import           Plutus.Contract.Effects                 (ActiveEndpoint (..), PABReq, TxConfirmed)
+import           Plutus.Contract.Effects                 (ActiveEndpoint (..), PABReq, TxStatus (Unknown))
 import           Plutus.PAB.Core.ContractInstance        (ContractInstanceMsg, ContractInstanceState)
 import qualified Plutus.PAB.Core.ContractInstance        as ContractInstance
 import           Plutus.PAB.Core.ContractInstance.STM    (Activity (Active), BlockchainEnv, InstancesState,
@@ -473,10 +473,10 @@ waitForState extract instanceId = do
         maybe STM.retry pure (extract state)
 
 -- | Wait for the transaction to be confirmed on the blockchain.
-waitForTxConfirmed :: forall t env. TxId -> PABAction t env TxConfirmed
-waitForTxConfirmed t = do
+waitForTxStatusChange :: forall t env. TxId -> PABAction t env TxStatus
+waitForTxStatusChange t = do
     env <- asks @(PABEnvironment t env) blockchainEnv
-    liftIO $ STM.atomically $ Instances.waitForTxConfirmed t env
+    liftIO $ STM.atomically $ Instances.waitForTxStatusChange Unknown t env
 
 -- | The list of endpoints that are currently open
 activeEndpoints :: forall t env. ContractInstanceId -> PABAction t env (STM [OpenEndpoint])

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

@@ -44,7 +44,8 @@ import           Data.Aeson                                       (Value)
 import           Data.Proxy                                       (Proxy (..))
 import qualified Data.Text                                        as Text
 
-import           Plutus.Contract.Effects                          (ActiveEndpoint (..), PABReq (..), PABResp (..))
+import           Plutus.Contract.Effects                          (ActiveEndpoint (..), PABReq (..), PABResp (..),
+                                                                   TxStatus (Unknown))
 import qualified Plutus.Contract.Effects                          as Contract.Effects
 import           Plutus.Contract.Resumable                        (Request (..), Response (..))
 import           Plutus.Contract.State                            (ContractResponse (..), State (..))
@@ -147,18 +148,18 @@ processAwaitSlotRequestsSTM =
     maybeToHandler (extract Contract.Effects._AwaitSlotReq)
     >>> (RequestHandler $ \targetSlot_ -> fmap AwaitSlotResp . InstanceState.awaitSlot targetSlot_ <$> ask)
 
-processTxConfirmedRequestsSTM ::
+processTxStatusChangeRequestsSTM ::
     forall effs.
     ( Member (Reader BlockchainEnv) effs
     )
     => RequestHandler effs PABReq (STM PABResp)
-processTxConfirmedRequestsSTM =
+processTxStatusChangeRequestsSTM =
     maybeToHandler (extract Contract.Effects._AwaitTxStatusChangeReq)
     >>> RequestHandler handler
     where
-        handler req = do
+        handler txId = do
             env <- ask
-            pure (AwaitTxConfirmedResp . unTxConfirmed <$> InstanceState.waitForTxConfirmed req env)
+            pure (AwaitTxStatusChangeResp txId <$> InstanceState.waitForTxStatusChange Unknown txId env)
 
 processEndpointRequestsSTM ::
     forall effs.
@@ -190,15 +191,14 @@ stmRequestHandler = fmap sequence (wrapHandler (fmap pure nonBlockingRequests) <
         <> RequestHandler.handleUtxoQueries @effs
         <> RequestHandler.handleUnbalancedTransactions @effs
         <> RequestHandler.handlePendingTransactions @effs
-        <> RequestHandler.handleTxConfirmedQueries @effs -- FIXME: Handle with waiting
         <> RequestHandler.handleOwnInstanceIdQueries @effs
         <> RequestHandler.handleAddressChangedAtQueries @effs
         <> RequestHandler.handleCurrentSlotQueries @effs
 
     -- requests that wait for changes to happen
     blockingRequests =
         wrapHandler (processAwaitSlotRequestsSTM @effs)
-        <> wrapHandler (processTxConfirmedRequestsSTM @effs)
+        <> wrapHandler (processTxStatusChangeRequestsSTM @effs)
         <> processEndpointRequestsSTM @effs
 
 -- | Start the thread for the contract instance
@@ -305,7 +305,7 @@ updateState ContractResponse{newState = State{observableState}, hooks} = do
         InstanceState.clearEndpoints state
         forM_ hooks $ \r -> do
             case rqRequest r of
-                AwaitTxConfirmedReq txid -> InstanceState.addTransaction txid state
+                AwaitTxStatusChangeReq txid -> InstanceState.addTransaction txid state
                 UtxoAtReq addr -> InstanceState.addAddress addr state
                 AddressChangeReq AddressChangeRequest{acreqAddress} -> InstanceState.addAddress acreqAddress state
                 ExposeEndpointReq endpoint -> InstanceState.addEndpoint (r { rqRequest = endpoint}) state

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

@@ -15,14 +15,14 @@ import qualified Cardano.Protocol.Socket.Mock.Client  as Client
 import           Ledger                               (Address, Block, OnChainTx, Slot, TxId, eitherTx, txId)
 import           Ledger.AddressMap                    (AddressMap)
 import qualified Ledger.AddressMap                    as AddressMap
-import           Plutus.PAB.Core.ContractInstance.STM (BlockchainEnv (..), InstancesState, TxStatus (..),
-                                                       emptyBlockchainEnv)
+import           Plutus.Contract.Effects              (TxStatus (..), increaseDepth, initialStatus)
+import           Plutus.PAB.Core.ContractInstance.STM (BlockchainEnv (..), InstancesState, emptyBlockchainEnv)
 import qualified Plutus.PAB.Core.ContractInstance.STM as S
 
 import           Control.Concurrent.STM               (STM)
 import qualified Control.Concurrent.STM               as STM
 import           Control.Lens
-import           Control.Monad                        (unless, when)
+import           Control.Monad                        (foldM, forM_, unless, when)
 import           Data.Foldable                        (foldl')
 import           Data.Map                             (Map)
 import           Data.Set                             (Set)
@@ -56,25 +56,33 @@ getClientEnv instancesState =
 --   when any interesting addresses or transactions have changed.
 processBlock :: BlockchainEnv -> Block -> Slot -> STM ()
 processBlock BlockchainEnv{beAddressMap, beTxChanges, beCurrentSlot, beTxIndex} transactions slot = do
+  changes <- STM.readTVar beTxChanges
+  forM_ changes $ \tv -> STM.modifyTVar tv increaseDepth
   lastSlot <- STM.readTVar beCurrentSlot
   when (slot > lastSlot) $ do
-    STM.modifyTVar beTxChanges (fmap S.increaseDepth)
     STM.writeTVar beCurrentSlot slot
   unless (null transactions) $ do
     addressMap <- STM.readTVar beAddressMap
     chainIndex <- STM.readTVar beTxIndex
-    txStatusMap <- STM.readTVar beTxChanges
-    let (addressMap', txStatusMap', chainIndex') = foldl' (processTx slot) (addressMap, txStatusMap, chainIndex) transactions
+    let (addressMap', chainIndex') = foldl' (processTx slot) (addressMap, chainIndex) transactions
     STM.writeTVar beAddressMap addressMap'
-    STM.writeTVar beTxChanges txStatusMap'
     STM.writeTVar beTxIndex chainIndex'
 
+    txStatusMap <- STM.readTVar beTxChanges
+    txStatusMap' <- foldM insertNewTx txStatusMap transactions
+    STM.writeTVar beTxChanges txStatusMap'
+
+insertNewTx :: Map TxId (STM.TVar TxStatus) -> OnChainTx -> STM (Map TxId (STM.TVar TxStatus))
+insertNewTx mp tx = do
+  tv <- STM.newTVar (initialStatus tx)
+  let tid = eitherTx txId txId tx
+  pure $ mp & at tid ?~ tv
 
-processTx :: Slot -> (AddressMap, Map TxId TxStatus, ChainIndex) -> OnChainTx -> (AddressMap, Map TxId TxStatus, ChainIndex)
-processTx currentSlot (addressMap, txStatusMap, chainIndex) tx = (addressMap', txStatusMap', chainIndex') where
+processTx :: Slot -> (AddressMap, ChainIndex) -> OnChainTx -> (AddressMap, ChainIndex)
+processTx currentSlot (addressMap, chainIndex) tx = (addressMap', chainIndex') where
   tid = eitherTx txId txId tx
   addressMap' = AddressMap.updateAllAddresses tx addressMap
   chainIndex' =
     let itm = ChainIndexItem{ciSlot = currentSlot, ciTx = tx, ciTxId = tid } in
     Index.insert addressMap' itm chainIndex
-  txStatusMap' = txStatusMap & at tid .~ Just (TentativelyConfirmed 0)
+  -- txStatusMap' = txStatusMap & at tid .~ Just (TentativelyConfirmed 0)

plutus-pab/src/Plutus/PAB/Run/PSGenerator.hs

@@ -36,7 +36,6 @@ import           Language.PureScript.Bridge.CodeGenSwitches (ForeignOptions (For
 import           Language.PureScript.Bridge.TypeParameters  (A)
 import qualified PSGenerator.Common
 import           Plutus.Contract.Checkpoint                 (CheckpointKey, CheckpointStore, CheckpointStoreItem)
-import           Plutus.Contract.Effects                    (TxConfirmed)
 import           Plutus.Contract.Resumable                  (Responses)
 import           Plutus.PAB.Effects.Contract.Builtin        (Builtin)
 import           Plutus.PAB.Events.ContractInstanceState    (PartiallyDecodedResponse)
@@ -104,7 +103,6 @@ pabTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(PartiallyDecodedResponse A))
 
     -- Contract request / response types
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxConfirmed)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @CheckpointStore)
     , (order <*> (genericShow <*> mkSumType)) (Proxy @CheckpointKey)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(CheckpointStoreItem A))

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

@@ -47,7 +47,7 @@ module Plutus.PAB.Simulator(
     , waitForState
     , activeEndpoints
     , waitForEndpoint
-    , waitForTxConfirmed
+    , waitForTxStatusChange
     , currentSlot
     , waitUntilSlot
     , waitNSlots
@@ -106,7 +106,7 @@ import           Ledger.Crypto                                  (PubKey, pubKeyH
 import           Ledger.Fee                                     (FeeConfig)
 import qualified Ledger.Index                                   as UtxoIndex
 import           Ledger.Value                                   (Value, flattenValue)
-import           Plutus.Contract.Effects                        (TxConfirmed)
+import           Plutus.Contract.Effects                        (TxStatus)
 import           Plutus.PAB.Core                                (EffectHandlers (..))
 import qualified Plutus.PAB.Core                                as Core
 import qualified Plutus.PAB.Core.ContractInstance.BlockchainEnv as BlockchainEnv
@@ -384,9 +384,9 @@ finalResult = Core.finalResult
 waitUntilFinished :: forall t. ContractInstanceId -> Simulation t (Maybe JSON.Value)
 waitUntilFinished = Core.waitUntilFinished
 
--- | Wait until the transaction has been confirmed on the blockchain.
-waitForTxConfirmed :: forall t. TxId -> Simulation t TxConfirmed
-waitForTxConfirmed = Core.waitForTxConfirmed
+-- | Wait until the status of the transaction changes
+waitForTxStatusChange :: forall t. TxId -> Simulation t TxStatus
+waitForTxStatusChange = Core.waitForTxStatusChange
 
 -- | Wait until the endpoint becomes active.
 waitForEndpoint :: forall t. ContractInstanceId -> String -> Simulation t ()
@@ -542,11 +542,10 @@ handleChainIndexEffect ::
     => ChainIndexEffect
     ~> Eff effs
 handleChainIndexEffect = runChainIndexEffects @t . \case
-    StartWatching a           -> WalletEffects.startWatching a
-    WatchedAddresses          -> WalletEffects.watchedAddresses
-    ConfirmedBlocks           -> WalletEffects.confirmedBlocks
-    TransactionConfirmed txid -> WalletEffects.transactionConfirmed txid
-    AddressChanged r          -> WalletEffects.addressChanged r
+    StartWatching a  -> WalletEffects.startWatching a
+    WatchedAddresses -> WalletEffects.watchedAddresses
+    ConfirmedBlocks  -> WalletEffects.confirmedBlocks
+    AddressChanged r -> WalletEffects.addressChanged r
 
 handleChainIndexControlEffect ::
     forall t effs.