{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes         #-}
-- |
module Plutus.PAB.Core.ContractInstance.BlockchainEnv(
  startNodeClient
  , processMockBlock
  ) where

import Cardano.Api (BlockInMode (..), ChainPoint (..), chainPointToSlotNo)
import Cardano.Api qualified as C
import Cardano.Api.NetworkId.Extra (NetworkIdWrapper (NetworkIdWrapper))
import Cardano.Node.Emulator.TimeSlot qualified as TimeSlot
import Cardano.Node.Params qualified as Params
import Cardano.Node.Types (NodeMode (..),
                           PABServerConfig (PABServerConfig, pscNetworkId, pscNodeMode, pscSlotConfig, pscSocketPath))
import Cardano.Protocol.Socket.Client (ChainSyncEvent (..))
import Cardano.Protocol.Socket.Client qualified as Client
import Cardano.Protocol.Socket.Mock.Client qualified as MockClient
import Control.Concurrent.STM (STM)
import Control.Concurrent.STM qualified as STM
import Control.Lens
import Control.Monad (forM_, void, when)
import Control.Monad.Freer.Extras.Beam.Postgres qualified as Postgres (DbConfig (dbConfigMarconiFile))
import Control.Monad.Freer.Extras.Beam.Sqlite qualified as Sqlite (DbConfig (dbConfigFile))
import Control.Tracer (nullTracer)
import Data.Foldable (foldl')
import Data.IORef (newIORef)
import Data.List (findIndex)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, maybeToList)
import Data.Monoid (Last (..), Sum (..))
import Data.Text (Text, unpack)
import Ledger (Block, Slot (..), TxId (..))
import Marconi.Core.Index.VSqlite qualified as Ix
import Plutus.ChainIndex (BlockNumber (..), ChainIndexTx (..), Depth (..), InsertUtxoFailed (..),
                          InsertUtxoSuccess (..), Point (..), ReduceBlockCountResult (..), RollbackFailed (..),
                          RollbackResult (..), Tip (..), TxConfirmedState (..), TxIdState (..), TxOutBalance,
                          TxValidity (..), UtxoIndex, UtxoState (..), blockId, citxTxId, fromOnChainTx, insert,
                          reduceBlockCount, tipAsPoint, utxoState, validityFromChainIndex)
import Plutus.ChainIndex.Compatibility (fromCardanoBlockHeader, fromCardanoPoint, toCardanoPoint)
import Plutus.ChainIndex.TxIdState qualified as TxIdState
import Plutus.ChainIndex.TxOutBalance qualified as TxOutBalance
import Plutus.ChainIndex.UtxoState (viewTip)
import Plutus.Contract.CardanoAPI (fromCardanoTx)
import Plutus.PAB.Core.ContractInstance.STM (BlockchainEnv (..), InstanceClientEnv (..), InstancesState,
                                             OpenTxOutProducedRequest (..), OpenTxOutSpentRequest (..),
                                             emptyBlockchainEnv)
import Plutus.PAB.Core.ContractInstance.STM qualified as S
import Plutus.PAB.Core.Indexer.TxConfirmationStatus (TxInfo (..))
import Plutus.PAB.Core.Indexer.TxConfirmationStatus qualified as Ix
import Plutus.PAB.Types (Config (Config, dbConfig), DbConfig (..),
                         DevelopmentOptions (DevelopmentOptions, pabResumeFrom, pabRollbackHistory),
                         WebserverConfig (WebserverConfig, enableMarconi), developmentOptions, nodeServerConfig,
                         pabWebserverConfig)
import Plutus.Trace.Emulator.ContractInstance (IndexedBlock (..), indexBlock)
import System.Random

-- | Connect to the node and write node updates to the blockchain
--   env.
startNodeClient ::
     Config -- ^ PAB's config
  -> InstancesState -- ^ In-memory state of running contract instances
  -> IO BlockchainEnv
startNodeClient :: Config -> InstancesState -> IO BlockchainEnv
startNodeClient Config
config InstancesState
instancesState = do
    let Config { nodeServerConfig :: Config -> PABServerConfig
nodeServerConfig =
                   PABServerConfig { pscSocketPath :: PABServerConfig -> FilePath
pscSocketPath = FilePath
socket
                                   , pscSlotConfig :: PABServerConfig -> SlotConfig
pscSlotConfig = SlotConfig
slotConfig
                                   , NodeMode
pscNodeMode :: NodeMode
pscNodeMode :: PABServerConfig -> NodeMode
pscNodeMode
                                   , pscNetworkId :: PABServerConfig -> NetworkIdWrapper
pscNetworkId = NetworkIdWrapper NetworkId
networkId
                                   }
               , developmentOptions :: Config -> DevelopmentOptions
developmentOptions =
                   DevelopmentOptions { Maybe Int
pabRollbackHistory :: Maybe Int
pabRollbackHistory :: DevelopmentOptions -> Maybe Int
pabRollbackHistory
                                      , pabResumeFrom :: DevelopmentOptions -> Point
pabResumeFrom = Point
resumePoint
                                      }
               , pabWebserverConfig :: Config -> WebserverConfig
pabWebserverConfig =
                   WebserverConfig { enableMarconi :: WebserverConfig -> Bool
enableMarconi = Bool
useDiskIndex }
               , dbConfig :: Config -> DbConfig
dbConfig = DbConfig
dbConf
               } = Config
config
    Params
params <- PABServerConfig -> IO Params
Params.fromPABServerConfig (PABServerConfig -> IO Params) -> PABServerConfig -> IO Params
forall a b. (a -> b) -> a -> b
$ Config -> PABServerConfig
nodeServerConfig Config
config
    BlockchainEnv
env <- do
      BlockchainEnv
env' <- STM BlockchainEnv -> IO BlockchainEnv
forall a. STM a -> IO a
STM.atomically (STM BlockchainEnv -> IO BlockchainEnv)
-> STM BlockchainEnv -> IO BlockchainEnv
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Params -> STM BlockchainEnv
emptyBlockchainEnv Maybe Int
pabRollbackHistory Params
params
      if Bool
useDiskIndex Bool -> Bool -> Bool
&& NodeMode -> Bool
nodeStartsInAlonzoMode NodeMode
pscNodeMode
      then do
        IORef TCSIndex
utxoIx <- FilePath -> Depth -> IO TCSIndex
Ix.open (Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ DbConfig -> Text
getDBFilePath DbConfig
dbConf) (Int -> Depth
Ix.Depth Int
10) IO TCSIndex
-> (TCSIndex -> IO (IORef TCSIndex)) -> IO (IORef TCSIndex)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TCSIndex -> IO (IORef TCSIndex)
forall a. a -> IO (IORef a)
newIORef
        BlockchainEnv -> IO BlockchainEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockchainEnv -> IO BlockchainEnv)
-> BlockchainEnv -> IO BlockchainEnv
forall a b. (a -> b) -> a -> b
$ BlockchainEnv
env' { beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges = IORef TCSIndex
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
forall a b. b -> Either a b
Right IORef TCSIndex
utxoIx }
      else do
        BlockchainEnv -> IO BlockchainEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockchainEnv
env'
    case NodeMode
pscNodeMode of
      NodeMode
MockNode -> do
        IO (ChainSyncHandle Block) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ChainSyncHandle Block) -> IO ())
-> IO (ChainSyncHandle Block) -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> SlotConfig
-> (Block -> Slot -> IO ())
-> IO (ChainSyncHandle Block)
MockClient.runChainSync FilePath
socket SlotConfig
slotConfig
            (\Block
block Slot
slot -> STM (Either SyncActionFailure (Slot, BlockNumber)) -> IO ()
handleSyncAction (STM (Either SyncActionFailure (Slot, BlockNumber)) -> IO ())
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber))) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InstancesState
-> BlockchainEnv
-> Block
-> Slot
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
processMockBlock InstancesState
instancesState BlockchainEnv
env Block
block Slot
slot)
      NodeMode
AlonzoNode -> do
        let resumePoints :: [ChainPoint]
resumePoints = Maybe ChainPoint -> [ChainPoint]
forall a. Maybe a -> [a]
maybeToList (Maybe ChainPoint -> [ChainPoint])
-> Maybe ChainPoint -> [ChainPoint]
forall a b. (a -> b) -> a -> b
$ Point -> Maybe ChainPoint
toCardanoPoint Point
resumePoint
        IO (ChainSyncHandle ChainSyncEvent) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ChainSyncHandle ChainSyncEvent) -> IO ())
-> IO (ChainSyncHandle ChainSyncEvent) -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> Trace IO ClientMsg
-> SlotConfig
-> NetworkId
-> [ChainPoint]
-> (ChainSyncEvent -> IO ())
-> IO (ChainSyncHandle ChainSyncEvent)
Client.runChainSync FilePath
socket Trace IO ClientMsg
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer SlotConfig
slotConfig NetworkId
networkId [ChainPoint]
resumePoints
            (\ChainSyncEvent
block -> do
                -- We store the actual current slot in `BlockchainEnv`. Thus,
                -- at every new block from the local node, we request for the
                -- current slot number and store it. The actual current slot is
                -- useful/necessary for blocking contract actions like `awaitSlot`.
                Slot
slot <- SlotConfig -> IO Slot
TimeSlot.currentSlot SlotConfig
slotConfig
                STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Slot -> Slot -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (BlockchainEnv -> TVar Slot
beCurrentSlot BlockchainEnv
env) Slot
slot
                InstancesState
-> BlockchainEnv
-> ChainSyncEvent
-> IO (Either SyncActionFailure (Slot, BlockNumber))
processChainSyncEvent InstancesState
instancesState BlockchainEnv
env ChainSyncEvent
block IO (Either SyncActionFailure (Slot, BlockNumber))
-> (Either SyncActionFailure (Slot, BlockNumber) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SyncActionFailure (Slot, BlockNumber) -> IO ()
handleSyncAction'
            )
      NodeMode
NoChainSyncEvents -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    BlockchainEnv -> IO BlockchainEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockchainEnv
env
    where
      getDBFilePath :: DbConfig -> Text
      getDBFilePath :: DbConfig -> Text
getDBFilePath (SqliteDB DbConfig
c)   = DbConfig -> Text
Sqlite.dbConfigFile DbConfig
c
      getDBFilePath (PostgresDB DbConfig
c) = DbConfig -> Text
Postgres.dbConfigMarconiFile DbConfig
c

      nodeStartsInAlonzoMode :: NodeMode -> Bool
      nodeStartsInAlonzoMode :: NodeMode -> Bool
nodeStartsInAlonzoMode NodeMode
AlonzoNode = Bool
True
      nodeStartsInAlonzoMode NodeMode
_          = Bool
False

-- | Deal with sync action failures from running this STM action. For now, we
-- deal with them by simply calling `error`; i.e. the application exits.
handleSyncAction :: STM (Either SyncActionFailure (Slot, BlockNumber)) -> IO ()
handleSyncAction :: STM (Either SyncActionFailure (Slot, BlockNumber)) -> IO ()
handleSyncAction STM (Either SyncActionFailure (Slot, BlockNumber))
action = do
  STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a. STM a -> IO a
STM.atomically STM (Either SyncActionFailure (Slot, BlockNumber))
action IO (Either SyncActionFailure (Slot, BlockNumber))
-> (Either SyncActionFailure (Slot, BlockNumber) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SyncActionFailure (Slot, BlockNumber) -> IO ()
handleSyncAction'

handleSyncAction' :: Either SyncActionFailure (Slot, BlockNumber) -> IO ()
handleSyncAction' :: Either SyncActionFailure (Slot, BlockNumber) -> IO ()
handleSyncAction' Either SyncActionFailure (Slot, BlockNumber)
action = do
  case Either SyncActionFailure (Slot, BlockNumber)
action of
    Left SyncActionFailure
err -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"handleSyncAction failed with: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SyncActionFailure -> FilePath
forall a. Show a => a -> FilePath
show SyncActionFailure
err
    Right (Slot Integer
s, BlockNumber Word64
n) -> do
      StdGen
stdGen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, StdGen) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0 :: Int, Int
10_000) StdGen
stdGen) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Current synced block: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
n FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
". Current synced slot: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
s
  (SyncActionFailure -> IO ())
-> ((Slot, BlockNumber) -> IO ())
-> Either SyncActionFailure (Slot, BlockNumber)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ())
-> (SyncActionFailure -> FilePath) -> SyncActionFailure -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncActionFailure -> FilePath
forall a. Show a => a -> FilePath
show) (IO () -> (Slot, BlockNumber) -> IO ()
forall a b. a -> b -> a
const (IO () -> (Slot, BlockNumber) -> IO ())
-> IO () -> (Slot, BlockNumber) -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Either SyncActionFailure (Slot, BlockNumber)
action

updateInstances :: IndexedBlock -> InstanceClientEnv -> STM ()
updateInstances :: IndexedBlock -> InstanceClientEnv -> STM ()
updateInstances
    IndexedBlock{Map TxOutRef ChainIndexTx
ibUtxoSpent :: IndexedBlock -> Map TxOutRef ChainIndexTx
ibUtxoSpent :: Map TxOutRef ChainIndexTx
ibUtxoSpent, Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced :: IndexedBlock -> Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced :: Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced}
    InstanceClientEnv{Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests :: InstanceClientEnv -> Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests :: Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests, Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests :: InstanceClientEnv -> Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests :: Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests} = do

  Map TxOutRef (ChainIndexTx, [OpenTxOutSpentRequest])
-> ((ChainIndexTx, [OpenTxOutSpentRequest]) -> STM [Bool])
-> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((ChainIndexTx
 -> [OpenTxOutSpentRequest]
 -> (ChainIndexTx, [OpenTxOutSpentRequest]))
-> Map TxOutRef ChainIndexTx
-> Map TxOutRef [OpenTxOutSpentRequest]
-> Map TxOutRef (ChainIndexTx, [OpenTxOutSpentRequest])
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map TxOutRef ChainIndexTx
ibUtxoSpent Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests) (((ChainIndexTx, [OpenTxOutSpentRequest]) -> STM [Bool]) -> STM ())
-> ((ChainIndexTx, [OpenTxOutSpentRequest]) -> STM [Bool])
-> STM ()
forall a b. (a -> b) -> a -> b
$ \(ChainIndexTx
onChainTx, [OpenTxOutSpentRequest]
requests) ->
    (OpenTxOutSpentRequest -> STM Bool)
-> [OpenTxOutSpentRequest] -> STM [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\OpenTxOutSpentRequest{TMVar ChainIndexTx
osrSpendingTx :: OpenTxOutSpentRequest -> TMVar ChainIndexTx
osrSpendingTx :: TMVar ChainIndexTx
osrSpendingTx} -> TMVar ChainIndexTx -> ChainIndexTx -> STM Bool
forall a. TMVar a -> a -> STM Bool
STM.tryPutTMVar TMVar ChainIndexTx
osrSpendingTx ChainIndexTx
onChainTx) [OpenTxOutSpentRequest]
requests
  Map
  CardanoAddress (NonEmpty ChainIndexTx, [OpenTxOutProducedRequest])
-> ((NonEmpty ChainIndexTx, [OpenTxOutProducedRequest])
    -> STM [Bool])
-> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((NonEmpty ChainIndexTx
 -> [OpenTxOutProducedRequest]
 -> (NonEmpty ChainIndexTx, [OpenTxOutProducedRequest]))
-> Map CardanoAddress (NonEmpty ChainIndexTx)
-> Map CardanoAddress [OpenTxOutProducedRequest]
-> Map
     CardanoAddress (NonEmpty ChainIndexTx, [OpenTxOutProducedRequest])
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests) (((NonEmpty ChainIndexTx, [OpenTxOutProducedRequest])
  -> STM [Bool])
 -> STM ())
-> ((NonEmpty ChainIndexTx, [OpenTxOutProducedRequest])
    -> STM [Bool])
-> STM ()
forall a b. (a -> b) -> a -> b
$ \(NonEmpty ChainIndexTx
txns, [OpenTxOutProducedRequest]
requests) ->
    (OpenTxOutProducedRequest -> STM Bool)
-> [OpenTxOutProducedRequest] -> STM [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\OpenTxOutProducedRequest{TMVar (NonEmpty ChainIndexTx)
otxProducingTxns :: OpenTxOutProducedRequest -> TMVar (NonEmpty ChainIndexTx)
otxProducingTxns :: TMVar (NonEmpty ChainIndexTx)
otxProducingTxns} -> TMVar (NonEmpty ChainIndexTx) -> NonEmpty ChainIndexTx -> STM Bool
forall a. TMVar a -> a -> STM Bool
STM.tryPutTMVar TMVar (NonEmpty ChainIndexTx)
otxProducingTxns NonEmpty ChainIndexTx
txns) [OpenTxOutProducedRequest]
requests

blockAndSlot :: BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot :: BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv{TVar BlockNumber
beLastSyncedBlockNo :: BlockchainEnv -> TVar BlockNumber
beLastSyncedBlockNo :: TVar BlockNumber
beLastSyncedBlockNo, TVar Slot
beLastSyncedBlockSlot :: BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot :: TVar Slot
beLastSyncedBlockSlot} =
  (,) (Slot -> BlockNumber -> (Slot, BlockNumber))
-> STM Slot -> STM (BlockNumber -> (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beLastSyncedBlockSlot STM (BlockNumber -> (Slot, BlockNumber))
-> STM BlockNumber -> STM (Slot, BlockNumber)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar BlockNumber -> STM BlockNumber
forall a. TVar a -> STM a
STM.readTVar TVar BlockNumber
beLastSyncedBlockNo

-- | Process a chain sync event that we receive from the alonzo node client
processChainSyncEvent
  :: InstancesState
  -> BlockchainEnv
  -> ChainSyncEvent
  -> IO (Either SyncActionFailure (Slot, BlockNumber))
processChainSyncEvent :: InstancesState
-> BlockchainEnv
-> ChainSyncEvent
-> IO (Either SyncActionFailure (Slot, BlockNumber))
processChainSyncEvent InstancesState
instancesState env :: BlockchainEnv
env@BlockchainEnv{Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges} ChainSyncEvent
event = do
  case ChainSyncEvent
event of
    Resume ChainPoint
_ -> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a. STM a -> IO a
STM.atomically (STM (Either SyncActionFailure (Slot, BlockNumber))
 -> IO (Either SyncActionFailure (Slot, BlockNumber)))
-> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
    RollForward (BlockInMode (C.Block BlockHeader
header [Tx era]
transactions) EraInMode era CardanoMode
era) ChainTip
_ ->
      InstancesState
-> BlockHeader
-> BlockchainEnv
-> [Tx era]
-> EraInMode era CardanoMode
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall era.
IsCardanoEra era =>
InstancesState
-> BlockHeader
-> BlockchainEnv
-> [Tx era]
-> EraInMode era CardanoMode
-> IO (Either SyncActionFailure (Slot, BlockNumber))
processBlock InstancesState
instancesState BlockHeader
header BlockchainEnv
env [Tx era]
transactions EraInMode era CardanoMode
era
    RollBackward ChainPoint
chainPoint ChainTip
_ -> do
      Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
-> (TCSIndex -> IO TCSIndex) -> IO ()
S.updateTxChangesR Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges ((TCSIndex -> IO TCSIndex) -> IO ())
-> (TCSIndex -> IO TCSIndex) -> IO ()
forall a b. (a -> b) -> a -> b
$
        \TCSIndex
txChanges -> do
           [TxInfo]
events <- [[TxInfo]] -> [TxInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TxInfo]] -> [TxInfo]) -> IO [[TxInfo]] -> IO [TxInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage Vector IO [TxInfo] -> IO [[TxInfo]]
forall (v :: * -> *) (m :: * -> *) e.
(MVector (Mutable v) e, PrimMonad m, Show e) =>
Storage v m e -> m [e]
Ix.getEvents (TCSIndex
txChanges TCSIndex
-> Getting
     (Storage Vector IO [TxInfo]) TCSIndex (Storage Vector IO [TxInfo])
-> Storage Vector IO [TxInfo]
forall s a. s -> Getting a s a -> a
^. Getting
  (Storage Vector IO [TxInfo]) TCSIndex (Storage Vector IO [TxInfo])
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) (Storage v m e)
Ix.storage)
           TCSIndex -> IO TCSIndex
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TCSIndex -> IO TCSIndex)
-> (Maybe TCSIndex -> TCSIndex) -> Maybe TCSIndex -> IO TCSIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCSIndex -> Maybe TCSIndex -> TCSIndex
forall a. a -> Maybe a -> a
fromMaybe TCSIndex
txChanges (Maybe TCSIndex -> IO TCSIndex) -> Maybe TCSIndex -> IO TCSIndex
forall a b. (a -> b) -> a -> b
$ do
             SlotNo
slot   <- ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
chainPoint
             Int
offset <- (TxInfo -> Bool) -> [TxInfo] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(TxInfo TxId
_ BlockNumber
_ SlotNo
sn) -> SlotNo
sn SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot) [TxInfo]
events
             Int -> TCSIndex -> Maybe TCSIndex
forall (v :: * -> *) e (m :: * -> *) h n q r.
MVector (Mutable v) e =>
Int -> SplitIndex m h v e n q r -> Maybe (SplitIndex m h v e n q r)
Ix.rewind Int
offset TCSIndex
txChanges
      STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a. STM a -> IO a
STM.atomically (STM (Either SyncActionFailure (Slot, BlockNumber))
 -> IO (Either SyncActionFailure (Slot, BlockNumber)))
-> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ BlockchainEnv
-> ChainPoint -> STM (Either SyncActionFailure (Slot, BlockNumber))
runRollback BlockchainEnv
env ChainPoint
chainPoint


data SyncActionFailure
  = RollbackFailure RollbackFailed
  | InsertUtxoStateFailure InsertUtxoFailed
  deriving (Int -> SyncActionFailure -> FilePath -> FilePath
[SyncActionFailure] -> FilePath -> FilePath
SyncActionFailure -> FilePath
(Int -> SyncActionFailure -> FilePath -> FilePath)
-> (SyncActionFailure -> FilePath)
-> ([SyncActionFailure] -> FilePath -> FilePath)
-> Show SyncActionFailure
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [SyncActionFailure] -> FilePath -> FilePath
$cshowList :: [SyncActionFailure] -> FilePath -> FilePath
show :: SyncActionFailure -> FilePath
$cshow :: SyncActionFailure -> FilePath
showsPrec :: Int -> SyncActionFailure -> FilePath -> FilePath
$cshowsPrec :: Int -> SyncActionFailure -> FilePath -> FilePath
Show)

-- | Roll back the chain to the given ChainPoint and slot.
runRollback :: BlockchainEnv -> ChainPoint -> STM (Either SyncActionFailure (Slot, BlockNumber))
runRollback :: BlockchainEnv
-> ChainPoint -> STM (Either SyncActionFailure (Slot, BlockNumber))
runRollback env :: BlockchainEnv
env@BlockchainEnv{TVar Slot
beLastSyncedBlockSlot :: TVar Slot
beLastSyncedBlockSlot :: BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot, Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges, TVar (UtxoIndex TxOutBalance)
beTxOutChanges :: BlockchainEnv -> TVar (UtxoIndex TxOutBalance)
beTxOutChanges :: TVar (UtxoIndex TxOutBalance)
beTxOutChanges} ChainPoint
chainPoint = do
  Slot
currentSlot <- TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beLastSyncedBlockSlot
  UtxoIndex TxOutBalance
txOutBalanceStateIndex <- TVar (UtxoIndex TxOutBalance) -> STM (UtxoIndex TxOutBalance)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxOutBalance)
beTxOutChanges

  let point :: Point
point = ChainPoint -> Point
fromCardanoPoint ChainPoint
chainPoint
      rs' :: Either RollbackFailed (RollbackResult TxOutBalance)
rs'   = Point
-> UtxoIndex TxOutBalance
-> Either RollbackFailed (RollbackResult TxOutBalance)
TxOutBalance.rollback Point
point UtxoIndex TxOutBalance
txOutBalanceStateIndex
      -- Check to see if the rollback is just through a sequence of empty blocks ending at the tip.
      emptyRollBack :: Bool
emptyRollBack =
           Point
point Point -> Point -> Bool
forall a. Ord a => a -> a -> Bool
> Tip -> Point
tipAsPoint (UtxoIndex TxOutBalance -> Tip
forall a. Monoid a => UtxoIndex a -> Tip
viewTip UtxoIndex TxOutBalance
txOutBalanceStateIndex)
        Bool -> Bool -> Bool
&& Point -> Slot
pointSlot Point
point Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
<= Slot
currentSlot

  if Bool
emptyRollBack
    then (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
    else case Either RollbackFailed (RollbackResult TxOutBalance)
rs' of
           Right RollbackResult{rolledBackIndex :: forall a. RollbackResult a -> UtxoIndex a
rolledBackIndex=UtxoIndex TxOutBalance
rolledBackTxOutBalanceStateIndex} -> do
             TVar (UtxoIndex TxOutBalance) -> UtxoIndex TxOutBalance -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (UtxoIndex TxOutBalance)
beTxOutChanges UtxoIndex TxOutBalance
rolledBackTxOutBalanceStateIndex
             case Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges of
               Left TVar (UtxoIndex TxIdState)
txChanges -> do
                 UtxoIndex TxIdState
txIdStateIndex <- TVar (UtxoIndex TxIdState) -> STM (UtxoIndex TxIdState)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxIdState)
txChanges
                 let rs :: Either RollbackFailed (RollbackResult TxIdState)
rs = Point
-> UtxoIndex TxIdState
-> Either RollbackFailed (RollbackResult TxIdState)
TxIdState.rollback Point
point UtxoIndex TxIdState
txIdStateIndex
                 case Either RollbackFailed (RollbackResult TxIdState)
rs of
                   Left RollbackFailed
e -> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SyncActionFailure (Slot, BlockNumber)
 -> STM (Either SyncActionFailure (Slot, BlockNumber)))
-> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ SyncActionFailure -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. a -> Either a b
Left (RollbackFailed -> SyncActionFailure
RollbackFailure RollbackFailed
e)
                   Right RollbackResult{rolledBackIndex :: forall a. RollbackResult a -> UtxoIndex a
rolledBackIndex=UtxoIndex TxIdState
rolledBackTxIdStateIndex} -> do
                     TVar (UtxoIndex TxIdState) -> UtxoIndex TxIdState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (UtxoIndex TxIdState)
txChanges UtxoIndex TxIdState
rolledBackTxIdStateIndex
                     (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
               Right IORef TCSIndex
_tcsIndex -> (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
           Left RollbackFailed
e' -> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SyncActionFailure (Slot, BlockNumber)
 -> STM (Either SyncActionFailure (Slot, BlockNumber)))
-> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ SyncActionFailure -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. a -> Either a b
Left (RollbackFailed -> SyncActionFailure
RollbackFailure RollbackFailed
e')

-- | Get transaction ID and validity from a transaction.
txEvent :: ChainIndexTx -> (TxId, TxOutBalance, TxValidity)
txEvent :: ChainIndexTx -> (TxId, TxOutBalance, TxValidity)
txEvent ChainIndexTx
tx = (Getting TxId ChainIndexTx TxId -> ChainIndexTx -> TxId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TxId ChainIndexTx TxId
Lens' ChainIndexTx TxId
citxTxId ChainIndexTx
tx, ChainIndexTx -> TxOutBalance
TxOutBalance.fromTx ChainIndexTx
tx, ChainIndexTx -> TxValidity
validityFromChainIndex ChainIndexTx
tx)

-- | Update the blockchain env. with changes from a new block of cardano
--   transactions in any era
processBlock :: forall era. C.IsCardanoEra era
             => InstancesState
             -> C.BlockHeader
             -> BlockchainEnv
             -> [C.Tx era]
             -> C.EraInMode era C.CardanoMode
             -> IO (Either SyncActionFailure (Slot, BlockNumber))
processBlock :: InstancesState
-> BlockHeader
-> BlockchainEnv
-> [Tx era]
-> EraInMode era CardanoMode
-> IO (Either SyncActionFailure (Slot, BlockNumber))
processBlock InstancesState
instancesState BlockHeader
header env :: BlockchainEnv
env@BlockchainEnv{Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges} [Tx era]
transactions EraInMode era CardanoMode
era = do
  let C.BlockHeader (C.SlotNo Word64
slot) Hash BlockHeader
_ BlockNo
_ = BlockHeader
header
      tip :: Tip
tip = BlockHeader -> Tip
fromCardanoBlockHeader BlockHeader
header
      ciTxs :: [ChainIndexTx]
ciTxs = EraInMode era CardanoMode -> Tx era -> ChainIndexTx
forall era.
IsCardanoEra era =>
EraInMode era CardanoMode -> Tx era -> ChainIndexTx
fromCardanoTx EraInMode era CardanoMode
era (Tx era -> ChainIndexTx) -> [Tx era] -> [ChainIndexTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx era]
transactions

  Either SyncActionFailure (Slot, BlockNumber)
stmResult <-
    if [Tx era] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tx era]
transactions
    then do
      STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a. STM a -> IO a
STM.atomically (STM (Either SyncActionFailure (Slot, BlockNumber))
 -> IO (Either SyncActionFailure (Slot, BlockNumber)))
-> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ do
        TVar Slot -> Slot -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot BlockchainEnv
env) (Word64 -> Slot
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot)
        (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
    else do
      STM InstanceClientEnv
instEnv <- InstancesState -> IO (STM InstanceClientEnv)
S.instancesClientEnv InstancesState
instancesState
      STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a. STM a -> IO a
STM.atomically (STM (Either SyncActionFailure (Slot, BlockNumber))
 -> IO (Either SyncActionFailure (Slot, BlockNumber)))
-> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ do
        InstanceClientEnv
e <- STM InstanceClientEnv
instEnv
        TVar Slot -> Slot -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot BlockchainEnv
env) (Word64 -> Slot
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot)
        IndexedBlock -> InstanceClientEnv -> STM ()
updateInstances ([ChainIndexTx] -> IndexedBlock
indexBlock [ChainIndexTx]
ciTxs) InstanceClientEnv
e
        Tip
-> BlockchainEnv
-> [(TxId, TxOutBalance, TxValidity)]
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (t :: * -> *).
Foldable t =>
Tip
-> BlockchainEnv
-> t (TxId, TxOutBalance, TxValidity)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
updateEmulatorTransactionState Tip
tip BlockchainEnv
env (ChainIndexTx -> (TxId, TxOutBalance, TxValidity)
txEvent (ChainIndexTx -> (TxId, TxOutBalance, TxValidity))
-> [ChainIndexTx] -> [(TxId, TxOutBalance, TxValidity)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ChainIndexTx]
ciTxs)

  Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
-> (TCSIndex -> IO TCSIndex) -> IO ()
S.updateTxChangesR Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges ((TCSIndex -> IO TCSIndex) -> IO ())
-> (TCSIndex -> IO TCSIndex) -> IO ()
forall a b. (a -> b) -> a -> b
$ [TxInfo] -> TCSIndex -> IO TCSIndex
forall (m :: * -> *) h (v :: * -> *) e n q r.
(Monad m, PrimMonad m, MVector (Mutable v) e) =>
e -> SplitIndex m h v e n q r -> m (SplitIndex m h v e n q r)
Ix.insert (Tip -> ChainIndexTx -> TxInfo
mkEvent Tip
tip (ChainIndexTx -> TxInfo) -> [ChainIndexTx] -> [TxInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ChainIndexTx]
ciTxs)

  Either SyncActionFailure (Slot, BlockNumber)
-> IO (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SyncActionFailure (Slot, BlockNumber)
stmResult


mkEvent :: Tip -> ChainIndexTx -> TxInfo
mkEvent :: Tip -> ChainIndexTx -> TxInfo
mkEvent Tip
TipAtGenesis  ChainIndexTx
tx =
  TxInfo :: TxId -> BlockNumber -> SlotNo -> TxInfo
TxInfo { txId :: TxId
txId        = ChainIndexTx -> TxId
_citxTxId ChainIndexTx
tx
         , slotNumber :: SlotNo
slotNumber  = Int -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
0 :: Int)
         , blockNumber :: BlockNumber
blockNumber = Int -> BlockNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
0 :: Int)
         }
mkEvent (Tip Slot
sn BlockId
_ BlockNumber
bn) ChainIndexTx
tx =
  TxInfo :: TxId -> BlockNumber -> SlotNo -> TxInfo
TxInfo { txId :: TxId
txId        = ChainIndexTx -> TxId
_citxTxId ChainIndexTx
tx
         , slotNumber :: SlotNo
slotNumber  = Slot -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
sn
         , blockNumber :: BlockNumber
blockNumber = BlockNumber
bn
         }

-- | For the given transactions, perform the updates in the 'TxIdState', and
-- also record that a new block has been processed.
updateEmulatorTransactionState
  :: Foldable t
  => Tip
  -> BlockchainEnv
  -> t (TxId, TxOutBalance, TxValidity)
  -> STM (Either SyncActionFailure (Slot, BlockNumber))
updateEmulatorTransactionState :: Tip
-> BlockchainEnv
-> t (TxId, TxOutBalance, TxValidity)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
updateEmulatorTransactionState
    Tip
tip
    env :: BlockchainEnv
env@BlockchainEnv{ Maybe Int
beRollbackHistory :: BlockchainEnv -> Maybe Int
beRollbackHistory :: Maybe Int
beRollbackHistory
                     , Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges
                     , TVar (UtxoIndex TxOutBalance)
beTxOutChanges :: TVar (UtxoIndex TxOutBalance)
beTxOutChanges :: BlockchainEnv -> TVar (UtxoIndex TxOutBalance)
beTxOutChanges
                     , TVar BlockNumber
beLastSyncedBlockNo :: TVar BlockNumber
beLastSyncedBlockNo :: BlockchainEnv -> TVar BlockNumber
beLastSyncedBlockNo
                     }
    t (TxId, TxOutBalance, TxValidity)
xs = do

    UtxoIndex TxOutBalance
txUtxoBalanceIndex <- TVar (UtxoIndex TxOutBalance) -> STM (UtxoIndex TxOutBalance)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxOutBalance)
beTxOutChanges
    let txUtxoBalance :: TxOutBalance
txUtxoBalance = UtxoState TxOutBalance -> TxOutBalance
forall a. UtxoState a -> a
_usTxUtxoData (UtxoState TxOutBalance -> TxOutBalance)
-> UtxoState TxOutBalance -> TxOutBalance
forall a b. (a -> b) -> a -> b
$ UtxoIndex TxOutBalance -> UtxoState TxOutBalance
forall a. Monoid a => UtxoIndex a -> UtxoState a
utxoState UtxoIndex TxOutBalance
txUtxoBalanceIndex
    BlockNumber
blockNumber <- TVar BlockNumber -> STM BlockNumber
forall a. TVar a -> STM a
STM.readTVar TVar BlockNumber
beLastSyncedBlockNo
    let txUtxoBalance' :: TxOutBalance
txUtxoBalance' = TxOutBalance
txUtxoBalance TxOutBalance -> TxOutBalance -> TxOutBalance
forall a. Semigroup a => a -> a -> a
<> ((TxId, TxOutBalance, TxValidity) -> TxOutBalance)
-> t (TxId, TxOutBalance, TxValidity) -> TxOutBalance
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TxId
_, TxOutBalance
b, TxValidity
_) -> TxOutBalance
b) t (TxId, TxOutBalance, TxValidity)
xs
        txUtxoBalanceInsert :: Either InsertUtxoFailed (InsertUtxoSuccess TxOutBalance)
txUtxoBalanceInsert = UtxoState TxOutBalance
-> UtxoIndex TxOutBalance
-> Either InsertUtxoFailed (InsertUtxoSuccess TxOutBalance)
forall a.
(Monoid a, Eq a) =>
UtxoState a
-> UtxoIndex a -> Either InsertUtxoFailed (InsertUtxoSuccess a)
insert (TxOutBalance -> Tip -> UtxoState TxOutBalance
forall a. a -> Tip -> UtxoState a
UtxoState TxOutBalance
txUtxoBalance' Tip
tip) UtxoIndex TxOutBalance
txUtxoBalanceIndex

    case Either InsertUtxoFailed (InsertUtxoSuccess TxOutBalance)
txUtxoBalanceInsert of
      Right InsertUtxoSuccess{newIndex :: forall a. InsertUtxoSuccess a -> UtxoIndex a
newIndex=UtxoIndex TxOutBalance
newTxOutBalance} -> do
        TVar (UtxoIndex TxOutBalance) -> UtxoIndex TxOutBalance -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (UtxoIndex TxOutBalance)
beTxOutChanges (UtxoIndex TxOutBalance -> STM ())
-> UtxoIndex TxOutBalance -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> UtxoIndex TxOutBalance -> UtxoIndex TxOutBalance
forall a. Monoid a => Maybe Int -> UtxoIndex a -> UtxoIndex a
trimIx Maybe Int
beRollbackHistory UtxoIndex TxOutBalance
newTxOutBalance
        TVar BlockNumber -> BlockNumber -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar BlockNumber
beLastSyncedBlockNo (BlockNumber -> BlockNumber
forall a. Enum a => a -> a
succ BlockNumber
blockNumber)
        -- We have to handle the case where we don't have a `UtxoState` indexer
        -- available in the environment. If this happens, it means that we have
        -- a disk based indexer which is updated outside of this function, as it
        -- requires `IO` to operate.
        case Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges of
          Left TVar (UtxoIndex TxIdState)
txChanges -> do
            UtxoIndex TxIdState
txIdStateIndex     <- TVar (UtxoIndex TxIdState) -> STM (UtxoIndex TxIdState)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxIdState)
txChanges
            let txIdState :: TxIdState
txIdState       = UtxoState TxIdState -> TxIdState
forall a. UtxoState a -> a
_usTxUtxoData (UtxoState TxIdState -> TxIdState)
-> UtxoState TxIdState -> TxIdState
forall a b. (a -> b) -> a -> b
$ UtxoIndex TxIdState -> UtxoState TxIdState
forall a. Monoid a => UtxoIndex a -> UtxoState a
utxoState UtxoIndex TxIdState
txIdStateIndex
                txIdState' :: TxIdState
txIdState'      = (TxIdState -> (TxId, TxOutBalance, TxValidity) -> TxIdState)
-> TxIdState -> t (TxId, TxOutBalance, TxValidity) -> TxIdState
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (BlockNumber
-> TxIdState -> (TxId, TxOutBalance, TxValidity) -> TxIdState
insertNewTx BlockNumber
blockNumber) TxIdState
txIdState t (TxId, TxOutBalance, TxValidity)
xs
                txIdStateInsert :: Either InsertUtxoFailed (InsertUtxoSuccess TxIdState)
txIdStateInsert = UtxoState TxIdState
-> UtxoIndex TxIdState
-> Either InsertUtxoFailed (InsertUtxoSuccess TxIdState)
forall a.
(Monoid a, Eq a) =>
UtxoState a
-> UtxoIndex a -> Either InsertUtxoFailed (InsertUtxoSuccess a)
insert (TxIdState -> Tip -> UtxoState TxIdState
forall a. a -> Tip -> UtxoState a
UtxoState TxIdState
txIdState' Tip
tip) UtxoIndex TxIdState
txIdStateIndex
            case Either InsertUtxoFailed (InsertUtxoSuccess TxIdState)
txIdStateInsert of
              Right InsertUtxoSuccess{newIndex :: forall a. InsertUtxoSuccess a -> UtxoIndex a
newIndex=UtxoIndex TxIdState
newTxIdState} -> do
                TVar (UtxoIndex TxIdState) -> UtxoIndex TxIdState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (UtxoIndex TxIdState)
txChanges (UtxoIndex TxIdState -> STM ()) -> UtxoIndex TxIdState -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> UtxoIndex TxIdState -> UtxoIndex TxIdState
forall a. Monoid a => Maybe Int -> UtxoIndex a -> UtxoIndex a
trimIx Maybe Int
beRollbackHistory UtxoIndex TxIdState
newTxIdState
                (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
              -- We have an in-memory indexer, but for some reason it failed to
              -- insert the Utxo
              Left InsertUtxoFailed
e -> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SyncActionFailure (Slot, BlockNumber)
 -> STM (Either SyncActionFailure (Slot, BlockNumber)))
-> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ SyncActionFailure -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. a -> Either a b
Left (SyncActionFailure -> Either SyncActionFailure (Slot, BlockNumber))
-> SyncActionFailure
-> Either SyncActionFailure (Slot, BlockNumber)
forall a b. (a -> b) -> a -> b
$ InsertUtxoFailed -> SyncActionFailure
InsertUtxoStateFailure InsertUtxoFailed
e
          Right IORef TCSIndex
_ ->
            -- This means that there is no in-memory indexer available, so we are
            -- using the on-disk one, so we just return all-is-fine.
            (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right ((Slot, BlockNumber)
 -> Either SyncActionFailure (Slot, BlockNumber))
-> STM (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockchainEnv -> STM (Slot, BlockNumber)
blockAndSlot BlockchainEnv
env
      Left InsertUtxoFailed
e -> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SyncActionFailure (Slot, BlockNumber)
 -> STM (Either SyncActionFailure (Slot, BlockNumber)))
-> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ SyncActionFailure -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. a -> Either a b
Left (SyncActionFailure -> Either SyncActionFailure (Slot, BlockNumber))
-> SyncActionFailure
-> Either SyncActionFailure (Slot, BlockNumber)
forall a b. (a -> b) -> a -> b
$ InsertUtxoFailed -> SyncActionFailure
InsertUtxoStateFailure InsertUtxoFailed
e

    where
      trimIx :: Monoid a => Maybe Int -> UtxoIndex a -> UtxoIndex a
      trimIx :: Maybe Int -> UtxoIndex a -> UtxoIndex a
trimIx Maybe Int
Nothing                UtxoIndex a
uix = UtxoIndex a
uix
      trimIx (Just Int
rollbackHistory) UtxoIndex a
uix =
        case Depth -> UtxoIndex a -> ReduceBlockCountResult a
forall a.
Monoid a =>
Depth -> UtxoIndex a -> ReduceBlockCountResult a
reduceBlockCount (Int -> Depth
Depth Int
rollbackHistory) UtxoIndex a
uix of
          ReduceBlockCountResult a
BlockCountNotReduced          -> UtxoIndex a
uix
          ReduceBlockCountResult UtxoIndex a
uix' UtxoState a
_ -> UtxoIndex a
uix'

insertNewTx :: BlockNumber -> TxIdState -> (TxId, TxOutBalance, TxValidity) -> TxIdState
insertNewTx :: BlockNumber
-> TxIdState -> (TxId, TxOutBalance, TxValidity) -> TxIdState
insertNewTx BlockNumber
blockNumber TxIdState{Map TxId TxConfirmedState
txnsConfirmed :: TxIdState -> Map TxId TxConfirmedState
txnsConfirmed :: Map TxId TxConfirmedState
txnsConfirmed, Map TxId (Sum Int)
txnsDeleted :: TxIdState -> Map TxId (Sum Int)
txnsDeleted :: Map TxId (Sum Int)
txnsDeleted} (TxId
txi, TxOutBalance
_, TxValidity
txValidity) =
  let newConfirmed :: Map TxId TxConfirmedState
newConfirmed = Map TxId TxConfirmedState
txnsConfirmed Map TxId TxConfirmedState
-> (Map TxId TxConfirmedState -> Map TxId TxConfirmedState)
-> Map TxId TxConfirmedState
forall a b. a -> (a -> b) -> b
& Index (Map TxId TxConfirmedState)
-> Lens'
     (Map TxId TxConfirmedState)
     (Maybe (IxValue (Map TxId TxConfirmedState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map TxId TxConfirmedState)
TxId
txi ((Maybe TxConfirmedState -> Identity (Maybe TxConfirmedState))
 -> Map TxId TxConfirmedState
 -> Identity (Map TxId TxConfirmedState))
-> TxConfirmedState
-> Map TxId TxConfirmedState
-> Map TxId TxConfirmedState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TxConfirmedState
newV
   in Map TxId TxConfirmedState -> Map TxId (Sum Int) -> TxIdState
TxIdState (Map TxId TxConfirmedState
txnsConfirmed Map TxId TxConfirmedState
-> Map TxId TxConfirmedState -> Map TxId TxConfirmedState
forall a. Semigroup a => a -> a -> a
<> Map TxId TxConfirmedState
newConfirmed) Map TxId (Sum Int)
txnsDeleted
    where
      -- New state; we rely on the monoid instance to make this agree with any
      -- existing transactions already present (but perhaps rolled back.)
      newV :: TxConfirmedState
newV = 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 (BlockNumber -> Maybe BlockNumber
forall a. a -> Maybe a
Just BlockNumber
blockNumber)
              , validity :: Last TxValidity
validity       = Maybe TxValidity -> Last TxValidity
forall a. Maybe a -> Last a
Last (TxValidity -> Maybe TxValidity
forall a. a -> Maybe a
Just TxValidity
txValidity)
              }

-- | Go through the transactions in a block, updating the 'BlockchainEnv'
--   when any interesting addresses or transactions have changed.
processMockBlock
    :: InstancesState
    -> BlockchainEnv
    -> Block
    -> Slot
    -> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
processMockBlock :: InstancesState
-> BlockchainEnv
-> Block
-> Slot
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
processMockBlock
  InstancesState
instancesState
  env :: BlockchainEnv
env@BlockchainEnv{TVar Slot
beCurrentSlot :: TVar Slot
beCurrentSlot :: BlockchainEnv -> TVar Slot
beCurrentSlot, TVar Slot
beLastSyncedBlockSlot :: TVar Slot
beLastSyncedBlockSlot :: BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot, TVar BlockNumber
beLastSyncedBlockNo :: TVar BlockNumber
beLastSyncedBlockNo :: BlockchainEnv -> TVar BlockNumber
beLastSyncedBlockNo}
  Block
transactions
  Slot
slot = do

  if Block -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Block
transactions
    then STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STM (Either SyncActionFailure (Slot, BlockNumber))
 -> IO (STM (Either SyncActionFailure (Slot, BlockNumber))))
-> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
forall a b. (a -> b) -> a -> b
$ do
      STM ()
updateSlot
      (Slot, BlockNumber)
result <- (,) (Slot -> BlockNumber -> (Slot, BlockNumber))
-> STM Slot -> STM (BlockNumber -> (Slot, BlockNumber))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beLastSyncedBlockSlot STM (BlockNumber -> (Slot, BlockNumber))
-> STM BlockNumber -> STM (Slot, BlockNumber)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar BlockNumber -> STM BlockNumber
forall a. TVar a -> STM a
STM.readTVar TVar BlockNumber
beLastSyncedBlockNo
      Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SyncActionFailure (Slot, BlockNumber)
 -> STM (Either SyncActionFailure (Slot, BlockNumber)))
-> Either SyncActionFailure (Slot, BlockNumber)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall a b. (a -> b) -> a -> b
$ (Slot, BlockNumber) -> Either SyncActionFailure (Slot, BlockNumber)
forall a b. b -> Either a b
Right (Slot, BlockNumber)
result
    else do
      STM InstanceClientEnv
instEnv <- InstancesState -> IO (STM InstanceClientEnv)
S.instancesClientEnv InstancesState
instancesState
      STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STM (Either SyncActionFailure (Slot, BlockNumber))
 -> IO (STM (Either SyncActionFailure (Slot, BlockNumber))))
-> STM (Either SyncActionFailure (Slot, BlockNumber))
-> IO (STM (Either SyncActionFailure (Slot, BlockNumber)))
forall a b. (a -> b) -> a -> b
$ do
        STM ()
updateSlot
        BlockNumber
blockNumber <- TVar BlockNumber -> STM BlockNumber
forall a. TVar a -> STM a
STM.readTVar TVar BlockNumber
beLastSyncedBlockNo
        InstanceClientEnv
e <- STM InstanceClientEnv
instEnv
        IndexedBlock -> InstanceClientEnv -> STM ()
updateInstances ([ChainIndexTx] -> IndexedBlock
indexBlock ([ChainIndexTx] -> IndexedBlock) -> [ChainIndexTx] -> IndexedBlock
forall a b. (a -> b) -> a -> b
$ (OnChainTx -> ChainIndexTx) -> Block -> [ChainIndexTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OnChainTx -> ChainIndexTx
fromOnChainTx Block
transactions) InstanceClientEnv
e

        let tip :: Tip
tip = Tip :: Slot -> BlockId -> BlockNumber -> Tip
Tip { tipSlot :: Slot
tipSlot = Slot
slot
                      , tipBlockId :: BlockId
tipBlockId = Block -> BlockId
blockId Block
transactions
                      , tipBlockNo :: BlockNumber
tipBlockNo = BlockNumber
blockNumber
                      }

        Tip
-> BlockchainEnv
-> [(TxId, TxOutBalance, TxValidity)]
-> STM (Either SyncActionFailure (Slot, BlockNumber))
forall (t :: * -> *).
Foldable t =>
Tip
-> BlockchainEnv
-> t (TxId, TxOutBalance, TxValidity)
-> STM (Either SyncActionFailure (Slot, BlockNumber))
updateEmulatorTransactionState Tip
tip BlockchainEnv
env (ChainIndexTx -> (TxId, TxOutBalance, TxValidity)
txEvent (ChainIndexTx -> (TxId, TxOutBalance, TxValidity))
-> [ChainIndexTx] -> [(TxId, TxOutBalance, TxValidity)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OnChainTx -> ChainIndexTx) -> Block -> [ChainIndexTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OnChainTx -> ChainIndexTx
fromOnChainTx Block
transactions)


  where
    updateSlot :: STM ()
updateSlot = do
      -- In the mock node, contrary to the actual node, the last synced block slot
      -- and the actual slot is the same.
      Slot
lastSyncedBlockSlot <- TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beLastSyncedBlockSlot
      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Slot
slot Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
> Slot
lastSyncedBlockSlot) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
        TVar Slot -> Slot -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Slot
beLastSyncedBlockSlot Slot
slot

      Slot
lastCurrentSlot <- TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beCurrentSlot
      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Slot
slot Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
> Slot
lastCurrentSlot ) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
        TVar Slot -> Slot -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Slot
beCurrentSlot Slot
slot