SCP-2734: API for watching the state of tx outputs.

playground-common/src/PSGenerator/Common.hs

@@ -38,8 +38,8 @@ import           Ledger.Value                              (AssetClass, Currency
 import           Playground.Types                          (ContractCall, FunctionSchema, KnownCurrency)
 import           Plutus.ChainIndex.Emulator.Handlers       (ChainIndexError, ChainIndexLog)
 import           Plutus.ChainIndex.Tx                      (ChainIndexTx, ChainIndexTxOutputs)
-import           Plutus.ChainIndex.Types                   (BlockNumber, Depth, Page, PageSize, Point, Tip, TxStatus,
-                                                            TxValidity)
+import           Plutus.ChainIndex.Types                   (BlockNumber, Depth, Page, PageSize, Point, RollbackState,
+                                                            Tip, TxOutState, TxValidity)
 import           Plutus.ChainIndex.UtxoState               (InsertUtxoFailed, InsertUtxoPosition, RollbackFailed)
 import           Plutus.Contract.CardanoAPI                (FromCardanoError)
 import           Plutus.Contract.Checkpoint                (CheckpointError)
@@ -397,7 +397,8 @@ ledgerTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @ActiveEndpoint)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @UnbalancedTx)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxValidity)
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxStatus)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxOutState)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @(RollbackState A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @BlockNumber)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @Depth)
     ]

plutus-chain-index/plutus-chain-index.cabal

@@ -39,6 +39,8 @@ library
         Plutus.ChainIndex.Server
         Plutus.ChainIndex.Tx
         Plutus.ChainIndex.TxIdState
+        Plutus.ChainIndex.TxOutBalance
+        Plutus.ChainIndex.TxUtxoBalance
         Plutus.ChainIndex.Types
         Plutus.ChainIndex.UtxoState
         Plutus.Monitoring.Util

plutus-chain-index/src/Plutus/ChainIndex.hs

@@ -10,5 +10,7 @@ import           Plutus.ChainIndex.Emulator.DiskState as Emulator hiding (fromTx
 import           Plutus.ChainIndex.Emulator.Handlers  as Emulator
 import           Plutus.ChainIndex.Tx                 as Export
 import           Plutus.ChainIndex.TxIdState          as Export hiding (fromBlock, fromTx, rollback)
+import           Plutus.ChainIndex.TxOutBalance       as Export hiding (fromBlock, fromTx, isSpentOutput,
+                                                                 isUnspentOutput, rollback)
 import           Plutus.ChainIndex.Types              as Export
-import           Plutus.ChainIndex.UtxoState          as Export hiding (fromBlock, fromTx, rollback)
+import           Plutus.ChainIndex.UtxoState          as Export

plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs

@@ -1,15 +1,14 @@
-{-# LANGUAGE DeriveAnyClass     #-}
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia        #-}
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE GADTs              #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE NamedFieldPuns     #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE TypeApplications   #-}
-{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE DerivingVia       #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeOperators     #-}
 {-| Handlers for the 'ChainIndexQueryEffect' and the 'ChainIndexControlEffect'
     in the emulator
 -}
@@ -45,9 +44,10 @@ import           Plutus.ChainIndex.Emulator.DiskState (DiskState, addressMap, da
                                                        redeemerMap, stakeValidatorMap, txMap, validatorMap)
 import qualified Plutus.ChainIndex.Emulator.DiskState as DiskState
 import           Plutus.ChainIndex.Tx                 (ChainIndexTx, _ValidTx, citxOutputs)
-import           Plutus.ChainIndex.Types              (Tip (..), pageOf)
+import           Plutus.ChainIndex.TxUtxoBalance      (fromBlock, isUnspentOutput, rollback, unspentOutputs)
+import           Plutus.ChainIndex.Types              (Tip (..), TxUtxoBalance, pageOf)
 import           Plutus.ChainIndex.UtxoState          (InsertUtxoPosition, InsertUtxoSuccess (..), RollbackResult (..),
-                                                       TxUtxoBalance, UtxoIndex, isUnspentOutput, tip)
+                                                       UtxoIndex, tip)
 import qualified Plutus.ChainIndex.UtxoState          as UtxoState
 import           Plutus.Contract.CardanoAPI           (FromCardanoError (..))
 import           Plutus.V1.Ledger.Api                 (Credential (PubKeyCredential, ScriptCredential))
@@ -150,7 +150,7 @@ handleControl ::
 handleControl = \case
     AppendBlock tip_ transactions -> do
         oldState <- get @ChainIndexEmulatorState
-        case UtxoState.insert (UtxoState.fromBlock tip_ transactions) (view utxoIndex oldState) of
+        case UtxoState.insert (fromBlock tip_ transactions) (view utxoIndex oldState) of
             Left err -> do
                 let reason = InsertionFailed err
                 logError $ Err reason
@@ -162,7 +162,7 @@ handleControl = \case
                 logDebug $ InsertionSuccess tip_ insertPosition
     Rollback tip_ -> do
         oldState <- get @ChainIndexEmulatorState
-        case UtxoState.rollback tip_ (view utxoIndex oldState) of
+        case rollback tip_ (view utxoIndex oldState) of
             Left err -> do
                 let reason = RollbackFailed err
                 logError $ Err reason
@@ -176,7 +176,7 @@ handleControl = \case
         utxos <- gets $
             Set.toList
             . Set.map txOutRefId
-            . UtxoState.unspentOutputs
+            . unspentOutputs
             . UtxoState.utxoState
             . view utxoIndex
         newDiskState <- foldMap DiskState.fromTx . catMaybes <$> mapM getTxFromTxId utxos

plutus-chain-index/src/Plutus/ChainIndex/TxIdState.hs

@@ -1,14 +1,10 @@
-{-# LANGUAGE DeriveAnyClass        #-}
-{-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MonoLocalBinds        #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE ViewPatterns          #-}
 
 module Plutus.ChainIndex.TxIdState(
@@ -28,23 +24,23 @@ import qualified Data.Map                    as Map
 import           Data.Monoid                 (Last (..), Sum (..))
 import           Ledger                      (OnChainTx, TxId, eitherTx)
 import           Plutus.ChainIndex.Tx        (ChainIndexTx (..), ChainIndexTxOutputs (..), citxOutputs, citxTxId)
-import           Plutus.ChainIndex.Types     (BlockNumber (..), Depth (..), Point (..), Tip (..), TxConfirmedState (..),
-                                              TxIdState (..), TxStatus (..), TxStatusFailure (..), TxValidity (..),
-                                              pointsToTip)
+import           Plutus.ChainIndex.Types     (BlockNumber (..), Depth (..), Point (..), RollbackState (..), Tip (..),
+                                              TxConfirmedState (..), TxIdState (..), TxStatus, TxStatusFailure (..),
+                                              TxValidity (..), pointsToTip)
 import           Plutus.ChainIndex.UtxoState (RollbackFailed (..), RollbackResult (..), UtxoIndex, UtxoState (..), tip,
                                               viewTip)
 
 
 -- | The 'TxStatus' of a transaction right after it was added to the chain
 initialStatus :: OnChainTx -> TxStatus
-initialStatus =
-  TentativelyConfirmed 0 . eitherTx (const TxInvalid) (const TxValid)
+initialStatus tx =
+  TentativelyConfirmed 0 (eitherTx (const TxInvalid) (const TxValid) tx) ()
 
 -- | Increase the depth of a tentatively confirmed transaction
 increaseDepth :: TxStatus -> TxStatus
-increaseDepth (TentativelyConfirmed d s)
-  | d < succ chainConstant = TentativelyConfirmed (d + 1) s
-  | otherwise              = Committed s
+increaseDepth (TentativelyConfirmed d s ())
+  | d < succ chainConstant = TentativelyConfirmed (d + 1) s ()
+  | otherwise              = Committed s ()
 increaseDepth e            = e
 
 -- TODO: Configurable!
@@ -61,19 +57,19 @@ transactionStatus currentBlock txIdState txId
 
        (Just TxConfirmedState{blockAdded=Last (Just block'), validity=Last (Just validity')}, Nothing) ->
          if isCommitted block'
-            then Right $ Committed validity'
-            else Right $ newStatus block' validity'
+            then Right $ Committed validity' ()
+            else Right $ newStatus block' validity' ()
 
        (Just TxConfirmedState{timesConfirmed=confirms, blockAdded=Last (Just block'), validity=Last (Just validity')}, Just deletes) ->
          if confirms > deletes
             -- It's fine, it's confirmed
-            then Right $ newStatus block' validity'
+            then Right $ newStatus block' validity' ()
             -- Otherwise, throw an error if it looks deleted but we're too far
             -- into the future.
             else if isCommitted block'
                     -- Illegal - We can't roll this transaction back.
                     then Left $ InvalidRollbackAttempt currentBlock txId txIdState
-                    else Right $ Unknown
+                    else Right Unknown
 
        _ -> Left $ TxIdStateInvalid currentBlock txId txIdState
     where

plutus-chain-index/src/Plutus/ChainIndex/TxOutBalance.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE DerivingVia           #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MonoLocalBinds        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ViewPatterns          #-}
+module Plutus.ChainIndex.TxOutBalance where
+
+import           Control.Lens                (view)
+import           Data.FingerTree             (Measured (measure))
+import qualified Data.FingerTree             as FT
+import qualified Data.Map                    as Map
+import           Data.Set                    (Set)
+import qualified Data.Set                    as Set
+import           Ledger                      (TxIn (txInRef), TxOutRef (..))
+import           Plutus.ChainIndex.Tx        (ChainIndexTx (..), citxInputs, citxTxId, txOutsWithRef)
+import           Plutus.ChainIndex.TxIdState (transactionStatus)
+import           Plutus.ChainIndex.Types     (BlockNumber, Point (..), Tip (..), TxIdState, TxOutBalance (..),
+                                              TxOutState (..), TxOutStatus, TxStatusFailure (TxOutBalanceStateInvalid),
+                                              pointsToTip, tobSpentOutputs, tobUnspentOutputs)
+import           Plutus.ChainIndex.UtxoState (RollbackFailed (OldPointNotFound, RollbackNoTip, TipMismatch, foundTip, targetPoint),
+                                              RollbackResult (RollbackResult, newTip, rolledBackIndex), UtxoIndex,
+                                              UtxoState (UtxoState, _usTip, _usTxUtxoData), tip, usTxUtxoData, viewTip)
+
+-- | Given the current block, compute the status for the given transaction
+-- output by getting the state of the transaction that produced it and checking
+-- if the output is spent or unspent.
+transactionOutputStatus
+  :: BlockNumber
+  -- ^ Current block number for inspecting the state of the transaction output
+  -> TxIdState
+  -- ^ Information on the state of a transaction. Needed for determining its
+  -- status.
+  -> TxOutBalance
+  -- ^ Balance of spent and unspent transaction outputs.
+  -> TxOutRef
+  -- ^ Target transaction output for inspecting its state.
+  -> Either TxStatusFailure TxOutStatus
+transactionOutputStatus currentBlock txIdState txOutBalance txOutRef@TxOutRef { txOutRefId } =
+  let isSpent = txOutRef `Set.member` Map.keysSet (_tobSpentOutputs txOutBalance)
+      isUnspent = txOutRef `Set.member` _tobUnspentOutputs txOutBalance
+      txOutState
+          | isSpent = Just (Spent txOutRefId)
+          | isUnspent = Just Unspent
+          | otherwise = Nothing
+   in do
+     -- Get the status of the tx which produced the target tx output
+     txStatus <- transactionStatus currentBlock txIdState txOutRefId
+     case txOutState of
+       Just s -> Right $ fmap (const s) txStatus
+       _      -> Left $ TxOutBalanceStateInvalid currentBlock txOutRef txOutBalance
+
+fromTx :: ChainIndexTx -> TxOutBalance
+fromTx tx =
+    TxOutBalance
+        { _tobUnspentOutputs = Set.fromList $ fmap snd $ txOutsWithRef tx
+        , _tobSpentOutputs =
+          Map.fromSet (const $ view citxTxId tx)
+                      $ Set.mapMonotonic txInRef (view citxInputs tx)
+        }
+
+-- | Whether a 'TxOutRef' is a member of the UTXO set (ie. unspent)
+isUnspentOutput :: TxOutRef -> UtxoState TxOutBalance -> Bool
+isUnspentOutput r = Set.member r . unspentOutputs
+
+-- | The UTXO set
+unspentOutputs :: UtxoState TxOutBalance -> Set TxOutRef
+unspentOutputs = view (usTxUtxoData . tobUnspentOutputs)
+
+-- | Whether a 'TxOutRef' is a member of the spent tx output set.
+isSpentOutput :: TxOutRef -> UtxoState TxOutBalance -> Bool
+isSpentOutput r = Set.member r . spentOutputs
+
+-- | The spent output set
+spentOutputs :: UtxoState TxOutBalance -> Set TxOutRef
+spentOutputs = Map.keysSet . view (usTxUtxoData . tobSpentOutputs)
+
+-- | 'UtxoIndex' for a single block
+fromBlock :: Tip -> [ChainIndexTx] -> UtxoState TxOutBalance
+fromBlock tip_ transactions =
+    UtxoState
+            { _usTxUtxoData = foldMap fromTx transactions
+            , _usTip        = tip_
+            }
+
+-- | Perform a rollback on the utxo index
+rollback :: Point
+         -> UtxoIndex TxOutBalance
+         -> Either RollbackFailed (RollbackResult TxOutBalance)
+rollback _ (viewTip -> TipAtGenesis) = Left RollbackNoTip
+rollback targetPoint idx@(viewTip -> currentTip)
+    -- The rollback happened sometime after the current tip.
+    | not (targetPoint `pointLessThanTip` currentTip) =
+        Left TipMismatch{foundTip=currentTip, targetPoint}
+    | otherwise = do
+        let (before, _) = FT.split (pointLessThanTip targetPoint . tip) idx
+
+        case tip (measure before) of
+            TipAtGenesis -> Left $ OldPointNotFound targetPoint
+            oldTip | targetPoint `pointsToTip` oldTip ->
+                       Right RollbackResult{newTip=oldTip, rolledBackIndex=before}
+                   | otherwise                        ->
+                       Left  TipMismatch{foundTip=oldTip, targetPoint=targetPoint}
+    where
+      pointLessThanTip :: Point -> Tip -> Bool
+      pointLessThanTip PointAtGenesis  _               = True
+      pointLessThanTip (Point pSlot _) (Tip tSlot _ _) = pSlot < tSlot
+      pointLessThanTip _               TipAtGenesis    = False