content: {-# LANGUAGE OverloadedRecordDot #-}
  
  -- | Parse hydra-node logs format more easy on the eyes. Parser works with regular json logs as well as journalctl format.
  module VisualizeLogs where
  
  import Hydra.Cardano.Api (Tx)
  import Hydra.Prelude hiding (encodeUtf8, takeWhile)
  
  import Conduit
  import Control.Lens ((^?))
  import Control.Monad (foldM)
  import Data.Aeson (eitherDecode')
  import Data.Aeson.Lens (key, _String)
  import Data.Attoparsec.ByteString
  import Data.Attoparsec.ByteString qualified as A
  import Data.Attoparsec.ByteString.Char8 (char8, endOfLine, isEndOfLine)
  import Data.Text.Encoding (encodeUtf8)
  import Hydra.Chain (ChainEvent (..))
  import Hydra.HeadLogic (Effect (..), Input (..), Outcome (..), StateChanged (..))
  import Hydra.Logging (Envelope (..))
  import Hydra.Logging.Messages (HydraLog (..))
  import Hydra.Node (HydraNodeLog (..))
  import Options.Applicative hiding (Parser)
  import Options.Applicative qualified as Options
  
  data InfoLine = InfoLine {toplabel :: LogType, details :: Text} deriving (Eq, Show)
  
  data Decoded tx
    = DecodedHydraLog {t :: UTCTime, n :: Text, infoLine :: InfoLine}
    | DropLog
    deriving (Eq, Show)
  
  -- | This instance is needed to sort results by timestamp
  instance Ord (Decoded tx) where
    compare DropLog DropLog = EQ
    compare DropLog DecodedHydraLog{} = LT
    compare DecodedHydraLog{} DropLog = GT
    compare (DecodedHydraLog t1 _ _) (DecodedHydraLog t2 _ _) = compare t1 t2
  
  -- | Log type labels for visualization
  data LogType
    = NodeOptionsLabel
    | ClientSentLabel
    | ObservationLabel
    | NetworkLabel
    | ChainEffectLabel
    | ErrorLabel
    | LogicLabel Text
    | LogicError Text
    | Other Text
    deriving (Eq, Show)
  
  labelLog :: LogType -> Text
  labelLog NodeOptionsLabel = "NODE OPTIONS"
  labelLog ClientSentLabel = "CLIENT SENT"
  labelLog ObservationLabel = "OBSERVATION"
  labelLog NetworkLabel = "NETWORK EFFECT"
  labelLog ChainEffectLabel = "POSTING TX"
  labelLog ErrorLabel = "ERROR"
  labelLog (LogicLabel t) = unlines ["LOGIC", t]
  labelLog (LogicError t) = unlines ["LOGIC ERROR", t]
  labelLog (Other t) = unlines ["OTHER", t]
  
  colorLog :: LogType -> Text
  colorLog = \case
    NodeOptionsLabel -> green
    ClientSentLabel -> green
    ObservationLabel -> blue
    NetworkLabel -> magenta
    ChainEffectLabel -> blue
    ErrorLabel -> red
    LogicLabel t -> case t of
      "DepositExpired" -> red
      "DecommitInvalid" -> red
      "IgnoredHeadInitializing" -> red
      "TxInvalid" -> red
      _ -> cyan
    LogicError _ -> red
    Other _ -> green
  
  newtype Options = Options
    { paths :: [FilePath]
    }
    deriving (Show)
  
  options :: Options.Parser Options
  options =
    Options
      <$> many
        ( strArgument
            ( metavar "FILES"
                <> help "One or more log file paths."
            )
        )
  
  opts :: ParserInfo Options
  opts =
    info
      (options <**> helper)
      ( fullDesc
          <> progDesc "Group logs by the timestamp and display using colors and separators for easy inspection."
          <> header "Visualize hydra-node logs"
      )
  
  visualize :: [FilePath] -> IO ()
  visualize paths = do
    decodedLines <-
      runConduitRes $
        mapM_ sourceFileBS paths
          .| linesUnboundedAsciiC
          .| mapMC decodeAndProcess
          .| filterC (/= DropLog)
          .| sinkList
  
    forM_ (sort decodedLines) render
  
  decodeAndProcess :: ByteString -> ResourceT IO (Decoded Tx)
  decodeAndProcess l =
    case inCurlyBraces l of
      Left _ -> lift $ pure DropLog
      Right incomingLine ->
        case incomingLine of
          Nothing -> lift $ pure DropLog
          Just jsonLine ->
            case jsonLine ^? key "message" . _String of
              Nothing -> process jsonLine
              Just line -> process $ encodeUtf8 line
   where
    process :: ByteString -> ResourceT IO (Decoded Tx)
    process line =
      case eitherDecode' (fromStrict line) of
        Left e -> do
          putTextLn $ red <> "Decoding failed for line: " <> decodeUtf8 l <> "\nError: " <> show e
          pure DropLog
        Right decoded -> lift $ processLogs decoded
  
  charToWord8 :: Char -> Word8
  charToWord8 = fromIntegral . ord
  
  textBetweenBraces :: A.Parser ByteString
  textBetweenBraces = do
    skipWhile (/= charToWord8 '{')
    _ <- char8 '{'
    jsonStr <- takeWhile (not . isEndOfLine)
    pure $ "{" <> jsonStr
  
  lineParser :: A.Parser (Maybe ByteString)
  lineParser = do
    result <- optional textBetweenBraces
    skipWhile (not . isEndOfLine)
    endOfLine <|> endOfInput
    return result
  
  inCurlyBraces :: ByteString -> Either String (Maybe ByteString)
  inCurlyBraces = parseOnly lineParser
  
  -- | Ideally we would have Data instances for all types so we could get data type string representation
  -- instead of providing strings directly but that would add some compilation time overhead so not worth it.
  processLogs :: Envelope (HydraLog Tx) -> IO (Decoded Tx)
  processLogs decoded =
    case decoded.message of
      NodeOptions opt -> logIt NodeOptionsLabel opt
      Node msg ->
        case msg of
          BeginInput{input} ->
            case input of
              ClientInput{clientInput} -> logIt ClientSentLabel clientInput
              NetworkInput{} -> pure DropLog
              ChainInput{chainEvent} ->
                case chainEvent of
                  Observation{observedTx} -> logIt ObservationLabel observedTx
                  Rollback{} -> pure DropLog
                  Tick{} -> pure DropLog
                  PostTxError{postTxError} -> logIt ErrorLabel postTxError
          EndInput{} -> pure DropLog
          BeginEffect{effect} ->
            case effect of
              ClientEffect{} -> pure DropLog
              NetworkEffect{message} -> logIt NetworkLabel message
              OnChainEffect{postChainTx} -> logIt ChainEffectLabel postChainTx
          EndEffect{} -> pure DropLog
          LogicOutcome{outcome} ->
            case outcome of
              Continue{stateChanges} ->
                foldM
                  ( \_ a -> case a of
                      details@HeadInitialized{} -> logIt (LogicLabel "HeadInitialized") details
                      details@HeadOpened{} -> logIt (LogicLabel "HeadOpened") details
                      details@CommittedUTxO{} -> logIt (LogicLabel "CommittedUTxO") details
                      details@HeadAborted{} -> logIt (LogicLabel "HeadAborted") details
                      details@SnapshotRequestDecided{} -> logIt (LogicLabel "SnapshotRequestDecided") details
                      details@SnapshotRequested{} -> logIt (LogicLabel "SnapshotRequested") details
                      details@PartySignedSnapshot{} -> logIt (LogicLabel "PartySignedSnapshot") details
                      details@SnapshotConfirmed{} -> logIt (LogicLabel "SnapshotConfirmed") details
                      details@DepositRecorded{} -> logIt (LogicLabel "DepositRecorded") details
                      details@DepositActivated{} -> logIt (LogicLabel "DepositActivated") details
                      details@DepositExpired{} -> logIt (LogicLabel "DepositExpired") details
                      details@DepositRecovered{} -> logIt (LogicLabel "DepositRecovered") details
                      details@CommitApproved{} -> logIt (LogicLabel "CommitApproved") details
                      details@CommitFinalized{} -> logIt (LogicLabel "CommitFinalized") details
                      details@DecommitRecorded{} -> logIt (LogicLabel "DecommitRecorded") details
                      details@DecommitApproved{} -> logIt (LogicLabel "DecommitApproved") details
                      details@DecommitInvalid{} -> logIt (LogicLabel "DecommitInvalid") details
                      details@DecommitFinalized{} -> logIt (LogicLabel "DecommitFinalized") details
                      details@HeadClosed{} -> logIt (LogicLabel "HeadClosed") details
                      details@HeadContested{} -> logIt (LogicLabel "HeadContested") details
                      details@HeadIsReadyToFanout{} -> logIt (LogicLabel "HeadIsReadyToFanout") details
                      details@HeadFannedOut{} -> logIt (LogicLabel "HeadFannedOut") details
                      details@IgnoredHeadInitializing{} -> logIt (LogicLabel "IgnoredHeadInitializing") details
                      details@TxInvalid{} -> logIt (LogicLabel "TxInvalid") details
                      NetworkConnected{} -> pure DropLog
                      NetworkDisconnected{} -> pure DropLog
                      PeerConnected{} -> pure DropLog
                      PeerDisconnected{} -> pure DropLog
                      NetworkVersionMismatch{} -> pure DropLog
                      NetworkClusterIDMismatch{} -> pure DropLog
                      TransactionReceived{} -> pure DropLog
                      TransactionAppliedToLocalUTxO{} -> pure DropLog
                      ChainRolledBack{} -> pure DropLog
                      TickObserved{} -> pure DropLog
                      LocalStateCleared{} -> pure DropLog
                      Checkpoint{} -> pure DropLog
                  )
                  DropLog
                  stateChanges
              Wait{} -> pure DropLog
              Error{error = err} -> logIt (LogicError "LOGIC ERROR") err
          DroppedFromQueue{} -> pure DropLog
          LoadingState -> logIt (Other "Loading state...") ()
          LoadedState{} -> logIt (Other "Loaded.") ()
          ReplayingState -> logIt (Other "Replaying state...") ()
          details@Misconfiguration{} -> logIt (Other "MISCONFIG!") details
      _ -> pure DropLog
   where
    logIt :: Show x => LogType -> x -> IO (Decoded Tx)
    logIt l s =
      pure $ DecodedHydraLog decoded.timestamp decoded.namespace (InfoLine l (show s))
  
  render :: Decoded tx -> IO ()
  render = \case
    DecodedHydraLog{t, n, infoLine = InfoLine{toplabel, details}} -> do
      putTextLn $
        unlines
          [ "-----------------------------------"
          , "[" <> show t <> "]"
          , "NAMESPACE:" <> show n
          , colorLog toplabel
          , labelLog toplabel
          , details
          , reset
          ]
    DropLog -> putTextLn ""
  
  -- ANSI escape codes for colors
  red :: Text
  red = "\ESC[31m"
  
  green :: Text
  green = "\ESC[32m"
  
  blue :: Text
  blue = "\ESC[34m"
  
  cyan :: Text
  cyan = "\ESC[36m"
  
  magenta :: Text
  magenta = "\ESC[45m"
  
  reset :: Text
  reset = "\ESC[0m"
  