{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE MonoLocalBinds    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}

module Cardano.ChainIndex.ChainIndex
    ( processChainIndexEffects
    , syncState
    ) where

import Cardano.BM.Data.Trace (Trace)
import Control.Concurrent.STM (TVar)
import Control.Concurrent.STM qualified as STM
import Control.Monad.Freer
import Control.Monad.Freer.Error (runError)
import Control.Monad.Freer.State qualified as Eff
import Control.Monad.IO.Class (MonadIO (..))
import Ledger.Blockchain (Block)
import Ledger.Slot (Slot)

import Cardano.ChainIndex.Types
import Plutus.ChainIndex.Emulator (ChainIndexEmulatorState, ChainIndexLog)
import Plutus.ChainIndex.Emulator qualified as ChainIndex
import Plutus.PAB.Monitoring.Monitoring (convertLog, handleLogMsgTrace)
import Plutus.Trace.Emulator.System (appendNewTipBlock)

-- | Update the chain index by asking the node for new blocks since the last
--   time.
syncState ::
    ( Member ChainIndex.ChainIndexControlEffect effs
    , Member ChainIndex.ChainIndexQueryEffect effs
    )
    => Block
    -> Slot
    -> Eff effs ()
syncState :: Block -> Slot -> Eff effs ()
syncState Block
block Slot
slot = do
    Tip
currentTip <- Eff effs Tip
forall (effs :: [* -> *]).
Member ChainIndexQueryEffect effs =>
Eff effs Tip
ChainIndex.getTip
    Tip -> Block -> Slot -> Eff effs ()
forall (effs :: [* -> *]).
Member ChainIndexControlEffect effs =>
Tip -> Block -> Slot -> Eff effs ()
appendNewTipBlock Tip
currentTip Block
block Slot
slot

-- | Process the chain index effects for the emulator.
processChainIndexEffects ::
    MonadIO m
    => ChainIndexTrace
    -> TVar ChainIndexEmulatorState
    -> Eff (ChainIndexEffects IO) a
    -> m a
processChainIndexEffects :: ChainIndexTrace
-> TVar ChainIndexEmulatorState
-> Eff (ChainIndexEffects IO) a
-> m a
processChainIndexEffects ChainIndexTrace
trace TVar ChainIndexEmulatorState
stateVar Eff (ChainIndexEffects IO) a
eff = do
  ChainIndexEmulatorState
emState <- IO ChainIndexEmulatorState -> m ChainIndexEmulatorState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChainIndexEmulatorState -> m ChainIndexEmulatorState)
-> IO ChainIndexEmulatorState -> m ChainIndexEmulatorState
forall a b. (a -> b) -> a -> b
$ STM ChainIndexEmulatorState -> IO ChainIndexEmulatorState
forall a. STM a -> IO a
STM.atomically (STM ChainIndexEmulatorState -> IO ChainIndexEmulatorState)
-> STM ChainIndexEmulatorState -> IO ChainIndexEmulatorState
forall a b. (a -> b) -> a -> b
$ TVar ChainIndexEmulatorState -> STM ChainIndexEmulatorState
forall a. TVar a -> STM a
STM.readTVar TVar ChainIndexEmulatorState
stateVar
  Either ChainIndexError (a, ChainIndexEmulatorState)
resultE <- IO (Either ChainIndexError (a, ChainIndexEmulatorState))
-> m (Either ChainIndexError (a, ChainIndexEmulatorState))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ChainIndexError (a, ChainIndexEmulatorState))
 -> m (Either ChainIndexError (a, ChainIndexEmulatorState)))
-> IO (Either ChainIndexError (a, ChainIndexEmulatorState))
-> m (Either ChainIndexError (a, ChainIndexEmulatorState))
forall a b. (a -> b) -> a -> b
$
        Eff '[IO] (Either ChainIndexError (a, ChainIndexEmulatorState))
-> IO (Either ChainIndexError (a, ChainIndexEmulatorState))
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM
        (Eff '[IO] (Either ChainIndexError (a, ChainIndexEmulatorState))
 -> IO (Either ChainIndexError (a, ChainIndexEmulatorState)))
-> Eff '[IO] (Either ChainIndexError (a, ChainIndexEmulatorState))
-> IO (Either ChainIndexError (a, ChainIndexEmulatorState))
forall a b. (a -> b) -> a -> b
$ Eff '[Error ChainIndexError, IO] (a, ChainIndexEmulatorState)
-> Eff '[IO] (Either ChainIndexError (a, ChainIndexEmulatorState))
forall e (effs :: [* -> *]) a.
Eff (Error e : effs) a -> Eff effs (Either e a)
runError
        (Eff '[Error ChainIndexError, IO] (a, ChainIndexEmulatorState)
 -> Eff '[IO] (Either ChainIndexError (a, ChainIndexEmulatorState)))
-> Eff '[Error ChainIndexError, IO] (a, ChainIndexEmulatorState)
-> Eff '[IO] (Either ChainIndexError (a, ChainIndexEmulatorState))
forall a b. (a -> b) -> a -> b
$ (LogMsg ChainIndexLog ~> Eff '[Error ChainIndexError, IO])
-> Eff '[LogMsg ChainIndexLog, Error ChainIndexError, IO]
   ~> Eff '[Error ChainIndexError, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Trace IO ChainIndexLog
-> LogMsg ChainIndexLog ~> Eff '[Error ChainIndexError, IO]
forall a (m :: * -> *) (effs :: [* -> *]).
(LastMember m effs, MonadIO m) =>
Trace m a -> LogMsg a ~> Eff effs
handleLogMsgTrace (ChainIndexTrace -> Trace IO ChainIndexLog
forall (m :: * -> *).
Trace m ChainIndexServerMsg -> Trace m ChainIndexLog
toChainIndexServerMsg ChainIndexTrace
trace))
        (Eff
   '[LogMsg ChainIndexLog, Error ChainIndexError, IO]
   (a, ChainIndexEmulatorState)
 -> Eff '[Error ChainIndexError, IO] (a, ChainIndexEmulatorState))
-> Eff
     '[LogMsg ChainIndexLog, Error ChainIndexError, IO]
     (a, ChainIndexEmulatorState)
-> Eff '[Error ChainIndexError, IO] (a, ChainIndexEmulatorState)
forall a b. (a -> b) -> a -> b
$ ChainIndexEmulatorState
-> Eff
     '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
       Error ChainIndexError, IO]
     a
-> Eff
     '[LogMsg ChainIndexLog, Error ChainIndexError, IO]
     (a, ChainIndexEmulatorState)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
Eff.runState ChainIndexEmulatorState
emState
        (Eff
   '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
     Error ChainIndexError, IO]
   a
 -> Eff
      '[LogMsg ChainIndexLog, Error ChainIndexError, IO]
      (a, ChainIndexEmulatorState))
-> Eff
     '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
       Error ChainIndexError, IO]
     a
-> Eff
     '[LogMsg ChainIndexLog, Error ChainIndexError, IO]
     (a, ChainIndexEmulatorState)
forall a b. (a -> b) -> a -> b
$ (ChainIndexQueryEffect
 ~> Eff
      '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
        Error ChainIndexError, IO])
-> Eff
     '[ChainIndexQueryEffect, State ChainIndexEmulatorState,
       LogMsg ChainIndexLog, Error ChainIndexError, IO]
   ~> Eff
        '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
          Error ChainIndexError, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret forall (effs :: [* -> *]).
(Member (State ChainIndexEmulatorState) effs,
 Member (Error ChainIndexError) effs,
 Member (LogMsg ChainIndexLog) effs) =>
ChainIndexQueryEffect ~> Eff effs
ChainIndexQueryEffect
~> Eff
     '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
       Error ChainIndexError, IO]
ChainIndex.handleQuery
        (Eff
   '[ChainIndexQueryEffect, State ChainIndexEmulatorState,
     LogMsg ChainIndexLog, Error ChainIndexError, IO]
   a
 -> Eff
      '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
        Error ChainIndexError, IO]
      a)
-> Eff
     '[ChainIndexQueryEffect, State ChainIndexEmulatorState,
       LogMsg ChainIndexLog, Error ChainIndexError, IO]
     a
-> Eff
     '[State ChainIndexEmulatorState, LogMsg ChainIndexLog,
       Error ChainIndexError, IO]
     a
forall a b. (a -> b) -> a -> b
$ (ChainIndexControlEffect
 ~> Eff
      '[ChainIndexQueryEffect, State ChainIndexEmulatorState,
        LogMsg ChainIndexLog, Error ChainIndexError, IO])
-> Eff (ChainIndexEffects IO) a
-> Eff
     '[ChainIndexQueryEffect, State ChainIndexEmulatorState,
       LogMsg ChainIndexLog, Error ChainIndexError, IO]
     a
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret forall (effs :: [* -> *]).
(Member (State ChainIndexEmulatorState) effs,
 Member (Error ChainIndexError) effs,
 Member (LogMsg ChainIndexLog) effs) =>
ChainIndexControlEffect ~> Eff effs
ChainIndexControlEffect
~> Eff
     '[ChainIndexQueryEffect, State ChainIndexEmulatorState,
       LogMsg ChainIndexLog, Error ChainIndexError, IO]
ChainIndex.handleControl Eff (ChainIndexEffects IO) a
eff
  case Either ChainIndexError (a, ChainIndexEmulatorState)
resultE of
    Left ChainIndexError
e -> [Char] -> m a
forall a. HasCallStack => [Char] -> a
error (ChainIndexError -> [Char]
forall a. Show a => a -> [Char]
show ChainIndexError
e)
    Right (a
result, ChainIndexEmulatorState
newEmState) -> do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ChainIndexEmulatorState -> ChainIndexEmulatorState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar ChainIndexEmulatorState
stateVar ChainIndexEmulatorState
newEmState
      a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
  where
      toChainIndexServerMsg :: Trace m ChainIndexServerMsg -> Trace m ChainIndexLog
      toChainIndexServerMsg :: Trace m ChainIndexServerMsg -> Trace m ChainIndexLog
toChainIndexServerMsg = (ChainIndexLog -> ChainIndexServerMsg)
-> Trace m ChainIndexServerMsg -> Trace m ChainIndexLog
forall a b (m :: * -> *). (a -> b) -> Trace m b -> Trace m a
convertLog ChainIndexLog -> ChainIndexServerMsg
ChainEvent