SCP-2569: Await tx status change

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

@@ -3,14 +3,15 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     PABReq(..),
     _AwaitSlotReq,
     _AwaitTimeReq,
     _CurrentSlotReq,
     _CurrentTimeReq,
-    _AwaitTxConfirmedReq,
+    _AwaitTxStatusChangeReq,
     _OwnContractInstanceIdReq,
     _OwnPublicKeyReq,
     _UtxoAtReq,
@@ -23,7 +24,8 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     _AwaitTimeResp,
     _CurrentSlotResp,
     _CurrentTimeResp,
-    _AwaitTxConfirmedResp,
+    _AwaitTxStatusChangeResp,
+    _AwaitTxStatusChangeResp',
     _OwnContractInstanceIdResp,
     _OwnPublicKeyResp,
     _UtxoAtResp,
@@ -40,31 +42,33 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     WriteBalancedTxResponse(..),
     writeBalancedTxResponse,
     ActiveEndpoint(..),
-    TxConfirmed(..)
+    TxValidity(..),
+    TxStatus(..)
     ) where
 
-import           Control.Lens                (Iso', iso, makePrisms)
-import           Data.Aeson                  (FromJSON, ToJSON)
-import qualified Data.Aeson                  as JSON
-import qualified Data.Map                    as Map
-import           Data.Text.Prettyprint.Doc   (Pretty (..), colon, indent, viaShow, vsep, (<+>))
-import           GHC.Generics                (Generic)
-import           Ledger                      (Address, PubKey, Tx, TxId, TxOutTx (..), txId)
-import           Ledger.AddressMap           (UtxoMap)
-import           Ledger.Constraints.OffChain (UnbalancedTx)
-import           Ledger.Slot                 (Slot (..))
-import           Ledger.Time                 (POSIXTime (..))
-import           Wallet.API                  (WalletAPIError)
-import           Wallet.Types                (AddressChangeRequest, AddressChangeResponse, ContractInstanceId,
-                                              EndpointDescription, EndpointValue)
+import           Control.Lens                     (Iso', Prism', iso, makePrisms, prism')
+import           Data.Aeson                       (FromJSON, ToJSON)
+import qualified Data.Aeson                       as JSON
+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.AddressMap                (UtxoMap)
+import           Ledger.Constraints.OffChain      (UnbalancedTx)
+import           Ledger.Slot                      (Slot (..))
+import           Ledger.Time                      (POSIXTime (..))
+import           Wallet.API                       (WalletAPIError)
+import           Wallet.Types                     (AddressChangeRequest, AddressChangeResponse, ContractInstanceId,
+                                                   EndpointDescription, EndpointValue)
 
 -- | Requests that 'Contract's can make
 data PABReq =
     AwaitSlotReq Slot
     | AwaitTimeReq POSIXTime
     | CurrentSlotReq
     | CurrentTimeReq
-    | AwaitTxConfirmedReq TxId
+    | AwaitTxStatusChangeReq TxId
     | OwnContractInstanceIdReq
     | OwnPublicKeyReq
     | UtxoAtReq Address
@@ -77,26 +81,26 @@ data PABReq =
 
 instance Pretty PABReq where
   pretty = \case
-    AwaitSlotReq s           -> "Await slot:" <+> pretty s
-    AwaitTimeReq s           -> "Await time:" <+> pretty s
-    CurrentSlotReq           -> "Current slot"
-    CurrentTimeReq           -> "Current time"
-    AwaitTxConfirmedReq txid -> "Await tx confirmed:" <+> pretty txid
-    OwnContractInstanceIdReq -> "Own contract instance ID"
-    OwnPublicKeyReq          -> "Own public key"
-    UtxoAtReq addr           -> "Utxo at:" <+> pretty addr
-    AddressChangeReq req     -> "Address change:" <+> pretty req
-    BalanceTxReq utx         -> "Balance tx:" <+> pretty utx
-    WriteBalancedTxReq tx    -> "Write balanced tx:" <+> pretty tx
-    ExposeEndpointReq ep     -> "Expose endpoint:" <+> pretty ep
+    AwaitSlotReq s              -> "Await slot:" <+> pretty s
+    AwaitTimeReq s              -> "Await time:" <+> pretty s
+    CurrentSlotReq              -> "Current slot"
+    CurrentTimeReq              -> "Current time"
+    AwaitTxStatusChangeReq txid -> "Await tx status change:" <+> pretty txid
+    OwnContractInstanceIdReq    -> "Own contract instance ID"
+    OwnPublicKeyReq             -> "Own public key"
+    UtxoAtReq addr              -> "Utxo at:" <+> pretty addr
+    AddressChangeReq req        -> "Address change:" <+> pretty req
+    BalanceTxReq utx            -> "Balance tx:" <+> pretty utx
+    WriteBalancedTxReq tx       -> "Write balanced tx:" <+> pretty tx
+    ExposeEndpointReq ep        -> "Expose endpoint:" <+> pretty ep
 
 -- | Responses that 'Contract's receive
 data PABResp =
     AwaitSlotResp Slot
     | AwaitTimeResp POSIXTime
     | CurrentSlotResp Slot
     | CurrentTimeResp POSIXTime
-    | AwaitTxConfirmedResp TxId
+    | AwaitTxStatusChangeResp TxId TxStatus
     | OwnContractInstanceIdResp ContractInstanceId
     | OwnPublicKeyResp PubKey
     | UtxoAtResp UtxoAtAddress
@@ -110,26 +114,26 @@ data PABResp =
 
 instance Pretty PABResp where
   pretty = \case
-    AwaitSlotResp s             -> "Slot:" <+> pretty s
-    AwaitTimeResp s             -> "Time:" <+> pretty s
-    CurrentSlotResp s           -> "Current slot:" <+> pretty s
-    CurrentTimeResp s           -> "Current time:" <+> pretty s
-    AwaitTxConfirmedResp txid   -> "Tx confirmed:" <+> pretty txid
-    OwnContractInstanceIdResp i -> "Own contract instance ID:" <+> pretty i
-    OwnPublicKeyResp k          -> "Own public key:" <+> pretty k
-    UtxoAtResp rsp              -> "Utxo at:" <+> pretty rsp
-    AddressChangeResp rsp       -> "Address change:" <+> pretty rsp
-    BalanceTxResp r             -> "Balance tx:" <+> pretty r
-    WriteBalancedTxResp r       -> "Write balanced tx:" <+> pretty r
-    ExposeEndpointResp desc rsp -> "Call endpoint" <+> pretty desc <+> "with" <+> pretty rsp
+    AwaitSlotResp s                     -> "Slot:" <+> pretty s
+    AwaitTimeResp s                     -> "Time:" <+> pretty s
+    CurrentSlotResp s                   -> "Current slot:" <+> pretty s
+    CurrentTimeResp s                   -> "Current time:" <+> pretty s
+    AwaitTxStatusChangeResp txid status -> "Status of" <+> pretty txid <+> "changed to" <+> pretty status
+    OwnContractInstanceIdResp i         -> "Own contract instance ID:" <+> pretty i
+    OwnPublicKeyResp k                  -> "Own public key:" <+> pretty k
+    UtxoAtResp rsp                      -> "Utxo at:" <+> pretty rsp
+    AddressChangeResp rsp               -> "Address change:" <+> pretty rsp
+    BalanceTxResp r                     -> "Balance tx:" <+> pretty r
+    WriteBalancedTxResp r               -> "Write balanced tx:" <+> pretty r
+    ExposeEndpointResp desc rsp         -> "Call endpoint" <+> pretty desc <+> "with" <+> pretty rsp
 
 matches :: PABReq -> PABResp -> Bool
 matches a b = case (a, b) of
   (AwaitSlotReq{}, AwaitSlotResp{})                       -> True
   (AwaitTimeReq{}, AwaitTimeResp{})                       -> True
   (CurrentSlotReq, CurrentSlotResp{})                     -> True
   (CurrentTimeReq, CurrentTimeResp{})                     -> True
-  (AwaitTxConfirmedReq{}, AwaitTxConfirmedResp{})         -> True
+  (AwaitTxStatusChangeReq i, AwaitTxStatusChangeResp i' _)         -> i == i'
   (OwnContractInstanceIdReq, OwnContractInstanceIdResp{}) -> True
   (OwnPublicKeyReq, OwnPublicKeyResp{})                   -> True
   (UtxoAtReq{}, UtxoAtResp{})                             -> True
@@ -156,6 +160,21 @@ instance Pretty UtxoAtAddress where
       utxos = vsep $ fmap prettyTxOutPair (Map.toList utxo)
     in vsep ["Utxo at" <+> pretty address <+> "=", indent 2 utxos]
 
+-- | Validity of a transaction that has been added to the ledger
+data TxValidity = TxValid | TxInvalid
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+  deriving Pretty via (PrettyShow TxValidity)
+
+-- | The status of a Cardano transaction
+data TxStatus =
+  OnChain TxValidity -- ^ The transaction is on the chain, n blocks deep. It can still be rolled back.
+  | Committed TxValidity -- ^ The transaction is on the chain. It cannot be rolled back anymore.
+  | Unknown -- ^ The transaction is not on the chain. That's all we can say.
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+  deriving Pretty via (PrettyShow TxStatus)
+
 data BalanceTxResponse =
   BalanceTxFailed WalletAPIError
   | BalanceTxSuccess Tx
@@ -167,6 +186,12 @@ instance Pretty BalanceTxResponse where
     BalanceTxFailed e  -> "BalanceTxFailed:" <+> pretty e
     BalanceTxSuccess i -> "BalanceTxSuccess:" <+> pretty (txId i)
 
+_AwaitTxStatusChangeResp' :: TxId -> Prism' PABResp TxStatus
+_AwaitTxStatusChangeResp' i =
+  prism'
+    (AwaitTxStatusChangeResp i)
+    (\case { AwaitTxStatusChangeResp i' s | i == i' -> Just s; _ -> Nothing })
+
 balanceTxResponse :: Iso' BalanceTxResponse (Either WalletAPIError Tx)
 balanceTxResponse = iso f g where
   f = \case { BalanceTxFailed w -> Left w; BalanceTxSuccess t -> Right t }
@@ -202,12 +227,6 @@ instance Pretty ActiveEndpoint where
       , "Metadata:" <+> viaShow aeMetadata
       ]
 
-newtype TxConfirmed =
-    TxConfirmed { unTxConfirmed :: TxId }
-        deriving stock (Eq, Ord, Generic, Show)
-        deriving anyclass (ToJSON, FromJSON)
-        deriving Pretty via TxId
-
 makePrisms ''PABReq
 
 makePrisms ''PABResp

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

@@ -33,6 +33,8 @@ module Plutus.Contract.Request(
     , watchAddressUntilSlot
     , watchAddressUntilTime
     -- ** Tx confirmation
+    , TxStatus(..)
+    , awaitTxStatusChange
     , awaitTxConfirmed
     -- ** Contract instances
     , ownInstanceId
@@ -63,7 +65,6 @@ module Plutus.Contract.Request(
 
 import           Control.Applicative
 import           Control.Lens                (Prism', preview, review, view)
-import           Control.Monad               (void)
 import qualified Control.Monad.Freer.Error   as E
 import           Data.Aeson                  (FromJSON, ToJSON)
 import qualified Data.Aeson                  as JSON
@@ -86,7 +87,8 @@ import qualified Ledger.Value                as V
 import           Plutus.Contract.Util        (loopM)
 import qualified PlutusTx
 
-import           Plutus.Contract.Effects     (ActiveEndpoint (..), PABReq (..), PABResp (..), UtxoAtAddress (..))
+import           Plutus.Contract.Effects     (ActiveEndpoint (..), PABReq (..), PABResp (..), TxStatus (..),
+                                              UtxoAtAddress (..))
 import qualified Plutus.Contract.Effects     as E
 import           Plutus.Contract.Schema      (Input, Output)
 import           Wallet.Types                (AddressChangeRequest (..), AddressChangeResponse (..), ContractInstanceId,
@@ -292,11 +294,22 @@ fundsAtAddressGeq
 fundsAtAddressGeq addr vl =
     fundsAtAddressCondition (\presentVal -> presentVal `V.geq` vl) addr
 
+-- | Wait for the status of a transaction to change
+awaitTxStatusChange :: forall w s e. AsContractError e => TxId -> Contract w s e TxStatus
+awaitTxStatusChange i = pabReq (AwaitTxStatusChangeReq i) (E._AwaitTxStatusChangeResp' i)
+
 -- TODO: Configurable level of confirmation (for example, as soon as the tx is
 --       included in a block, or only when it can't be rolled back anymore)
 -- | Wait until a transaction is confirmed (added to the ledger).
+--   If the transaction is never added to the ledger then 'awaitTxConfirmed' never
+--   returns
 awaitTxConfirmed :: forall w s e. (AsContractError e) => TxId -> Contract w s e ()
-awaitTxConfirmed i = void $ pabReq (AwaitTxConfirmedReq i) E._AwaitTxConfirmedResp
+awaitTxConfirmed i = go where
+  go = do
+    newStatus <- awaitTxStatusChange i
+    case newStatus of
+      Unknown -> go
+      _       -> pure ()
 
 -- | Get the 'ContractInstanceId' of this instance.
 ownInstanceId :: forall w s e. (AsContractError e) => Contract w s e ContractInstanceId

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

@@ -33,7 +33,6 @@ module Plutus.Contract.Trace
     , handleUnbalancedTransactions
     , handlePendingTransactions
     , handleUtxoQueries
-    , handleTxConfirmedQueries
     , handleAddressChangedAtQueries
     , handleOwnInstanceIdQueries
     -- * Initial distributions of emulated chains
@@ -151,7 +150,6 @@ handleBlockchainQueries =
     handleUnbalancedTransactions
     <> handlePendingTransactions
     <> handleUtxoQueries
-    <> handleTxConfirmedQueries
     <> handleOwnPubKeyQueries
     <> handleAddressChangedAtQueries
     <> handleOwnInstanceIdQueries
@@ -199,14 +197,6 @@ handleUtxoQueries ::
 handleUtxoQueries =
     generalise (preview E._UtxoAtReq) E.UtxoAtResp RequestHandler.handleUtxoQueries
 
-handleTxConfirmedQueries ::
-    ( Member (LogObserve (LogMessage Text)) effs
-    , Member ChainIndexEffect effs
-    )
-    => RequestHandler effs PABReq PABResp
-handleTxConfirmedQueries =
-    generalise (preview E._AwaitTxConfirmedReq) (E.AwaitTxConfirmedResp . E.unTxConfirmed) RequestHandler.handleTxConfirmedQueries
-
 handleAddressChangedAtQueries ::
     ( Member (LogObserve (LogMessage Text)) effs
     , Member (LogMsg RequestHandlerLogMsg) effs

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

@@ -25,7 +25,6 @@ module Plutus.Contract.Trace.RequestHandler(
     , handleUnbalancedTransactions
     , handlePendingTransactions
     , handleUtxoQueries
-    , handleTxConfirmedQueries
     , handleAddressChangedAtQueries
     , handleOwnInstanceIdQueries
     , handleContractNotifications
@@ -51,11 +50,11 @@ import qualified Ledger.AddressMap              as AM
 import           Plutus.Contract.Resumable      (Request (..), Response (..))
 
 import           Control.Monad.Freer.Extras.Log (LogMessage, LogMsg, LogObserve, logDebug, logWarn, surroundDebug)
-import           Ledger                         (Address, OnChainTx (Valid), POSIXTime, PubKey, Slot, Tx, TxId)
+import           Ledger                         (Address, OnChainTx (Valid), POSIXTime, PubKey, Slot, Tx)
 import           Ledger.AddressMap              (AddressMap (..))
 import           Ledger.Constraints.OffChain    (UnbalancedTx)
 import qualified Ledger.TimeSlot                as TimeSlot
-import           Plutus.Contract.Effects        (TxConfirmed (..), UtxoAtAddress (..))
+import           Plutus.Contract.Effects        (UtxoAtAddress (..))
 import qualified Plutus.Contract.Wallet         as Wallet
 import           Wallet.API                     (WalletAPIError)
 import           Wallet.Effects                 (ChainIndexEffect, ContractRuntimeEffect, NodeClientEffect,
@@ -224,18 +223,6 @@ handleUtxoQueries = RequestHandler $ \addr ->
                 empty
             Just s  -> pure (UtxoAtAddress addr s)
 
-handleTxConfirmedQueries ::
-    forall effs.
-    ( Member (LogObserve (LogMessage Text)) effs
-    , Member ChainIndexEffect effs
-    )
-    => RequestHandler effs TxId TxConfirmed
-handleTxConfirmedQueries = RequestHandler $ \txid ->
-    surroundDebug @Text "handleTxConfirmedQueries" $ do
-        conf <- Wallet.Effects.transactionConfirmed txid
-        guard conf
-        pure (TxConfirmed txid)
-
 handleAddressChangedAtQueries ::
     forall effs.
     ( Member (LogObserve (LogMessage Text)) effs

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

@@ -31,7 +31,7 @@ module Plutus.Trace.Emulator.ContractInstance(
     ) where
 
 import           Control.Lens
-import           Control.Monad                        (guard, unless, void, when)
+import           Control.Monad                        (guard, join, unless, void, when)
 import           Control.Monad.Freer
 import           Control.Monad.Freer.Coroutine        (Yield)
 import           Control.Monad.Freer.Error            (Error, throwError)
@@ -43,9 +43,15 @@ import           Control.Monad.Freer.State            (State, evalState, get, ge
 import           Data.Aeson                           (object)
 import qualified Data.Aeson                           as JSON
 import           Data.Foldable                        (traverse_)
+import qualified Data.Map                             as Map
+import           Data.Maybe                           (listToMaybe, mapMaybe)
 import qualified Data.Text                            as T
+import           Ledger.Blockchain                    (OnChainTx (..))
+import           Ledger.Tx                            (txId)
 import           Plutus.Contract                      (Contract (..))
-import           Plutus.Contract.Effects              (PABReq, PABResp, matches)
+import           Plutus.Contract.Effects              (PABReq, PABResp (AwaitTxStatusChangeResp), TxValidity (..),
+                                                       matches)
+import qualified Plutus.Contract.Effects              as E
 import           Plutus.Contract.Resumable            (Request (..), Response (..))
 import qualified Plutus.Contract.Resumable            as State
 import           Plutus.Contract.Trace                (handleBlockchainQueries)
@@ -192,6 +198,10 @@ runInstance contract event = do
             Just (ContractInstanceStateRequest sender) -> do
                 handleObservableStateRequest sender
                 mkAgentSysCall Normal WaitForMessage >>= runInstance contract
+            Just (NewSlot block _) -> do
+                processNewTransactions @w @s @e (join block)
+                -- mkAgentSysCall Normal WaitForMessage >>= runInstance contract
+                runInstance contract Nothing
             _ -> waitForNextMessage True >>= runInstance contract
 
 -- | Run an instance to only answer to observable state requests even when the
@@ -272,6 +282,31 @@ decodeEvent vl =
 getHooks :: forall w s e effs. Member (State (ContractInstanceStateInternal w s e ())) effs => Eff effs [Request PABReq]
 getHooks = gets @(ContractInstanceStateInternal w s e ()) (State.unRequests . view requests . view resumableResult . cisiSuspState)
 
+-- | Update the contract instance with tx status information from the new block.
+processNewTransactions ::
+    forall w s e effs.
+    ( Member (State (ContractInstanceStateInternal w s e ())) effs
+    , Member (LogMsg ContractInstanceMsg) effs
+    , Monoid w
+    )
+    => [OnChainTx]
+    -> Eff effs ()
+processNewTransactions txns = do
+    -- Check whether the contract instance is waiting for a status change of any
+    -- of the new transactions. If that is the case, call 'addResponse' to send the
+    -- response.
+    let txWithStatus (Invalid tx) = (txId tx, TxInvalid)
+        txWithStatus (Valid tx)   = (txId tx, TxValid)
+        statusMap = Map.fromList $ fmap txWithStatus txns
+    hks <- mapMaybe (traverse (preview E._AwaitTxStatusChangeReq)) <$> getHooks @w @s @e
+    let mpReq Request{rqID, itID, rqRequest=txid} =
+            case Map.lookup txid statusMap of
+                Nothing -> Nothing
+                Just newStatus -> Just Response{rspRqID=rqID, rspItID=itID, rspResponse=AwaitTxStatusChangeResp txid (E.OnChain newStatus)}
+        txStatusHk = listToMaybe $ mapMaybe mpReq hks
+    traverse_ (addResponse @w @s @e) txStatusHk
+    logResponse @w @s @e txStatusHk
+
 -- | Add a 'Response' to the contract instance state
 addResponse
     :: forall w s e effs.