SCP-3431: Better syncing logging in the chain-index.

* Syncing message now logs every 30s.

* Prints syncing percentage, number of applied blocks, number of rollbacks and current tip

* Logging uses the Trace for more consistent logging with PAB and cardano-node.

plutus-chain-index-core/src/Plutus/ChainIndex.hs

@@ -33,11 +33,11 @@ import Control.Monad.Freer.Reader (runReader)
 import Control.Monad.Freer.State (runState)
 import Control.Monad.IO.Class (liftIO)
 import Database.SQLite.Simple qualified as Sqlite
-import Plutus.Monitoring.Util (convertLog, runLogEffects)
+import Plutus.Monitoring.Util (PrettyObject (PrettyObject), convertLog, runLogEffects)
 
 -- | The required arguments to run the chain index effects.
 data RunRequirements = RunRequirements
-    { trace         :: Trace IO ChainIndexLog
+    { trace         :: Trace IO (PrettyObject ChainIndexLog)
     , stateMVar     :: MVar ChainIndexState
     , conn          :: Sqlite.Connection
     , securityParam :: Int
@@ -49,7 +49,7 @@ runChainIndexEffects
     -> Eff '[ChainIndexQueryEffect, ChainIndexControlEffect, BeamEffect] a
     -> IO (Either ChainIndexError a)
 runChainIndexEffects runReq action =
-    runLogEffects (trace runReq)
+    runLogEffects (convertLog PrettyObject $ trace runReq)
         $ handleChainIndexEffects runReq
         $ raiseEnd action
 
@@ -67,7 +67,7 @@ handleChainIndexEffects RunRequirements{trace, stateMVar, conn, securityParam} a
         $ runReader (Depth securityParam)
         $ runError @ChainIndexError
         $ flip handleError (throwError . BeamEffectError)
-        $ interpret (handleBeam (convertLog BeamLogItem trace))
+        $ interpret (handleBeam (convertLog (PrettyObject . BeamLogItem) trace))
         $ interpret handleControl
         $ interpret handleQuery
         -- Insert the 5 effects needed by the handlers of the 3 chain index effects between those 3 effects and 'effs'.

plutus-chain-index-core/src/Plutus/ChainIndex/Types.hs

@@ -14,6 +14,8 @@ module Plutus.ChainIndex.Types(
     , Point(..)
     , pointsToTip
     , tipAsPoint
+    , _PointAtGenesis
+    , _Point
     , TxValidity(..)
     , TxStatus
     , TxOutStatus
@@ -39,7 +41,7 @@ module Plutus.ChainIndex.Types(
 
 import Codec.Serialise (Serialise)
 import Codec.Serialise qualified as CBOR
-import Control.Lens (makeLenses)
+import Control.Lens (makeLenses, makePrisms)
 import Control.Monad (void)
 import Crypto.Hash (SHA256, hash)
 import Data.Aeson (FromJSON, ToJSON)
@@ -61,7 +63,7 @@ import Ledger.Blockchain qualified as Ledger
 import Ledger.Slot (Slot)
 import Ledger.TxId (TxId)
 import PlutusTx.Lattice (MeetSemiLattice (..))
-import Prettyprinter (Pretty (..), (<+>))
+import Prettyprinter (Pretty (..), comma, (<+>))
 import Prettyprinter.Extras (PrettyShow (..))
 
 import Plutus.ChainIndex.Tx (ChainIndexTx)
@@ -74,6 +76,14 @@ blockId = BlockId
         . BSL.toStrict
         . CBOR.serialise
 
+newtype BlockNumber = BlockNumber { unBlockNumber :: Word64 }
+    deriving stock (Eq, Ord, Show, Generic)
+    deriving newtype (Num, Real, Enum, Integral, ToJSON, FromJSON, OpenApi.ToSchema)
+
+instance Pretty BlockNumber where
+    pretty (BlockNumber blockNumber) =
+        "BlockNumber " <> pretty blockNumber
+
 -- | The tip of the chain index.
 data Tip =
       TipAtGenesis
@@ -96,6 +106,8 @@ data Point =
     deriving stock (Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)
 
+makePrisms ''Point
+
 instance Ord Point where
   PointAtGenesis <= _              = True
   _              <= PointAtGenesis = False
@@ -104,11 +116,11 @@ instance Ord Point where
 instance Pretty Point where
     pretty PointAtGenesis = "PointAtGenesis"
     pretty Point {pointSlot, pointBlockId} =
-            "Tip(slot="
-        <+> pretty pointSlot
-        <>  ", blockId="
-        <+> pretty pointBlockId
-        <>  ")"
+        "Point("
+     <> pretty pointSlot
+     <> comma
+     <+> pretty pointBlockId
+     <>  ")"
 
 tipAsPoint :: Tip -> Point
 tipAsPoint TipAtGenesis = PointAtGenesis
@@ -129,9 +141,16 @@ instance Semigroup Tip where
     t <> TipAtGenesis = t
     _ <> t            = t
 
+instance Semigroup Point where
+    t <> PointAtGenesis = t
+    _ <> t              = t
+
 instance Monoid Tip where
     mempty = TipAtGenesis
 
+instance Monoid Point where
+    mempty = PointAtGenesis
+
 instance Ord Tip where
     TipAtGenesis <= _            = True
     _            <= TipAtGenesis = False
@@ -140,11 +159,11 @@ instance Ord Tip where
 instance Pretty Tip where
     pretty TipAtGenesis = "TipAtGenesis"
     pretty Tip {tipSlot, tipBlockId, tipBlockNo} =
-            "Tip(slot="
-        <+> pretty tipSlot
-        <>  ", blockId="
+            "Tip("
+        <>  pretty tipSlot
+        <>  comma
         <+> pretty tipBlockId
-        <> ", blockNo="
+        <>  comma
         <+> pretty tipBlockNo
         <>  ")"
 
@@ -243,10 +262,6 @@ txOutStatusTxOutState (Committed _ s)              = Just s
 liftTxOutStatus :: TxOutStatus -> TxStatus
 liftTxOutStatus = void
 
-newtype BlockNumber = BlockNumber { unBlockNumber :: Word64 }
-    deriving stock (Eq, Ord, Show, Generic)
-    deriving newtype (Num, Real, Enum, Integral, Pretty, ToJSON, FromJSON, OpenApi.ToSchema)
-
 data Diagnostics =
     Diagnostics
         { numTransactions    :: Integer
@@ -366,6 +381,7 @@ newtype TxProcessOption = TxProcessOption
     -- If not, only handle the UTXOs.
     -- This, for example, allows applications to skip unwanted pre-Alonzo transactions.
     }
+    deriving (Show)
 
 -- We should think twice when setting the default option.
 -- For now, it should store all data to avoid weird non-backward-compatible bugs in the future.
@@ -377,3 +393,4 @@ data ChainSyncBlock = Block
     { blockTip :: Tip
     , blockTxs :: [(ChainIndexTx, TxProcessOption)]
     }
+    deriving (Show)

plutus-chain-index/plutus-chain-index.cabal

@@ -25,7 +25,7 @@ common lang
                         DeriveTraversable ImportQualifiedPost
     ghc-options: -Wall -Wnoncanonical-monad-instances -Wunused-packages
                  -Wincomplete-uni-patterns -Wincomplete-record-updates
-                 -Wredundant-constraints -Widentities
+                 -Wredundant-constraints -Widentities -Wmissing-import-lists
 
 library
     import: lang
@@ -35,6 +35,7 @@ library
         Plutus.ChainIndex.Config
         Plutus.ChainIndex.Lib
         Plutus.ChainIndex.Logging
+        Plutus.ChainIndex.SyncStats
     hs-source-dirs: src
     build-depends:
         plutus-ledger -any,
@@ -43,6 +44,7 @@ library
         freer-extras -any
     build-depends:
         aeson -any,
+        async -any,
         base >=4.7 && <5,
         beam-sqlite -any,
         beam-migrate -any,
@@ -52,11 +54,13 @@ library
         freer-simple -any,
         iohk-monitoring -any,
         lens -any,
+        optparse-applicative -any,
         ouroboros-network -any,
         prettyprinter >=1.1.0.1,
         sqlite-simple -any,
+        stm -any,
+        time-units -any,
         yaml -any,
-        optparse-applicative -any
 
 executable plutus-chain-index
   main-is: Main.hs
@@ -69,4 +73,4 @@ executable plutus-chain-index
         -Wno-missing-import-lists -Wredundant-constraints -O0
   build-depends:
     base >=4.9 && <5,
-    plutus-chain-index -any
+    plutus-chain-index -any

plutus-chain-index/src/Plutus/ChainIndex/App.hs

@@ -1,13 +1,9 @@
 {-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE GADTs               #-}
-{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
 
 {-| Main entry points to the chain index.
 -}
@@ -19,17 +15,25 @@ import Data.Foldable (for_)
 import Data.Function ((&))
 import Data.Yaml qualified as Y
 import Options.Applicative (execParser)
-import Prettyprinter (Pretty (..))
+import Prettyprinter (Pretty (pretty))
 
 import Cardano.BM.Configuration.Model qualified as CM
 
-import Plutus.ChainIndex.CommandLine (AppConfig (..), Command (..), applyOverrides, cmdWithHelpParser)
+import Cardano.BM.Setup (setupTrace_)
+import Cardano.BM.Trace (Trace)
+import Control.Concurrent.Async (wait, withAsync)
+import Control.Concurrent.STM.TChan (newBroadcastTChanIO)
+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.Lib (defaultChainSyncHandler, getTipSlot, showingProgress, storeFromBlockNo, syncChainIndex,
-                              withRunRequirements)
+import Plutus.ChainIndex.Lib (defaultChainSyncHandler, getTipSlot, storeFromBlockNo, syncChainIndex,
+                              withRunRequirements, writeChainSyncEventToChan)
 import Plutus.ChainIndex.Logging qualified as Logging
 import Plutus.ChainIndex.Server qualified as Server
+import Plutus.ChainIndex.SyncStats (SyncLog, convertEventToSyncStats, logProgress)
+import Plutus.Monitoring.Util (PrettyObject (PrettyObject), convertLog, runLogEffects)
 
 main :: IO ()
 main = do
@@ -43,7 +47,7 @@ main = do
     DumpDefaultLoggingConfig path ->
       Logging.defaultConfig >>= CM.toRepresentation >>= Y.encodeFile path
 
-    StartChainIndex{} -> do
+    StartChainIndex {} -> do
       -- Initialise logging
       logConfig <- maybe Logging.defaultConfig Logging.loadConfig acLogConfigPath
       for_ acMinLogLevel $ \ll -> CM.setMinSeverity logConfig ll
@@ -73,14 +77,19 @@ runMain logConfig config = do
     slotNo <- getTipSlot config
     print slotNo
 
+    -- Channel for broadcasting 'ChainSyncEvent's
+    chan <- newBroadcastTChanIO
     syncHandler
       <- defaultChainSyncHandler runReq
         & storeFromBlockNo (fromCardanoBlockNo $ Config.cicStoreFrom config)
-        & showingProgress
+        & writeChainSyncEventToChan convertEventToSyncStats chan
 
     putStrLn $ "Connecting to the node using socket: " <> Config.cicSocketPath config
     syncChainIndex config runReq syncHandler
 
+    (trace :: Trace IO (PrettyObject SyncLog), _) <- setupTrace_ logConfig "chain-index"
+    withAsync (runLogEffects (convertLog PrettyObject trace) $ logProgress chan) wait
+
     let port = show (Config.cicPort config)
     putStrLn $ "Starting webserver on port " <> port
     putStrLn $ "A Swagger UI for the endpoints are available at "

plutus-chain-index/src/Plutus/ChainIndex/CommandLine.hs

@@ -12,8 +12,8 @@ import Control.Lens (over)
 import Options.Applicative (CommandFields, Mod, Parser, ParserInfo, argument, auto, command, flag, fullDesc, header,
                             help, helper, hsubparser, info, long, metavar, option, progDesc, short, str, value, (<**>))
 
-import Cardano.Api (NetworkId (..), NetworkMagic (..))
-import Cardano.BM.Data.Severity
+import Cardano.Api (NetworkId (Testnet), NetworkMagic (NetworkMagic))
+import Cardano.BM.Data.Severity (Severity (Debug))
 import GHC.Word (Word32)
 import Plutus.ChainIndex.Config (ChainIndexConfig)
 import Plutus.ChainIndex.Config qualified as Config