{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

module Plutus.ChainIndex.TxIdState(
    increaseDepth
    , initialStatus
    , transactionStatus
    , fromTx
    , fromBlock
    , rollback
    , chainConstant
    , dropOlder
    ) where

import Control.Lens ((^.))
import Data.FingerTree ((|>))
import Data.FingerTree qualified as FT
import Data.Map qualified as Map
import Data.Monoid (Last (..), Sum (..))
import Ledger (OnChainTx, onChainTxIsValid)
import Plutus.ChainIndex.Tx (ChainIndexTx (..), citxTxId, validityFromChainIndex)
import Plutus.ChainIndex.Types (BlockNumber (..), Depth (..), Point (..), RollbackState (..), Tip (..),
                                TxConfirmedState (..), TxIdState (..), TxStatus, TxStatusFailure (..), TxValidity (..))
import Plutus.ChainIndex.UtxoState (RollbackFailed (..), RollbackResult (..), UtxoIndex, UtxoState (..), rollbackWith,
                                    tip, utxoState, viewTip)
import Plutus.V1.Ledger.Api (TxId)

-- | The 'TxStatus' of a transaction right after it was added to the chain
initialStatus :: OnChainTx -> TxStatus
initialStatus :: OnChainTx -> TxStatus
initialStatus OnChainTx
tx =
  Depth -> TxValidity -> () -> TxStatus
forall a. Depth -> TxValidity -> a -> RollbackState a
TentativelyConfirmed Depth
0 (if OnChainTx -> Bool
onChainTxIsValid OnChainTx
tx then TxValidity
TxValid else TxValidity
TxInvalid) ()

-- | Increase the depth of a tentatively confirmed transaction
increaseDepth :: TxStatus -> TxStatus
increaseDepth :: TxStatus -> TxStatus
increaseDepth (TentativelyConfirmed Depth
d TxValidity
s ())
  | Depth
d Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
< Depth -> Depth
forall a. Enum a => a -> a
succ Depth
chainConstant = Depth -> TxValidity -> () -> TxStatus
forall a. Depth -> TxValidity -> a -> RollbackState a
TentativelyConfirmed (Depth
d Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
1) TxValidity
s ()
  | Bool
otherwise              = TxValidity -> () -> TxStatus
forall a. TxValidity -> a -> RollbackState a
Committed TxValidity
s ()
increaseDepth TxStatus
e            = TxStatus
e

-- TODO: Configurable!
-- | The depth (in blocks) after which a transaction cannot be rolled back anymore
chainConstant :: Depth
chainConstant :: Depth
chainConstant = Int -> Depth
Depth Int
8

-- | Drop everything older than 'BlockNumber' in the index.
dropOlder :: (Monoid a)
          => BlockNumber
          -> UtxoIndex a
          -> UtxoIndex a
dropOlder :: BlockNumber -> UtxoIndex a -> UtxoIndex a
dropOlder BlockNumber
targetBlock UtxoIndex a
idx = ((BlockCount, UtxoState a) -> Bool) -> UtxoIndex a -> UtxoIndex a
forall v a.
Measured v a =>
(v -> Bool) -> FingerTree v a -> FingerTree v a
FT.dropUntil (BlockNumber -> Tip -> Bool
blockEqTip BlockNumber
targetBlock (Tip -> Bool)
-> ((BlockCount, UtxoState a) -> Tip)
-> (BlockCount, UtxoState a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoState a -> Tip
forall a. UtxoState a -> Tip
tip (UtxoState a -> Tip)
-> ((BlockCount, UtxoState a) -> UtxoState a)
-> (BlockCount, UtxoState a)
-> Tip
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockCount, UtxoState a) -> UtxoState a
forall a b. (a, b) -> b
snd) UtxoIndex a
idx

blockEqTip :: BlockNumber -> Tip -> Bool
blockEqTip :: BlockNumber -> Tip -> Bool
blockEqTip BlockNumber
blockTarget (Tip Slot
_ BlockId
_ BlockNumber
blockAtTip) = BlockNumber
blockTarget BlockNumber -> BlockNumber -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNumber
blockAtTip
blockEqTip BlockNumber
_                  Tip
TipAtGenesis  = Bool
False

-- | Given the current block, compute the status for the given transaction by
-- checking to see if it has been deleted.
transactionStatus :: BlockNumber -> TxIdState -> TxId -> Either TxStatusFailure TxStatus
transactionStatus :: BlockNumber -> TxIdState -> TxId -> Either TxStatusFailure TxStatus
transactionStatus BlockNumber
currentBlock TxIdState
txIdState TxId
txId
  = case (Maybe TxConfirmedState
confirmed, Maybe (Sum Int)
deleted) of
       (Maybe TxConfirmedState
Nothing, Maybe (Sum Int)
_)      -> TxStatus -> Either TxStatusFailure TxStatus
forall a b. b -> Either a b
Right TxStatus
forall a. RollbackState a
Unknown

       (Just TxConfirmedState{blockAdded :: TxConfirmedState -> Last BlockNumber
blockAdded=Last (Just BlockNumber
block'), validity :: TxConfirmedState -> Last TxValidity
validity=Last (Just TxValidity
validity')}, Maybe (Sum Int)
Nothing) ->
         if BlockNumber -> Bool
isCommitted BlockNumber
block'
            then TxStatus -> Either TxStatusFailure TxStatus
forall a b. b -> Either a b
Right (TxStatus -> Either TxStatusFailure TxStatus)
-> TxStatus -> Either TxStatusFailure TxStatus
forall a b. (a -> b) -> a -> b
$ TxValidity -> () -> TxStatus
forall a. TxValidity -> a -> RollbackState a
Committed TxValidity
validity' ()
            else TxStatus -> Either TxStatusFailure TxStatus
forall a b. b -> Either a b
Right (TxStatus -> Either TxStatusFailure TxStatus)
-> TxStatus -> Either TxStatusFailure TxStatus
forall a b. (a -> b) -> a -> b
$ BlockNumber -> TxValidity -> () -> TxStatus
newStatus BlockNumber
block' TxValidity
validity' ()

       (Just TxConfirmedState{timesConfirmed :: TxConfirmedState -> Sum Int
timesConfirmed=Sum Int
confirms, blockAdded :: TxConfirmedState -> Last BlockNumber
blockAdded=Last (Just BlockNumber
block'), validity :: TxConfirmedState -> Last TxValidity
validity=Last (Just TxValidity
validity')}, Just Sum Int
deletes) ->
         if Sum Int
confirms Sum Int -> Sum Int -> Bool
forall a. Ord a => a -> a -> Bool
> Sum Int
deletes
            -- It's fine, it's confirmed
            then TxStatus -> Either TxStatusFailure TxStatus
forall a b. b -> Either a b
Right (TxStatus -> Either TxStatusFailure TxStatus)
-> TxStatus -> Either TxStatusFailure TxStatus
forall a b. (a -> b) -> a -> b
$ BlockNumber -> TxValidity -> () -> TxStatus
newStatus BlockNumber
block' TxValidity
validity' ()
            -- Otherwise, throw an error if it looks deleted but we're too far
            -- into the future.
            else if BlockNumber -> Bool
isCommitted BlockNumber
block'
                    -- Illegal - We can't roll this transaction back.
                    then TxStatusFailure -> Either TxStatusFailure TxStatus
forall a b. a -> Either a b
Left (TxStatusFailure -> Either TxStatusFailure TxStatus)
-> TxStatusFailure -> Either TxStatusFailure TxStatus
forall a b. (a -> b) -> a -> b
$ BlockNumber -> TxId -> TxIdState -> TxStatusFailure
InvalidRollbackAttempt BlockNumber
currentBlock TxId
txId TxIdState
txIdState
                    else TxStatus -> Either TxStatusFailure TxStatus
forall a b. b -> Either a b
Right TxStatus
forall a. RollbackState a
Unknown

       (Maybe TxConfirmedState, Maybe (Sum Int))
_ -> TxStatusFailure -> Either TxStatusFailure TxStatus
forall a b. a -> Either a b
Left (TxStatusFailure -> Either TxStatusFailure TxStatus)
-> TxStatusFailure -> Either TxStatusFailure TxStatus
forall a b. (a -> b) -> a -> b
$ BlockNumber -> TxId -> TxIdState -> TxStatusFailure
TxIdStateInvalid BlockNumber
currentBlock TxId
txId TxIdState
txIdState
    where
      -- A block is committed at least 'chainConstant' number of blocks
      -- has elapsed since the block was added.
      isCommitted :: BlockNumber -> Bool
isCommitted BlockNumber
addedInBlock = BlockNumber
currentBlock BlockNumber -> BlockNumber -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNumber
addedInBlock BlockNumber -> BlockNumber -> BlockNumber
forall a. Num a => a -> a -> a
+ Depth -> BlockNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Depth
chainConstant

      newStatus :: BlockNumber -> TxValidity -> () -> TxStatus
newStatus BlockNumber
block' TxValidity
validity' =
        if BlockNumber -> Bool
isCommitted BlockNumber
block'
           then TxValidity -> () -> TxStatus
forall a. TxValidity -> a -> RollbackState a
Committed TxValidity
validity'
           else Depth -> TxValidity -> () -> TxStatus
forall a. Depth -> TxValidity -> a -> RollbackState a
TentativelyConfirmed (Int -> Depth
Depth (Int -> Depth) -> Int -> Depth
forall a b. (a -> b) -> a -> b
$ BlockNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BlockNumber -> Int) -> BlockNumber -> Int
forall a b. (a -> b) -> a -> b
$ BlockNumber
currentBlock BlockNumber -> BlockNumber -> BlockNumber
forall a. Num a => a -> a -> a
- BlockNumber
block') TxValidity
validity'

      confirmed :: Maybe TxConfirmedState
confirmed = TxId -> Map TxId TxConfirmedState -> Maybe TxConfirmedState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
txId (TxIdState -> Map TxId TxConfirmedState
txnsConfirmed TxIdState
txIdState)
      deleted :: Maybe (Sum Int)
deleted   = TxId -> Map TxId (Sum Int) -> Maybe (Sum Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
txId (TxIdState -> Map TxId (Sum Int)
txnsDeleted TxIdState
txIdState)


fromBlock :: Tip -> [ChainIndexTx] -> UtxoState TxIdState
fromBlock :: Tip -> [ChainIndexTx] -> UtxoState TxIdState
fromBlock Tip
tip_ [ChainIndexTx]
transactions =
  UtxoState :: forall a. a -> Tip -> UtxoState a
UtxoState
    { _usTxUtxoData :: TxIdState
_usTxUtxoData = (ChainIndexTx -> TxIdState) -> [ChainIndexTx] -> TxIdState
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (BlockNumber -> ChainIndexTx -> TxIdState
fromTx (BlockNumber -> ChainIndexTx -> TxIdState)
-> BlockNumber -> ChainIndexTx -> TxIdState
forall a b. (a -> b) -> a -> b
$ Tip -> BlockNumber
tipBlockNo Tip
tip_) [ChainIndexTx]
transactions
    , _usTip :: Tip
_usTip = Tip
tip_
    }

fromTx :: BlockNumber -> ChainIndexTx -> TxIdState
fromTx :: BlockNumber -> ChainIndexTx -> TxIdState
fromTx BlockNumber
blockNumber ChainIndexTx
tx =
  TxIdState :: Map TxId TxConfirmedState -> Map TxId (Sum Int) -> TxIdState
TxIdState
    { txnsConfirmed :: Map TxId TxConfirmedState
txnsConfirmed =
        TxId -> TxConfirmedState -> Map TxId TxConfirmedState
forall k a. k -> a -> Map k a
Map.singleton
          (ChainIndexTx
tx ChainIndexTx -> Getting TxId ChainIndexTx TxId -> TxId
forall s a. s -> Getting a s a -> a
^. Getting TxId ChainIndexTx TxId
Lens' ChainIndexTx TxId
citxTxId)
          (TxConfirmedState :: Sum Int -> Last BlockNumber -> Last TxValidity -> TxConfirmedState
TxConfirmedState { timesConfirmed :: Sum Int
timesConfirmed = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1
                            , blockAdded :: Last BlockNumber
blockAdded = Maybe BlockNumber -> Last BlockNumber
forall a. Maybe a -> Last a
Last (Maybe BlockNumber -> Last BlockNumber)
-> (BlockNumber -> Maybe BlockNumber)
-> BlockNumber
-> Last BlockNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNumber -> Maybe BlockNumber
forall a. a -> Maybe a
Just (BlockNumber -> Last BlockNumber)
-> BlockNumber -> Last BlockNumber
forall a b. (a -> b) -> a -> b
$ BlockNumber
blockNumber
                            , validity :: Last TxValidity
validity = Maybe TxValidity -> Last TxValidity
forall a. Maybe a -> Last a
Last (Maybe TxValidity -> Last TxValidity)
-> (TxValidity -> Maybe TxValidity)
-> TxValidity
-> Last TxValidity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxValidity -> Maybe TxValidity
forall a. a -> Maybe a
Just (TxValidity -> Last TxValidity) -> TxValidity -> Last TxValidity
forall a b. (a -> b) -> a -> b
$ ChainIndexTx -> TxValidity
validityFromChainIndex ChainIndexTx
tx })
    , txnsDeleted :: Map TxId (Sum Int)
txnsDeleted = Map TxId (Sum Int)
forall a. Monoid a => a
mempty
    }

rollback :: Point
         -> UtxoIndex TxIdState
         -> Either RollbackFailed (RollbackResult TxIdState)
rollback :: Point
-> UtxoIndex TxIdState
-> Either RollbackFailed (RollbackResult TxIdState)
rollback = (UtxoIndex TxIdState -> UtxoIndex TxIdState -> UtxoIndex TxIdState)
-> Point
-> UtxoIndex TxIdState
-> Either RollbackFailed (RollbackResult TxIdState)
forall a.
Monoid a =>
(UtxoIndex a -> UtxoIndex a -> UtxoIndex a)
-> Point -> UtxoIndex a -> Either RollbackFailed (RollbackResult a)
rollbackWith UtxoIndex TxIdState -> UtxoIndex TxIdState -> UtxoIndex TxIdState
markDeleted
  where
    markDeleted :: UtxoIndex TxIdState -> UtxoIndex TxIdState -> UtxoIndex TxIdState
markDeleted UtxoIndex TxIdState
before UtxoIndex TxIdState
deleted =
      let oldTxIdState :: TxIdState
oldTxIdState = UtxoState TxIdState -> TxIdState
forall a. UtxoState a -> a
_usTxUtxoData (UtxoIndex TxIdState -> UtxoState TxIdState
forall a. Monoid a => UtxoIndex a -> UtxoState a
utxoState UtxoIndex TxIdState
deleted)
          newTxIdState :: TxIdState
newTxIdState = TxIdState :: Map TxId TxConfirmedState -> Map TxId (Sum Int) -> TxIdState
TxIdState
                            { txnsConfirmed :: Map TxId TxConfirmedState
txnsConfirmed = Map TxId TxConfirmedState
forall a. Monoid a => a
mempty
                            -- All the transactions that were confirmed in the deleted
                            -- section are now deleted.
                            , txnsDeleted :: Map TxId (Sum Int)
txnsDeleted = Sum Int
1 Sum Int -> Map TxId TxConfirmedState -> Map TxId (Sum Int)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TxIdState -> Map TxId TxConfirmedState
txnsConfirmed TxIdState
oldTxIdState
                            }
          newUtxoState :: UtxoState TxIdState
newUtxoState = TxIdState -> Tip -> UtxoState TxIdState
forall a. a -> Tip -> UtxoState a
UtxoState (TxIdState
oldTxIdState TxIdState -> TxIdState -> TxIdState
forall a. Semigroup a => a -> a -> a
<> TxIdState
newTxIdState) (UtxoIndex TxIdState -> Tip
forall a. Monoid a => UtxoIndex a -> Tip
viewTip UtxoIndex TxIdState
before)
      in UtxoIndex TxIdState
before UtxoIndex TxIdState -> UtxoState TxIdState -> UtxoIndex TxIdState
forall v a. Measured v a => FingerTree v a -> a -> FingerTree v a
|> UtxoState TxIdState
newUtxoState