{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-| Main entry points to the chain index.
-}
module Plutus.ChainIndex.App(main, runMain, runMainWithLog) where

import Control.Exception (throwIO)
import Data.Aeson qualified as A
import Data.Foldable (for_)
import Data.Function ((&))
import Data.Yaml qualified as Y
import Options.Applicative (execParser)
import Prettyprinter (Pretty (pretty))

import Cardano.BM.Configuration.Model qualified as CM

import Cardano.BM.Setup (setupTrace_)
import Cardano.BM.Trace (Trace)
import Control.Concurrent.Async (wait, withAsync)
import Control.Concurrent.STM.TBMQueue (newTBMQueueIO)
import Plutus.ChainIndex.CommandLine (AppConfig (AppConfig, acCLIConfigOverrides, acCommand, acConfigPath, acLogConfigPath, acMinLogLevel),
                                      Command (DumpDefaultConfig, DumpDefaultLoggingConfig, StartChainIndex),
                                      applyOverrides, cmdWithHelpParser)
import Plutus.ChainIndex.Compatibility (fromCardanoBlockNo)
import Plutus.ChainIndex.Config qualified as Config
import Plutus.ChainIndex.Events (measureEventQueueSizeByTxs, processEventsQueue)
import Plutus.ChainIndex.Lib (getTipSlot, storeChainSyncHandler, storeFromBlockNo, syncChainIndex, withRunRequirements)
import Plutus.ChainIndex.Logging qualified as Logging
import Plutus.ChainIndex.Server qualified as Server
import Plutus.ChainIndex.SyncStats (SyncLog)
import Plutus.Monitoring.Util (PrettyObject)
import System.Exit (exitFailure)

main :: IO ()
main :: IO ()
main = do
  -- Parse comand line arguments.
  cmdConfig :: AppConfig
cmdConfig@AppConfig{Maybe FilePath
acLogConfigPath :: Maybe FilePath
acLogConfigPath :: AppConfig -> Maybe FilePath
acLogConfigPath, Maybe FilePath
acConfigPath :: Maybe FilePath
acConfigPath :: AppConfig -> Maybe FilePath
acConfigPath, Maybe Severity
acMinLogLevel :: Maybe Severity
acMinLogLevel :: AppConfig -> Maybe Severity
acMinLogLevel, Command
acCommand :: Command
acCommand :: AppConfig -> Command
acCommand, CLIConfigOverrides
acCLIConfigOverrides :: CLIConfigOverrides
acCLIConfigOverrides :: AppConfig -> CLIConfigOverrides
acCLIConfigOverrides} <- ParserInfo AppConfig -> IO AppConfig
forall a. ParserInfo a -> IO a
execParser ParserInfo AppConfig
cmdWithHelpParser

  case Command
acCommand of
    DumpDefaultConfig FilePath
path ->
      FilePath -> ChainIndexConfig -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
A.encodeFile FilePath
path ChainIndexConfig
Config.defaultConfig

    DumpDefaultLoggingConfig FilePath
path ->
      IO Configuration
Logging.defaultConfig IO Configuration
-> (Configuration -> IO Representation) -> IO Representation
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Configuration -> IO Representation
CM.toRepresentation IO Representation -> (Representation -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Representation -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Y.encodeFile FilePath
path

    StartChainIndex {} -> do
      -- Initialise logging
      Configuration
logConfig <- IO Configuration
-> (FilePath -> IO Configuration)
-> Maybe FilePath
-> IO Configuration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Configuration
Logging.defaultConfig FilePath -> IO Configuration
Logging.loadConfig Maybe FilePath
acLogConfigPath
      Maybe Severity -> (Severity -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Severity
acMinLogLevel ((Severity -> IO ()) -> IO ()) -> (Severity -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Severity
ll -> Configuration -> Severity -> IO ()
CM.setMinSeverity Configuration
logConfig Severity
ll

      -- Reading configuration file
      ChainIndexConfig
config <- CLIConfigOverrides -> ChainIndexConfig -> ChainIndexConfig
applyOverrides CLIConfigOverrides
acCLIConfigOverrides (ChainIndexConfig -> ChainIndexConfig)
-> IO ChainIndexConfig -> IO ChainIndexConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe FilePath
acConfigPath of
        Maybe FilePath
Nothing -> ChainIndexConfig -> IO ChainIndexConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainIndexConfig
Config.defaultConfig
        Just FilePath
p  -> FilePath -> IO (Either FilePath ChainIndexConfig)
forall a. FromJSON a => FilePath -> IO (Either FilePath a)
A.eitherDecodeFileStrict FilePath
p IO (Either FilePath ChainIndexConfig)
-> (Either FilePath ChainIndexConfig -> IO ChainIndexConfig)
-> IO ChainIndexConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          (FilePath -> IO ChainIndexConfig)
-> (ChainIndexConfig -> IO ChainIndexConfig)
-> Either FilePath ChainIndexConfig
-> IO ChainIndexConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DecodeConfigException -> IO ChainIndexConfig
forall e a. Exception e => e -> IO a
throwIO (DecodeConfigException -> IO ChainIndexConfig)
-> (FilePath -> DecodeConfigException)
-> FilePath
-> IO ChainIndexConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> DecodeConfigException
Config.DecodeConfigException) ChainIndexConfig -> IO ChainIndexConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure

      FilePath -> IO ()
putStrLn FilePath
"\nCommand line config:"
      AppConfig -> IO ()
forall a. Show a => a -> IO ()
print AppConfig
cmdConfig

      FilePath -> IO ()
putStrLn FilePath
"\nLogging config:"
      Configuration -> IO Representation
CM.toRepresentation Configuration
logConfig IO Representation -> (Representation -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Representation -> IO ()
forall a. Show a => a -> IO ()
print

      FilePath -> IO ()
putStrLn FilePath
"\nChain Index config:"
      Doc Any -> IO ()
forall a. Show a => a -> IO ()
print (ChainIndexConfig -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty ChainIndexConfig
config)

      Configuration -> ChainIndexConfig -> IO ()
runMain Configuration
logConfig ChainIndexConfig
config

runMain :: CM.Configuration -> Config.ChainIndexConfig -> IO ()
runMain :: Configuration -> ChainIndexConfig -> IO ()
runMain = (FilePath -> IO ()) -> Configuration -> ChainIndexConfig -> IO ()
runMainWithLog FilePath -> IO ()
putStrLn

-- Run main with provided function to log startup logs.
runMainWithLog :: (String -> IO ()) -> CM.Configuration -> Config.ChainIndexConfig -> IO ()
runMainWithLog :: (FilePath -> IO ()) -> Configuration -> ChainIndexConfig -> IO ()
runMainWithLog FilePath -> IO ()
logger Configuration
logConfig ChainIndexConfig
config = do
  Configuration
-> ChainIndexConfig -> (RunRequirements -> IO ()) -> IO ()
withRunRequirements Configuration
logConfig ChainIndexConfig
config ((RunRequirements -> IO ()) -> IO ())
-> (RunRequirements -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RunRequirements
runReq -> do

    Maybe SlotNo
mslotNo <- ChainIndexConfig -> IO (Maybe SlotNo)
getTipSlot ChainIndexConfig
config
    case Maybe SlotNo
mslotNo of
      Just SlotNo
slotNo -> do
        let slotNoStr :: FilePath
slotNoStr = FilePath
"\nThe tip of the local node: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
slotNo
        FilePath -> IO ()
logger FilePath
slotNoStr
      Maybe SlotNo
Nothing -> do
        FilePath -> IO ()
putStrLn FilePath
"\nLocal node still at Genesis Tip !!!"
        IO ()
forall a. IO a
exitFailure

    -- Queue for processing events
    let maxQueueSize :: Natural
maxQueueSize = ChainIndexConfig -> Natural
Config.cicAppendTransactionQueueSize ChainIndexConfig
config
    TBMQueue ChainSyncEvent
eventsQueue <- Natural
-> (ChainSyncEvent -> Natural) -> IO (TBMQueue ChainSyncEvent)
forall a. Natural -> (a -> Natural) -> IO (TBMQueue a)
newTBMQueueIO Natural
maxQueueSize (Natural -> ChainSyncEvent -> Natural
measureEventQueueSizeByTxs Natural
maxQueueSize)
    ChainSyncHandler
syncHandler
      <- TBMQueue ChainSyncEvent -> ChainSyncHandler
storeChainSyncHandler TBMQueue ChainSyncEvent
eventsQueue
        ChainSyncHandler
-> (ChainSyncHandler -> ChainSyncHandler) -> ChainSyncHandler
forall a b. a -> (a -> b) -> b
& BlockNumber -> ChainSyncHandler -> ChainSyncHandler
storeFromBlockNo (BlockNo -> BlockNumber
fromCardanoBlockNo (BlockNo -> BlockNumber) -> BlockNo -> BlockNumber
forall a b. (a -> b) -> a -> b
$ ChainIndexConfig -> BlockNo
Config.cicStoreFrom ChainIndexConfig
config)
        ChainSyncHandler
-> (ChainSyncHandler -> IO ChainSyncHandler) -> IO ChainSyncHandler
forall a b. a -> (a -> b) -> b
& ChainSyncHandler -> IO ChainSyncHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    FilePath -> IO ()
logger (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Connecting to the node using socket: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ChainIndexConfig -> FilePath
Config.cicSocketPath ChainIndexConfig
config
    ChainIndexConfig -> RunRequirements -> ChainSyncHandler -> IO ()
syncChainIndex ChainIndexConfig
config RunRequirements
runReq ChainSyncHandler
syncHandler

    (Trace IO (PrettyObject SyncLog)
trace :: Trace IO (PrettyObject SyncLog), Switchboard (PrettyObject SyncLog)
_) <- Configuration
-> Text
-> IO
     (Trace IO (PrettyObject SyncLog),
      Switchboard (PrettyObject SyncLog))
forall (m :: * -> *) a.
(MonadIO m, ToJSON a, FromJSON a, ToObject a) =>
Configuration -> Text -> m (Trace m a, Switchboard a)
setupTrace_ Configuration
logConfig Text
"chain-index"
    IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Trace IO (PrettyObject SyncLog)
-> RunRequirements -> TBMQueue ChainSyncEvent -> IO ()
processEventsQueue Trace IO (PrettyObject SyncLog)
trace RunRequirements
runReq TBMQueue ChainSyncEvent
eventsQueue) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
processAsync -> do

      let port :: FilePath
port = Int -> FilePath
forall a. Show a => a -> FilePath
show (ChainIndexConfig -> Int
Config.cicPort ChainIndexConfig
config)
      FilePath -> IO ()
logger (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Starting webserver on port " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
port
      FilePath -> IO ()
logger (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"A Swagger UI for the endpoints are available at "
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"http://localhost:" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
port FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/swagger/swagger-ui"
      Int -> RunRequirements -> IO ()
Server.serveChainIndexQueryServer (ChainIndexConfig -> Int
Config.cicPort ChainIndexConfig
config) RunRequirements
runReq
      Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
processAsync