SCP-2460: Better waiting; WIP

plutus-contract/plutus-contract.cabal

@@ -30,7 +30,7 @@ common lang
 flag defer-plugin-errors
     description:
         Defer errors from the plugin, useful for things like Haddock that can't handle it.
-    default: False
+    default: True
     manual: True
 
 library

plutus-contract/src/Plutus/Contract.hs

@@ -29,10 +29,10 @@ module Plutus.Contract(
     , Request.endpointWithMeta
     , Schema.EmptySchema
     -- * Blockchain events
-    , Wallet.Types.AddressChangeRequest(..)
-    , Wallet.Types.AddressChangeResponse(..)
-    , Request.addressChangeRequest
-    , Request.nextTransactionsAt
+    , Request.awaitTxOutSpent
+    , Request.awaitUtxoProduced
+    , Request.TxStatus(..)
+    , Request.awaitTxStatusChange
     , Request.watchAddressUntilSlot
     , Request.watchAddressUntilTime
     , Request.fundsAtAddressGt
@@ -59,8 +59,6 @@ module Plutus.Contract(
     , Request.balanceTx
     -- ** Creating transactions
     , module Tx
-    -- ** Tx confirmation
-    , Request.awaitTxConfirmed
     -- * Checkpoints
     , checkpoint
     , checkpointLoop

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

@@ -10,11 +10,12 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     _AwaitTimeReq,
     _CurrentSlotReq,
     _CurrentTimeReq,
-    _AwaitTxConfirmedReq,
+    _AwaitTxStatusChangeReq,
     _OwnContractInstanceIdReq,
     _OwnPublicKeyReq,
     _UtxoAtReq,
-    _AddressChangeReq,
+    _AwaitUtxoSpentReq,
+    _AwaitUtxoProducedReq,
     _BalanceTxReq,
     _WriteBalancedTxReq,
     _ExposeEndpointReq,
@@ -23,11 +24,12 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     _AwaitTimeResp,
     _CurrentSlotResp,
     _CurrentTimeResp,
-    _AwaitTxConfirmedResp,
+    _AwaitTxStatusChangeResp,
     _OwnContractInstanceIdResp,
     _OwnPublicKeyResp,
     _UtxoAtResp,
-    _AddressChangeResp,
+    _AwaitUtxoSpentResp,
+    _AwaitUtxoProducedResp,
     _BalanceTxResp,
     _WriteBalancedTxResp,
     _ExposeEndpointResp,
@@ -40,35 +42,36 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     WriteBalancedTxResponse(..),
     writeBalancedTxResponse,
     ActiveEndpoint(..),
-    TxConfirmed(..)
+    TxConfirmed(..),
+    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           Data.Text.Prettyprint.Doc   (Pretty (..), colon, indent, parens, viaShow, vsep, (<+>))
 import           GHC.Generics                (Generic)
-import           Ledger                      (Address, PubKey, Tx, TxId, TxOutTx (..), txId)
+import           Ledger                      (Address, OnChainTx, PubKey, Tx, TxId, TxOutRef, 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           Wallet.Types                (ContractInstanceId, EndpointDescription, EndpointValue)
 
 -- | Requests that 'Contract's can make
 data PABReq =
     AwaitSlotReq Slot
     | AwaitTimeReq POSIXTime
+    | AwaitUtxoSpentReq TxOutRef
+    | AwaitUtxoProducedReq Address
+    | AwaitTxStatusChangeReq TxId
     | CurrentSlotReq
     | CurrentTimeReq
-    | AwaitTxConfirmedReq TxId
     | OwnContractInstanceIdReq
     | OwnPublicKeyReq
     | UtxoAtReq Address
-    | AddressChangeReq AddressChangeRequest
     | BalanceTxReq UnbalancedTx
     | WriteBalancedTxReq Tx
     | ExposeEndpointReq ActiveEndpoint
@@ -77,30 +80,32 @@ 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
+    AwaitUtxoSpentReq utxo      -> "Await utxo spent:" <+> pretty utxo
+    AwaitUtxoProducedReq a      -> "Await utxo produced:" <+> pretty a
+    AwaitTxStatusChangeReq txid -> "Await tx status change:" <+> pretty txid
+    CurrentSlotReq              -> "Current slot"
+    CurrentTimeReq              -> "Current time"
+    OwnContractInstanceIdReq    -> "Own contract instance ID"
+    OwnPublicKeyReq             -> "Own public key"
+    UtxoAtReq addr              -> "Utxo at:" <+> pretty addr
+    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
+    | AwaitUtxoSpentResp OnChainTx
+    | AwaitUtxoProducedResp [OnChainTx]
+    | AwaitTxStatusChangeResp TxStatus
     | CurrentSlotResp Slot
     | CurrentTimeResp POSIXTime
-    | AwaitTxConfirmedResp TxId
     | OwnContractInstanceIdResp ContractInstanceId
     | OwnPublicKeyResp PubKey
     | UtxoAtResp UtxoAtAddress
-    | AddressChangeResp AddressChangeResponse
     | BalanceTxResp BalanceTxResponse
     | WriteBalancedTxResp WriteBalancedTxResponse
     | ExposeEndpointResp EndpointDescription (EndpointValue JSON.Value)
@@ -110,30 +115,32 @@ 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
+    AwaitUtxoSpentResp utxo      -> "Utxo spent:" <+> pretty utxo
+    AwaitUtxoProducedResp addr   -> "Utxo produced:" <+> pretty addr
+    AwaitTxStatusChangeResp txid -> "Tx confirmed:" <+> pretty txid
+    CurrentSlotResp s            -> "Current slot:" <+> pretty s
+    CurrentTimeResp s            -> "Current time:" <+> pretty s
+    OwnContractInstanceIdResp i  -> "Own contract instance ID:" <+> pretty i
+    OwnPublicKeyResp k           -> "Own public key:" <+> pretty k
+    UtxoAtResp rsp               -> "Utxo at:" <+> 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
+  (AwaitUtxoSpentReq{}, AwaitUtxoSpentResp{})                       -> True
+  (AwaitUtxoProducedReq{}, AwaitUtxoProducedResp{})                -> True
+  (AwaitTxStatusChangeReq{}, AwaitTxStatusChangeResp{})         -> True
   (CurrentSlotReq, CurrentSlotResp{})                     -> True
   (CurrentTimeReq, CurrentTimeResp{})                     -> True
-  (AwaitTxConfirmedReq{}, AwaitTxConfirmedResp{})         -> True
   (OwnContractInstanceIdReq, OwnContractInstanceIdResp{}) -> True
   (OwnPublicKeyReq, OwnPublicKeyResp{})                   -> True
   (UtxoAtReq{}, UtxoAtResp{})                             -> True
-  (AddressChangeReq{}, AddressChangeResp{})               -> True
   (BalanceTxReq{}, BalanceTxResp{})                       -> True
   (WriteBalancedTxReq{}, WriteBalancedTxResp{})           -> True
   (ExposeEndpointReq ActiveEndpoint{aeDescription}, ExposeEndpointResp desc _)
@@ -156,6 +163,19 @@ instance Pretty UtxoAtAddress where
       utxos = vsep $ fmap prettyTxOutPair (Map.toList utxo)
     in vsep ["Utxo at" <+> pretty address <+> "=", indent 2 utxos]
 
+-- | The status of a Cardano transaction
+data TxStatus =
+  OnChain Int -- ^ The transaction is on the chain, n blocks deep. It can still be rolled back.
+  | Committed -- ^ The transaction is on the chain. It cannot 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)
+
+instance Pretty TxStatus where
+  pretty = \case
+    OnChain i -> "OnChain" <+> parens (pretty i <+> "blocks deep")
+    e         -> viaShow e
+
 data BalanceTxResponse =
   BalanceTxFailed WalletAPIError
   | BalanceTxSuccess Tx

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

@@ -25,15 +25,16 @@ module Plutus.Contract.Request(
     -- ** Querying the UTXO set
     , utxoAt
     -- ** Waiting for changes to the UTXO set
-    , addressChangeRequest
-    , nextTransactionsAt
+    , awaitTxOutSpent
+    , awaitUtxoProduced
     , fundsAtAddressGt
     , fundsAtAddressGeq
     , fundsAtAddressCondition
     , watchAddressUntilSlot
     , watchAddressUntilTime
-    -- ** Tx confirmation
-    , awaitTxConfirmed
+    -- ** Tx status
+    , TxStatus(..)
+    , awaitTxStatusChange
     -- ** Contract instances
     , ownInstanceId
     -- ** Exposing endpoints
@@ -76,7 +77,7 @@ import           Data.Void                   (Void)
 import           GHC.Natural                 (Natural)
 import           GHC.TypeLits                (Symbol, symbolVal)
 import           Ledger                      (Address, DiffMilliSeconds, OnChainTx (..), POSIXTime, PubKey, Slot, Tx,
-                                              TxId, TxOut (..), TxOutTx (..), Value, fromMilliSeconds, txId)
+                                              TxId, TxOut (..), TxOutRef, TxOutTx (..), Value, fromMilliSeconds, txId)
 import           Ledger.AddressMap           (UtxoMap)
 import           Ledger.Constraints          (TxConstraints)
 import           Ledger.Constraints.OffChain (ScriptLookups, UnbalancedTx)
@@ -86,11 +87,11 @@ 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,
-                                              EndpointDescription (..), EndpointValue (..), targetSlot)
+import           Wallet.Types                (ContractInstanceId, EndpointDescription (..), EndpointValue (..))
 
 import           Plutus.Contract.Resumable
 import           Plutus.Contract.Types
@@ -218,37 +219,25 @@ watchAddressUntilTime ::
     -> Contract w s e UtxoMap
 watchAddressUntilTime a time = awaitTime time >> utxoAt a
 
-{-| Get the transactions that modified an address in a specific slot.
+{-| Wait until the UTXO has been spent, returning the transaction that spends it.
 -}
-addressChangeRequest ::
-    forall w s e.
-    ( AsContractError e
-    )
-    => AddressChangeRequest
-    -> Contract w s e AddressChangeResponse
-addressChangeRequest r = do
-  _ <- awaitSlot (targetSlot r)
-  pabReq (AddressChangeReq r) E._AddressChangeResp
-
--- | Call 'addresssChangeRequest' for the address in each slot, until at least one
---   transaction is returned that modifies the address.
-nextTransactionsAt ::
-    forall w s e.
-    ( AsContractError e
-    )
-    => Address
-    -> Contract w s e [OnChainTx]
-nextTransactionsAt addr = do
-    initial <- currentSlot
-    let go :: Slot -> Contract w s ContractError (Either [OnChainTx] Slot)
-        go sl = do
-            let request = AddressChangeRequest{acreqSlotRangeFrom = sl, acreqSlotRangeTo = sl, acreqAddress=addr}
-            _ <- awaitSlot (targetSlot request)
-            txns <- acrTxns <$> addressChangeRequest request
-            if null txns
-                then pure $ Right (succ sl)
-                else pure $ Left txns
-    mapError (review _ContractError) (checkpointLoop go initial)
+awaitTxOutSpent ::
+  forall w s e.
+  ( AsContractError e
+  )
+  => TxOutRef
+  -> Contract w s e OnChainTx
+awaitTxOutSpent utxo = pabReq (AwaitUtxoSpentReq utxo) E._AwaitUtxoSpentResp
+
+{-| Wait until one or more unspent outputs are produced at an address.
+-}
+awaitUtxoProduced ::
+  forall w s e .
+  ( AsContractError e
+  )
+  => Address
+  -> Contract w s e [OnChainTx]
+awaitUtxoProduced address = pabReq (AwaitUtxoProducedReq address) E._AwaitUtxoProducedResp
 
 -- | Watch an address for changes, and return the outputs
 --   at that address when the total value at the address
@@ -292,11 +281,9 @@ fundsAtAddressGeq
 fundsAtAddressGeq addr vl =
     fundsAtAddressCondition (\presentVal -> presentVal `V.geq` vl) addr
 
--- 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).
-awaitTxConfirmed :: forall w s e. (AsContractError e) => TxId -> Contract w s e ()
-awaitTxConfirmed i = void $ pabReq (AwaitTxConfirmedReq i) E._AwaitTxConfirmedResp
+-- | Wait until the status of a transaction changes
+awaitTxStatusChange :: forall w s e. (AsContractError e) => TxId -> Contract w s e TxStatus
+awaitTxStatusChange i = pabReq (AwaitTxStatusChangeReq i) E._AwaitTxStatusChangeResp
 
 -- | Get the 'ContractInstanceId' of this instance.
 ownInstanceId :: forall w s e. (AsContractError e) => Contract w s e ContractInstanceId
@@ -456,5 +443,13 @@ submitTxConstraintsWith sl constraints = do
 -- | A version of 'submitTx' that waits until the transaction has been
 --   confirmed on the ledger before returning.
 submitTxConfirmed :: forall w s e. (AsContractError e) => UnbalancedTx -> Contract w s e ()
-submitTxConfirmed t = submitUnbalancedTx t >>= awaitTxConfirmed . txId
+submitTxConfirmed t = do
+  txi <- txId <$> submitUnbalancedTx t
+  go txi where
+    go t = do
+      status <- awaitTxStatusChange t
+      case status of
+        OnChain{} -> pure ()
+        Committed -> pure ()
+        _         -> go t -- wait until the status is one of OnChain, Committed