create Show instance for FetchError, move shouldAbortOnPanic

Author: Cmdv

cardano-db-sync/app/http-get-json-metadata.hs

@@ -6,11 +6,9 @@ import Cardano.DbSync (
   SimplifiedPoolOfflineData (..),
   httpGetPoolOfflineData,
   parsePoolUrl,
-  renderFetchError,
  )
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT)
-import Control.Monad.Trans.Except.Exit (orDie)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
 import qualified Data.ByteString.Base16 as Base16
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Text as Text
@@ -26,6 +24,7 @@ import System.Console.ANSI.Types (
  )
 import System.Environment (getArgs, getProgName)
 import System.Exit (exitFailure)
+import Cardano.DbSync.Error (runOrThrowIO)
 
 main :: IO ()
 main = do
@@ -60,7 +59,7 @@ usageExit = do
 
 runHttpGet :: PoolUrl -> Maybe PoolMetaHash -> IO ()
 runHttpGet poolUrl mHash =
-  reportSuccess =<< orDie renderFetchError httpGet
+  reportSuccess =<< runOrThrowIO (runExceptT httpGet)
   where
     httpGet :: ExceptT FetchError IO SimplifiedPoolOfflineData
     httpGet = do

cardano-db-sync/app/test-http-get-json-metadata.hs

@@ -17,7 +17,6 @@ import Cardano.DbSync.Era.Shelley.Offline.Http (
   FetchError (..),
   httpGetPoolOfflineData,
   parsePoolUrl,
-  renderFetchError,
  )
 import Control.Monad (foldM)
 import Control.Monad.IO.Class (MonadIO)
@@ -28,7 +27,6 @@ import qualified Data.List as List
 import qualified Data.List.Extra as List
 import Data.Ord (Down (..))
 import Data.Text (Text)
-import qualified Data.Text.IO as Text
 import Database.Esqueleto.Experimental (
   SqlBackend,
   from,
@@ -65,7 +63,7 @@ main = do
         httpGetPoolOfflineData manager request poolUrl mHash
       case eres of
         Left err -> do
-          Text.putStrLn $ renderFetchError err
+          putStrLn $ show err
           pure $ classifyFetchError accum err
         Right _ ->
           pure accum

cardano-db-sync/cardano-db-sync.cabal

@@ -265,7 +265,6 @@ executable http-get-json-metadata
                       , http-client-tls
                       , text
                       , transformers
-                      , transformers-except
 
 executable test-http-get-json-metadata
   default-language:     Haskell2010

cardano-db-sync/src/Cardano/DbSync.hs

@@ -23,7 +23,6 @@ module Cardano.DbSync (
   SimplifiedPoolOfflineData (..),
   httpGetPoolOfflineData,
   parsePoolUrl,
-  renderFetchError,
 ) where
 
 import Cardano.BM.Trace (Trace, logError, logInfo, logWarning)
@@ -52,16 +51,14 @@ import Cardano.DbSync.Era.Shelley.Offline.Http (
   SimplifiedPoolOfflineData (..),
   httpGetPoolOfflineData,
   parsePoolUrl,
-  renderFetchError,
   spodJson,
  )
-import Cardano.DbSync.Error (SyncNodeError, runOrThrowIO)
+import Cardano.DbSync.Error (SyncNodeError, runOrThrowIO, hasAbortOnPanicEnv)
 import Cardano.DbSync.Ledger.State
 import Cardano.DbSync.Rollback (unsafeRollback)
 import Cardano.DbSync.Sync (runSyncNodeClient)
 import Cardano.DbSync.Tracing.ToObjectOrphans ()
 import Cardano.DbSync.Types
-import Cardano.DbSync.Util (readAbortOnPanic)
 import Cardano.Prelude hiding (Nat, (%))
 import Cardano.Slotting.Slot (EpochNo (..))
 import Control.Concurrent.Async
@@ -80,7 +77,7 @@ runDbSyncNode metricsSetters knownMigrations params =
   withIOManager $ \iomgr -> do
     trce <- configureLogging params "db-sync-node"
 
-    aop <- readAbortOnPanic
+    aop <- hasAbortOnPanicEnv
     startupReport trce aop params
 
     runDbSync metricsSetters knownMigrations iomgr trce params aop

cardano-db-sync/src/Cardano/DbSync/Database.hs

@@ -130,7 +130,7 @@ rollbackLedger syncEnv point =
           let statePoint = headerStatePoint $ headerState $ clsState st
           -- This is an extra validation that should always succeed.
           unless (point == statePoint) $
-            logAndPanic (getTrace syncEnv) $
+            logAndThrowIO (getTrace syncEnv) $
               mconcat
                 [ "Ledger "
                 , textShow statePoint
@@ -152,7 +152,7 @@ validateConsistentLevel syncEnv stPoint = do
   compareTips stPoint dbTipInfo cLevel
   where
     compareTips _ dbTip Unchecked =
-      logAndPanic tracer $
+      logAndThrowIO tracer $
         "Found Unchecked Consistent Level. " <> showContext dbTip Unchecked
     compareTips (Point Origin) Nothing Consistent = pure ()
     compareTips (Point Origin) _ DBAheadOfLedger = pure ()
@@ -163,7 +163,7 @@ validateConsistentLevel syncEnv stPoint = do
     compareTips (Point (At blk)) (Just tip) DBAheadOfLedger
       | blockPointSlot blk <= bSlotNo tip = pure ()
     compareTips _ dbTip cLevel =
-      logAndPanic tracer $
+      logAndThrowIO tracer $
         "Unexpected Consistent Level. " <> showContext dbTip cLevel
 
     tracer = getTrace syncEnv

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Offline.hs

@@ -136,6 +136,6 @@ fetchOfflineData _tracer manager time pfr =
               { DB.poolOfflineFetchErrorPoolId = pfrPoolHashId pfr
               , DB.poolOfflineFetchErrorFetchTime = Time.posixSecondsToUTCTime time
               , DB.poolOfflineFetchErrorPmrId = pfrReferenceId pfr
-              , DB.poolOfflineFetchErrorFetchError = renderFetchError err
+              , DB.poolOfflineFetchErrorFetchError = show err
               , DB.poolOfflineFetchErrorRetryCount = retryCount (pfrRetry pfr)
               }

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Offline/Http.hs

@@ -1,13 +1,13 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Cardano.DbSync.Era.Shelley.Offline.Http (
   FetchError (..),
   SimplifiedPoolOfflineData (..),
   httpGetPoolOfflineData,
   parsePoolUrl,
-  renderFetchError,
 ) where
 
 import qualified Cardano.Crypto.Hash.Blake2b as Crypto
@@ -31,6 +31,7 @@ import qualified Data.Text.Encoding as Text
 import Network.HTTP.Client (HttpException (..))
 import qualified Network.HTTP.Client as Http
 import qualified Network.HTTP.Types as Http
+import qualified GHC.Show as GHCS
 
 -- | Fetch error for the HTTP client fetching the pool offline metadata.
 data FetchError
@@ -47,6 +48,45 @@ data FetchError
   | FEConnectionFailure !PoolUrl
   deriving (Eq, Generic)
 
+instance Exception FetchError
+
+instance Show FetchError where
+  show =
+    \case
+      FEHashMismatch (PoolUrl url) xpt act ->
+        mconcat
+          [ "Hash mismatch from when fetching metadata from "
+          , show url
+          , ". Expected "
+          , show xpt
+          , " but got "
+          , show act
+          , "."
+          ]
+      FEDataTooLong (PoolUrl url) ->
+        mconcat
+          ["Offline pool data when fetching metadata from ", show url, " exceeded 512 bytes."]
+      FEUrlParseFail (PoolUrl url) err ->
+        mconcat
+          ["URL parse error for ", show url, " resulted in : ", show err]
+      FEJsonDecodeFail (PoolUrl url) err ->
+        mconcat
+          ["JSON decode error from when fetching metadata from ", show url, " resulted in : ", show err]
+      FEHttpException (PoolUrl url) err ->
+        mconcat ["HTTP Exception for ", show url, " resulted in : ", show err]
+      FEHttpResponse (PoolUrl url) sc msg ->
+        mconcat ["HTTP Response from ", show url, " resulted in HTTP status code : ", show sc, " ", show msg]
+      FEBadContentType (PoolUrl url) ct ->
+        mconcat ["HTTP Response from ", show url, ": expected JSON, but got : ", show ct]
+      FEBadContentTypeHtml (PoolUrl url) ct ->
+        mconcat ["HTTP Response from ", show url, ": expected JSON, but got : ", show ct]
+      FETimeout (PoolUrl url) ctx ->
+        mconcat ["Timeout when fetching metadata from ", show url, ": ", show ctx]
+      FEConnectionFailure (PoolUrl url) ->
+        mconcat
+          ["Connection failure when fetching metadata from ", show url, "'."]
+      FEIOException err -> "IO Exception: " <> show err
+
 data SimplifiedPoolOfflineData = SimplifiedPoolOfflineData
   { spodTickerName :: !Text
   , spodHash :: !ByteString
@@ -158,43 +198,6 @@ parsePoolUrl poolUrl =
     wrapHttpException :: HttpException -> FetchError
     wrapHttpException err = FEHttpException poolUrl (textShow err)
 
-renderFetchError :: FetchError -> Text
-renderFetchError fe =
-  case fe of
-    FEHashMismatch (PoolUrl url) xpt act ->
-      mconcat
-        [ "Hash mismatch from when fetching metadata from "
-        , url
-        , ". Expected "
-        , xpt
-        , " but got "
-        , act
-        , "."
-        ]
-    FEDataTooLong (PoolUrl url) ->
-      mconcat
-        ["Offline pool data when fetching metadata from ", url, " exceeded 512 bytes."]
-    FEUrlParseFail (PoolUrl url) err ->
-      mconcat
-        ["URL parse error for ", url, " resulted in : ", err]
-    FEJsonDecodeFail (PoolUrl url) err ->
-      mconcat
-        ["JSON decode error from when fetching metadata from ", url, " resulted in : ", err]
-    FEHttpException (PoolUrl url) err ->
-      mconcat ["HTTP Exception for ", url, " resulted in : ", err]
-    FEHttpResponse (PoolUrl url) sc msg ->
-      mconcat ["HTTP Response from ", url, " resulted in HTTP status code : ", textShow sc, " ", msg]
-    FEBadContentType (PoolUrl url) ct ->
-      mconcat ["HTTP Response from ", url, ": expected JSON, but got : ", ct]
-    FEBadContentTypeHtml (PoolUrl url) ct ->
-      mconcat ["HTTP Response from ", url, ": expected JSON, but got : ", ct]
-    FETimeout (PoolUrl url) ctx ->
-      mconcat ["Timeout when fetching metadata from ", url, ": ", ctx]
-    FEConnectionFailure (PoolUrl url) ->
-      mconcat
-        ["Connection failure when fetching metadata from ", url, "'."]
-    FEIOException err -> "IO Exception: " <> err
-
 -- -------------------------------------------------------------------------------------------------
 
 convertHttpException :: PoolUrl -> HttpException -> FetchError

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs

@@ -9,6 +9,7 @@ module Cardano.DbSync.Era.Shelley.ValidateWithdrawal (
 import Cardano.BM.Trace (Trace, logError)
 import Cardano.Db (Ada (..))
 import qualified Cardano.Db as Db
+import Cardano.DbSync.Error (shouldAbortOnPanic)
 import Cardano.DbSync.Util
 import Cardano.Slotting.Slot (EpochNo (..))
 import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -60,7 +61,7 @@ validateRewardWithdrawals trce (EpochNo epochNo) = do
         logError trce . mconcat $
           [textShow epochNo, ": ", textShow (length xs), " errors, eg\n"]
             ++ List.intersperse "\n" (map reportError xs)
-        panicAbort "Validation failure"
+        shouldAbortOnPanic "Validation failure"
 
 -- -----------------------------------------------------------------------------
 

cardano-db-sync/src/Cardano/DbSync/Error.hs

@@ -1,7 +1,7 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Cardano.DbSync.Error (
   SyncInvariant (..),
@@ -11,7 +11,10 @@ module Cardano.DbSync.Error (
   dbSyncNodeError,
   dbSyncInvariant,
   renderSyncInvariant,
-  runOrThrowIO
+  runOrThrowIO,
+  logAndThrowIO,
+  shouldAbortOnPanic,
+  hasAbortOnPanicEnv,
 ) where
 
 import qualified Cardano.Chain.Genesis as Byron
@@ -26,6 +29,10 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified GHC.Show as GShow
 import qualified Text.Show as Text
+import System.Environment (lookupEnv)
+import System.Posix.Process (exitImmediately)
+import Cardano.BM.Trace (Trace, logError)
+import GHC.IO.Exception (userError)
 
 data SyncInvariant
   = EInvInOut !Word64 !Word64
@@ -131,3 +138,23 @@ runOrThrowIO ioEither = do
   case et of
     Left err -> throwIO err
     Right a -> pure a
+
+logAndThrowIO :: Trace IO Text -> Text -> IO ()
+logAndThrowIO tracer msg = do
+  logError tracer msg
+  throwIO $ userError $ show msg
+
+-- The network code catches all execptions and retries them, even exceptions generated by the
+-- 'error' or 'panic' function. To actually force the termination of 'db-sync' we therefore
+-- need a custom panic function that is guaranteed to abort when we want it to.
+-- However, we may not want to abort in production, so we make it optional by use of an
+-- environment variable.
+shouldAbortOnPanic :: Text -> IO ()
+shouldAbortOnPanic msg = do
+  whenM hasAbortOnPanicEnv $ do
+    threadDelay 100000 -- 0.1 seconds
+    mapM_ putStrLn ["DbSyncAbortOnPanic: ", msg]
+    exitImmediately (ExitFailure 1)
+
+hasAbortOnPanicEnv :: IO Bool
+hasAbortOnPanicEnv = isJust <$> lookupEnv "DbSyncAbortOnPanic"

cardano-db-sync/src/Cardano/DbSync/Util.hs

@@ -15,10 +15,7 @@ module Cardano.DbSync.Util (
   maybeFromStrict,
   maybeToStrict,
   nullMetricSetters,
-  panicAbort,
-  logAndPanic,
   plusCoin,
-  readAbortOnPanic,
   renderByteArray,
   renderPoint,
   renderSlotList,
@@ -54,16 +51,13 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Strict.Maybe as Strict
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import qualified Data.Text.IO as Text
 import qualified Data.Time.Clock as Time
 import Ouroboros.Consensus.Block.Abstract (ConvertRawHash (..))
 import Ouroboros.Consensus.Protocol.Praos.Translate ()
 import Ouroboros.Consensus.Shelley.HFEras ()
 import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
 import Ouroboros.Network.Block (blockSlot, getPoint)
 import qualified Ouroboros.Network.Point as Point
-import System.Environment (lookupEnv)
-import System.Posix.Process (exitImmediately)
 import Text.Show.Pretty (ppShow)
 
 cardanoBlockSlotNo :: CardanoBlock -> SlotNo
@@ -140,29 +134,9 @@ nullMetricSetters =
     , metricsSetDbSlotHeight = const $ pure ()
     }
 
--- The network code catches all execptions and retries them, even exceptions generated by the
--- 'error' or 'panic' function. To actually force the termination of 'db-sync' we therefore
--- need a custom panic function that is guaranteed to abort when we want it to.
--- However, we may not want to abort in production, so we make it optional by use of an
--- environment variable.
-panicAbort :: Text -> IO ()
-panicAbort msg = do
-  whenM readAbortOnPanic $ do
-    threadDelay 100000 -- 0.1 seconds
-    mapM_ Text.putStrLn ["panic abort:", msg]
-    exitImmediately (ExitFailure 1)
-
-logAndPanic :: Trace IO Text -> Text -> IO ()
-logAndPanic tracer msg = do
-  logError tracer msg
-  panic msg
-
 plusCoin :: Coin -> Coin -> Coin
 plusCoin (Coin a) (Coin b) = Coin (a + b)
 
-readAbortOnPanic :: IO Bool
-readAbortOnPanic = isJust <$> lookupEnv "DbSyncAbortOnPanic"
-
 renderByteArray :: ByteArrayAccess bin => bin -> Text
 renderByteArray =
   Text.decodeUtf8 . Base16.encode . Data.ByteArray.convert