content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Cardano.DbSync.Error (
    SyncInvariant (..),
    SyncNodeError (..),
    NodeConfigError (..),
    SyncNodeCallStack (..),
    annotateInvariantTx,
    bsBase16Encode,
    renderSyncInvariant,
    runOrThrowIO,
    fromEitherSTM,
    logAndThrowIO,
    hasAbortOnPanicEnv,
    mkSyncNodeCallStack,
  ) where
  
  import Cardano.BM.Trace (Trace, logError)
  import qualified Cardano.Chain.Genesis as Byron
  import qualified Cardano.Chain.UTxO as Byron
  import qualified Cardano.Crypto as Crypto (serializeCborHash)
  import qualified Cardano.Db as DB
  import qualified Cardano.DbSync.Era.Byron.Util as Byron
  import Cardano.DbSync.Util
  import Cardano.Prelude
  
  import qualified Data.ByteString.Base16 as Base16
  import Data.String (String)
  import qualified Data.Text as Text
  import qualified Data.Text.Encoding as Text
  import System.Environment (lookupEnv)
  import qualified Text.Show as Show
  
  data SyncInvariant
    = EInvInOut !Word64 !Word64
    | EInvTxInOut !Byron.Tx !Word64 !Word64
  
  newtype SyncNodeCallStack = SyncNodeCallStack
    {sncsCallChain :: [(String, SrcLoc)]}
    deriving (Show, Eq)
  
  data SyncNodeError
    = SNErrDefault !SyncNodeCallStack !Text
    | SNErrDbSessionErr !SyncNodeCallStack !DB.DbSessionError
    | SNErrDbLookupError !SyncNodeCallStack !DB.DbLookupError
    | SNErrInvariant !Text !SyncInvariant
    | SNEErrBlockMismatch !Word64 !ByteString !ByteString
    | SNErrIgnoreShelleyInitiation
    | SNErrByronConfig !FilePath !Byron.ConfigurationError
    | SNErrShelleyConfig !FilePath !Text
    | SNErrAlonzoConfig !FilePath !Text
    | SNErrConwayConfig !FilePath !Text
    | SNErrCardanoConfig !Text
    | SNErrPGConfig !String
    | SNErrInsertGenesis !String
    | SNErrLedgerState !String
    | SNErrNodeConfig NodeConfigError
    | SNErrLocalStateQuery !String
    | SNErrByronGenesis !String
    | SNErrExtraMigration !String
    | SNErrDbSessionErrRollBackLedger !String
    | SNErrDbSessionErrValConstLevel !String
    | SNErrJsonbInSchema !String
    | SNErrRollback !String
  
  instance Exception SyncNodeError
  
  instance Show SyncNodeError where
    show =
      \case
        SNErrDefault cs err -> "Error SNErrDefault: " <> show err <> ":" <> Text.unpack (formatCallStack cs)
        SNErrDbSessionErr cs err -> "Error SNErrDbSessionErr: " <> Text.unpack (formatCallStack cs) <> " " <> Text.unpack (DB.formatDbCallStack (DB.dbSessionErrCallStack err)) <> "\n " <> Text.unpack (DB.dbSessionErrMsg err)
        SNErrDbLookupError cs err -> "Error SNErrDbLookupError: " <> Text.unpack (formatCallStack cs) <> " " <> Text.unpack (DB.formatDbCallStack (DB.dbLookupErrCallStack err)) <> "\n " <> Text.unpack (DB.dbLookupErrMsg err)
        SNErrInvariant loc i -> "Error SNErrInvariant: " <> Show.show loc <> ": " <> show (renderSyncInvariant i)
        SNEErrBlockMismatch blkNo hashDb hashBlk ->
          mconcat
            [ "Error SNEErrBlockMismatch: "
            , "Block mismatch for block number "
            , show blkNo
            , ", db has "
            , show $ bsBase16Encode hashDb
            , " but chain provided "
            , show $ bsBase16Encode hashBlk
            ]
        SNErrIgnoreShelleyInitiation ->
          mconcat
            [ "Error SNErrIgnoreShelleyInitiation: "
            , "Node configs that don't fork to Shelley directly and initiate"
            , " funds or stakes in Shelley Genesis are not supported."
            ]
        SNErrByronConfig fp ce ->
          mconcat
            [ "Error SNErrByronConfig: "
            , "Failed reading Byron genesis file "
            , show fp
            , ": "
            , show ce
            ]
        SNErrShelleyConfig fp txt ->
          mconcat
            [ "Error SNErrShelleyConfig: "
            , "Failed reading Shelley genesis file "
            , show fp
            , ": "
            , show txt
            ]
        SNErrAlonzoConfig fp txt ->
          mconcat
            [ "Error SNErrAlonzoConfig: "
            , "Failed reading Alonzo genesis file "
            , show fp
            , ": "
            , show txt
            ]
        SNErrConwayConfig fp txt ->
          mconcat
            [ "Error SNErrConwayConfig: "
            , "Failed reading Conway genesis file "
            , show fp
            , ": "
            , show txt
            ]
        SNErrCardanoConfig err ->
          mconcat
            [ "Error SNErrCardanoConfig: "
            , "With Cardano protocol, Byron/Shelley config mismatch:\n"
            , "   "
            , show err
            ]
        SNErrPGConfig err -> "Error SNErrPGConfig: " <> err
        SNErrInsertGenesis err -> "Error SNErrInsertGenesis: " <> err
        SNErrLedgerState err -> "Error SNErrLedgerState: " <> err
        SNErrNodeConfig err -> "Error SNErrNodeConfig: " <> show err
        SNErrLocalStateQuery err -> "Error SNErrLocalStateQuery: " <> show err
        SNErrByronGenesis err -> "Error SNErrByronGenesis:" <> show err
        SNErrExtraMigration err -> "Error SNErrExtraMigration: " <> show err
        SNErrDbSessionErrRollBackLedger err -> "Error SNErrDbSessionErr Rollback Ledger: " <> show err
        SNErrDbSessionErrValConstLevel err -> "Error SNErrDbSessionErr Validate Consistent Level: " <> show err
        SNErrJsonbInSchema err -> "Error SNErrJsonbInSchema: " <> show err
        SNErrRollback err -> "Error SNErrRollback: " <> show err
  
  data NodeConfigError
    = NodeConfigParseError !String
    | ParseSyncPreConfigError !String
    | ReadByteStringFromFileError !String
  
  instance Exception NodeConfigError
  
  instance Show NodeConfigError where
    show =
      \case
        NodeConfigParseError err -> "NodeConfigParseError - " <> err
        ParseSyncPreConfigError err -> "ParseSyncPreConfigError - " <> err
        ReadByteStringFromFileError err -> "ReadByteStringFromFileError - " <> err
  
  annotateInvariantTx :: Byron.Tx -> SyncInvariant -> SyncInvariant
  annotateInvariantTx tx ei =
    case ei of
      EInvInOut inval outval -> EInvTxInOut tx inval outval
      _other -> ei
  
  renderSyncInvariant :: SyncInvariant -> Text
  renderSyncInvariant ei =
    case ei of
      EInvInOut inval outval ->
        mconcat ["input value ", textShow inval, " < output value ", textShow outval]
      EInvTxInOut tx inval outval ->
        mconcat
          [ "tx "
          , bsBase16Encode (Byron.unTxHash $ Crypto.serializeCborHash tx)
          , " : input value "
          , textShow inval
          , " < output value "
          , textShow outval
          , "\n"
          , textShow tx
          ]
  
  fromEitherSTM :: Exception e => Either e a -> STM a
  fromEitherSTM = either throwSTM return
  
  bsBase16Encode :: ByteString -> Text
  bsBase16Encode bs =
    case Text.decodeUtf8' (Base16.encode bs) of
      Left _ -> Text.pack $ "UTF-8 decode failed for " ++ Show.show bs
      Right txt -> txt
  
  runOrThrowIO :: forall e a m. MonadIO m => Exception e => m (Either e a) -> m a
  runOrThrowIO ioEither = do
    et <- ioEither
    case et of
      Left err -> throwIO err
      Right a -> pure a
  
  logAndThrowIO :: Trace IO Text -> SyncNodeError -> IO ()
  logAndThrowIO tracer err = do
    logError tracer $ show err
    throwIO err
  
  hasAbortOnPanicEnv :: IO Bool
  hasAbortOnPanicEnv = isJust <$> lookupEnv "DbSyncAbortOnPanic"
  
  -- | Create a SyncNodeCallStack from the current call stack
  mkSyncNodeCallStack :: HasCallStack => SyncNodeCallStack
  mkSyncNodeCallStack =
    case getCallStack callStack of
      [] -> SyncNodeCallStack []
      ((_, _) : rest) ->
        SyncNodeCallStack
          { sncsCallChain = take 4 rest -- Take next 4 frames as raw data
          }
  
  -- | Format a single frame with function name, module, and location
  formatFrame :: String -> String -> String -> Int -> Text
  formatFrame fnName mName fileName lineNum =
    Text.pack fnName <> " at " <> Text.pack mName <> ":" <> Text.pack fileName <> ":" <> textShow lineNum
  
  -- | Format a SyncNodeCallStack for display in error messages
  -- This can be reused for other error types that include callstacks
  formatCallStack :: SyncNodeCallStack -> Text
  formatCallStack cs =
    if null (sncsCallChain cs)
      then ""
      else
        "\n App call chain: "
          <> Text.intercalate
            " <- "
            ( map
                ( \(fnName, srcLoc) ->
                    formatFrame fnName (srcLocModule srcLoc) (srcLocFile srcLoc) (srcLocStartLine srcLoc)
                )
                (sncsCallChain cs)
            )
  