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

module Cardano.ChainIndex.Server(
    -- $chainIndex
    main
    , ChainIndexConfig(..)
    , ChainIndexServerMsg
    ) where

import Control.Concurrent.Availability (Availability, available)
import Control.Concurrent.STM (TVar)
import Control.Concurrent.STM qualified as STM
import Control.Monad.Freer.Extras.Log
import Servant.Client (BaseUrl (baseUrlPort))

import Data.Coerce (coerce)
import Plutus.Monitoring.Util (runLogEffects)

import Cardano.ChainIndex.ChainIndex (processChainIndexEffects, syncState)
import Cardano.Node.Emulator.Internal.Node (Params (..))
import Control.Monad.IO.Class (MonadIO (..))
import Ledger.Blockchain (Block)

import Cardano.ChainIndex.Types
import Cardano.Protocol.Socket.Mock.Client (runChainSync)
import Ledger.Slot (Slot (..))
import Plutus.ChainIndex.Emulator (ChainIndexEmulatorState, serveChainIndexQueryServer)

-- $chainIndex
-- The PAB chain index that keeps track of transaction data (UTXO set enriched
-- with datums)

main :: ChainIndexTrace -> ChainIndexConfig -> FilePath -> Params -> Availability -> IO ()
main :: ChainIndexTrace
-> ChainIndexConfig -> FilePath -> Params -> Availability -> IO ()
main ChainIndexTrace
trace ChainIndexConfig{ChainIndexUrl
ciBaseUrl :: ChainIndexConfig -> ChainIndexUrl
ciBaseUrl :: ChainIndexUrl
ciBaseUrl} FilePath
socketPath Params{SlotConfig
pSlotConfig :: Params -> SlotConfig
pSlotConfig :: SlotConfig
pSlotConfig} Availability
ccaAvailability = ChainIndexTrace -> Eff '[LogMsg ChainIndexServerMsg, IO] ~> IO
forall (m :: * -> *) l.
MonadIO m =>
Trace m l -> Eff '[LogMsg l, m] ~> m
runLogEffects ChainIndexTrace
trace (Eff '[LogMsg ChainIndexServerMsg, IO] () -> IO ())
-> Eff '[LogMsg ChainIndexServerMsg, IO] () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TVar ChainIndexEmulatorState
tVarState <- IO (TVar ChainIndexEmulatorState)
-> Eff
     '[LogMsg ChainIndexServerMsg, IO] (TVar ChainIndexEmulatorState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar ChainIndexEmulatorState)
 -> Eff
      '[LogMsg ChainIndexServerMsg, IO] (TVar ChainIndexEmulatorState))
-> IO (TVar ChainIndexEmulatorState)
-> Eff
     '[LogMsg ChainIndexServerMsg, IO] (TVar ChainIndexEmulatorState)
forall a b. (a -> b) -> a -> b
$ STM (TVar ChainIndexEmulatorState)
-> IO (TVar ChainIndexEmulatorState)
forall a. STM a -> IO a
STM.atomically (STM (TVar ChainIndexEmulatorState)
 -> IO (TVar ChainIndexEmulatorState))
-> STM (TVar ChainIndexEmulatorState)
-> IO (TVar ChainIndexEmulatorState)
forall a b. (a -> b) -> a -> b
$ ChainIndexEmulatorState -> STM (TVar ChainIndexEmulatorState)
forall a. a -> STM (TVar a)
STM.newTVar ChainIndexEmulatorState
forall a. Monoid a => a
mempty

    ChainIndexServerMsg -> Eff '[LogMsg ChainIndexServerMsg, IO] ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo ChainIndexServerMsg
StartingNodeClientThread
    ChainSyncHandle Block
_ <- IO (ChainSyncHandle Block)
-> Eff '[LogMsg ChainIndexServerMsg, IO] (ChainSyncHandle Block)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ChainSyncHandle Block)
 -> Eff '[LogMsg ChainIndexServerMsg, IO] (ChainSyncHandle Block))
-> IO (ChainSyncHandle Block)
-> Eff '[LogMsg ChainIndexServerMsg, IO] (ChainSyncHandle Block)
forall a b. (a -> b) -> a -> b
$ FilePath
-> SlotConfig
-> (Block -> Slot -> IO ())
-> IO (ChainSyncHandle Block)
runChainSync FilePath
socketPath SlotConfig
pSlotConfig ((Block -> Slot -> IO ()) -> IO (ChainSyncHandle Block))
-> (Block -> Slot -> IO ()) -> IO (ChainSyncHandle Block)
forall a b. (a -> b) -> a -> b
$ TVar ChainIndexEmulatorState -> Block -> Slot -> IO ()
updateChainState TVar ChainIndexEmulatorState
tVarState

    ChainIndexServerMsg -> Eff '[LogMsg ChainIndexServerMsg, IO] ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (ChainIndexServerMsg -> Eff '[LogMsg ChainIndexServerMsg, IO] ())
-> ChainIndexServerMsg -> Eff '[LogMsg ChainIndexServerMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Int -> ChainIndexServerMsg
StartingChainIndex Int
servicePort
    Availability -> Eff '[LogMsg ChainIndexServerMsg, IO] ()
forall (m :: * -> *). MonadIO m => Availability -> m ()
available Availability
ccaAvailability
    IO () -> Eff '[LogMsg ChainIndexServerMsg, IO] ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff '[LogMsg ChainIndexServerMsg, IO] ())
-> IO () -> Eff '[LogMsg ChainIndexServerMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Int -> TVar ChainIndexEmulatorState -> IO ()
serveChainIndexQueryServer Int
servicePort TVar ChainIndexEmulatorState
tVarState
    where
        servicePort :: Int
servicePort = BaseUrl -> Int
baseUrlPort (ChainIndexUrl -> BaseUrl
coerce ChainIndexUrl
ciBaseUrl)
        updateChainState :: TVar ChainIndexEmulatorState -> Block -> Slot -> IO ()
        updateChainState :: TVar ChainIndexEmulatorState -> Block -> Slot -> IO ()
updateChainState TVar ChainIndexEmulatorState
tv Block
block Slot
slot = do
          ChainIndexTrace
-> TVar ChainIndexEmulatorState
-> Eff (ChainIndexEffects IO) ()
-> IO ()
forall (m :: * -> *) a.
MonadIO m =>
ChainIndexTrace
-> TVar ChainIndexEmulatorState
-> Eff (ChainIndexEffects IO) a
-> m a
processChainIndexEffects ChainIndexTrace
trace TVar ChainIndexEmulatorState
tv (Eff (ChainIndexEffects IO) () -> IO ())
-> Eff (ChainIndexEffects IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ Block -> Slot -> Eff (ChainIndexEffects IO) ()
forall (effs :: [* -> *]).
(Member ChainIndexControlEffect effs,
 Member ChainIndexQueryEffect effs) =>
Block -> Slot -> Eff effs ()
syncState Block
block Slot
slot