Skip to content

Commit 9abb759

Browse files
CmdvCmdv
committed
make show instances & convert ordie > showOrThrowIO
1 parent 5322c54 commit 9abb759

File tree

19 files changed

+99
-152
lines changed

19 files changed

+99
-152
lines changed

‎cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ import qualified Cardano.Db as Db
4242
import Cardano.DbSync
4343
import Cardano.DbSync.Config
4444
import Cardano.DbSync.Config.Cardano
45-
import Cardano.DbSync.Error
45+
import Cardano.DbSync.Error (runOrThrowIO)
4646
import Cardano.DbSync.Types (CardanoBlock, MetricSetters (..))
4747
import Cardano.Mock.ChainSync.Server
4848
import Cardano.Mock.Forging.Interpreter
@@ -63,8 +63,7 @@ import Control.Exception (SomeException, bracket)
6363
import Control.Monad (void)
6464
import Control.Monad.Extra (eitherM)
6565
import Control.Monad.Logger (NoLoggingT, runNoLoggingT)
66-
import Control.Monad.Trans.Except.Exit (orDie)
67-
import Control.Monad.Trans.Except.Extra (newExceptT, runExceptT)
66+
import Control.Monad.Trans.Except.Extra (runExceptT)
6867
import Control.Tracer (nullTracer)
6968
import Data.Text (Text)
7069
import qualified Data.Text as Text
@@ -206,7 +205,7 @@ getPoolLayer env = do
206205
mkConfig :: FilePath -> FilePath -> CommandLineArgs -> IO Config
207206
mkConfig staticDir mutableDir cmdLineArgs = do
208207
config <- readSyncNodeConfig $ ConfigFile (staticDir </> "test-db-sync-config.json")
209-
genCfg <- either (error . Text.unpack . renderSyncNodeError) id <$> runExceptT (readCardanoGenesisConfig config)
208+
genCfg <- runOrThrowIO $ runExceptT (readCardanoGenesisConfig config)
210209
let (pInfoDbSync, _) = mkProtocolInfoCardano genCfg []
211210
creds <- mkShelleyCredentials $ staticDir </> "pools" </> "bulk1.creds"
212211
let (pInfoForger, forging) = mkProtocolInfoCardano genCfg creds
@@ -230,7 +229,7 @@ mkShelleyCredentials bulkFile = do
230229

231230
-- | staticDir can be shared by tests running in parallel. mutableDir not.
232231
mkSyncNodeParams :: FilePath -> FilePath -> CommandLineArgs -> IO SyncNodeParams
233-
mkSyncNodeParams staticDir mutableDir CommandLineArgs{..} = do
232+
mkSyncNodeParams staticDir mutableDir CommandLineArgs {..} = do
234233
pgconfig <- runOrThrowIO Db.readPGPassDefault
235234
pure $
236235
SyncNodeParams

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

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ import Cardano.DbSync.Era.Shelley.Offline.Http (
5555
renderFetchError,
5656
spodJson,
5757
)
58-
import Cardano.DbSync.Error ( renderSyncNodeError, runOrThrowExcept, SyncNodeError )
58+
import Cardano.DbSync.Error (SyncNodeError, runOrThrowIO)
5959
import Cardano.DbSync.Ledger.State
6060
import Cardano.DbSync.Rollback (unsafeRollback)
6161
import Cardano.DbSync.Sync (runSyncNodeClient)
@@ -85,8 +85,6 @@ runDbSyncNode metricsSetters knownMigrations params =
8585

8686
runDbSync metricsSetters knownMigrations iomgr trce params aop
8787

88-
89-
9088
runDbSync ::
9189
MetricSetters ->
9290
[(Text, Text)] ->
@@ -174,7 +172,7 @@ runSyncNode metricsSetters trce iomgr dbConnString ranMigrations runMigrationFnc
174172
logInfo trce $ "Using alonzo genesis file from: " <> (show . unGenesisFile $ dncAlonzoGenesisFile syncNodeConfig)
175173
Db.runIohkLogging trce $
176174
withPostgresqlConn dbConnString $ \backend -> liftIO $ do
177-
orDie renderSyncNodeError $ do
175+
runOrThrowIO $ runExceptT $ do
178176
genCfg <- readCardanoGenesisConfig syncNodeConfig
179177
logProtocolMagicId trce $ genesisProtocolMagicId genCfg
180178

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ runDbThread syncEnv metricsSetters queue = do
6565
setDbSlotHeight metricsSetters $ bSlotNo block
6666

6767
case eNextState of
68-
Left err -> logError trce $ renderSyncNodeError err
68+
Left err -> logError trce $ show err
6969
Right Continue -> loop
7070
Right Done -> pure ()
7171
Just resultVar -> do

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do
6565
-- Setting this to True will log all 'Persistent' operations which is great
6666
-- for debugging, but otherwise *way* too chatty.
6767
when (not shelleyInitiation && (hasInitialFunds || hasStakes)) $ do
68-
liftIO $ logError tracer $ renderSyncNodeError NEIgnoreShelleyInitiation
68+
liftIO $ logError tracer $ show NEIgnoreShelleyInitiation
6969
throwError NEIgnoreShelleyInitiation
7070
if False
7171
then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer (insertAction hasConsumed prunes)

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ import qualified Data.Text.Encoding.Error as Text
2020

2121
liftLookupFail :: Monad m => Text -> m (Either DB.LookupFail a) -> ExceptT SyncNodeError m a
2222
liftLookupFail loc =
23-
firstExceptT (\lf -> NEError $ mconcat [loc, " ", DB.renderLookupFail lf]) . newExceptT
23+
firstExceptT (\lf -> NEError $ mconcat [loc, " ", show lf]) . newExceptT
2424

2525
safeDecodeUtf8 :: ByteString -> IO (Either Text.UnicodeException Text)
2626
safeDecodeUtf8 bs

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

Lines changed: 55 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# LANGUAGE NoImplicitPrelude #-}
33
{-# LANGUAGE RankNTypes #-}
4+
{-# LANGUAGE LambdaCase #-}
45

56
module Cardano.DbSync.Error (
67
SyncInvariant (..),
@@ -10,7 +11,6 @@ module Cardano.DbSync.Error (
1011
dbSyncNodeError,
1112
dbSyncInvariant,
1213
renderSyncInvariant,
13-
renderSyncNodeError,
1414
runOrThrowIO
1515
) where
1616

@@ -24,6 +24,8 @@ import Control.Monad.Trans.Except.Extra (left)
2424
import qualified Data.ByteString.Base16 as Base16
2525
import qualified Data.Text as Text
2626
import qualified Data.Text.Encoding as Text
27+
import qualified GHC.Show as GShow
28+
import qualified Text.Show as Text
2729

2830
data SyncInvariant
2931
= EInvInOut !Word64 !Word64
@@ -39,6 +41,55 @@ data SyncNodeError
3941
| NEAlonzoConfig !FilePath !Text
4042
| NECardanoConfig !Text
4143

44+
instance Exception SyncNodeError
45+
46+
instance Show SyncNodeError where
47+
show =
48+
\case
49+
NEError t -> "Error: " <> Text.show t
50+
NEInvariant loc i -> Text.show loc <> ": " <> Text.show (renderSyncInvariant i)
51+
NEBlockMismatch blkNo hashDb hashBlk ->
52+
mconcat
53+
[ "Block mismatch for block number "
54+
, show blkNo
55+
, ", db has "
56+
, Text.show $ bsBase16Encode hashDb
57+
, " but chain provided "
58+
, Text.show $ bsBase16Encode hashBlk
59+
]
60+
NEIgnoreShelleyInitiation ->
61+
mconcat
62+
[ "Node configs that don't fork to Shelley directly and initiate"
63+
, " funds or stakes in Shelley Genesis are not supported."
64+
]
65+
NEByronConfig fp ce ->
66+
mconcat
67+
[ "Failed reading Byron genesis file "
68+
, Text.show $ textShow fp
69+
, ": "
70+
, Text.show $ textShow ce
71+
]
72+
NEShelleyConfig fp txt ->
73+
mconcat
74+
[ "Failed reading Shelley genesis file "
75+
, Text.show $ textShow fp
76+
, ": "
77+
, show txt
78+
]
79+
NEAlonzoConfig fp txt ->
80+
mconcat
81+
[ "Failed reading Alonzo genesis file "
82+
, Text.show $ textShow fp
83+
, ": "
84+
, show txt
85+
]
86+
NECardanoConfig err ->
87+
mconcat
88+
[ "With Cardano protocol, Byron/Shelley config mismatch:\n"
89+
, " "
90+
, show err
91+
]
92+
4293
annotateInvariantTx :: Byron.Tx -> SyncInvariant -> SyncInvariant
4394
annotateInvariantTx tx ei =
4495
case ei of
@@ -68,62 +119,15 @@ renderSyncInvariant ei =
68119
, textShow tx
69120
]
70121

71-
renderSyncNodeError :: SyncNodeError -> Text
72-
renderSyncNodeError ne =
73-
case ne of
74-
NEError t -> "Error: " <> t
75-
NEInvariant loc i -> mconcat [loc, ": " <> renderSyncInvariant i]
76-
NEBlockMismatch blkNo hashDb hashBlk ->
77-
mconcat
78-
[ "Block mismatch for block number "
79-
, textShow blkNo
80-
, ", db has "
81-
, bsBase16Encode hashDb
82-
, " but chain provided "
83-
, bsBase16Encode hashBlk
84-
]
85-
NEIgnoreShelleyInitiation ->
86-
mconcat
87-
[ "Node configs that don't fork to Shelley directly and initiate"
88-
, " funds or stakes in Shelley Genesis are not supported."
89-
]
90-
NEByronConfig fp ce ->
91-
mconcat
92-
[ "Failed reading Byron genesis file "
93-
, textShow fp
94-
, ": "
95-
, textShow ce
96-
]
97-
NEShelleyConfig fp txt ->
98-
mconcat
99-
[ "Failed reading Shelley genesis file "
100-
, textShow fp
101-
, ": "
102-
, txt
103-
]
104-
NEAlonzoConfig fp txt ->
105-
mconcat
106-
[ "Failed reading Alonzo genesis file "
107-
, textShow fp
108-
, ": "
109-
, txt
110-
]
111-
NECardanoConfig err ->
112-
mconcat
113-
[ "With Cardano protocol, Byron/Shelley config mismatch:\n"
114-
, " "
115-
, err
116-
]
117-
118122
bsBase16Encode :: ByteString -> Text
119123
bsBase16Encode bs =
120124
case Text.decodeUtf8' (Base16.encode bs) of
121-
Left _ -> Text.pack $ "UTF-8 decode failed for " ++ show bs
125+
Left _ -> Text.pack $ "UTF-8 decode failed for " ++ Text.show bs
122126
Right txt -> txt
123127

124128
runOrThrowIO :: forall e a. Exception e => IO (Either e a) -> IO a
125129
runOrThrowIO ioEither = do
126-
either <- ioEither
127-
case either of
130+
et <- ioEither
131+
case et of
128132
Left err -> throwIO err
129133
Right a -> pure a

‎cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -74,6 +74,7 @@ import qualified Data.Set as Set
7474
import qualified Data.Strict.Maybe as Strict
7575
import qualified Data.Text as Text
7676
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
77+
import GHC.IO.Exception (userError)
7778
import Lens.Micro ((^.))
7879
import Ouroboros.Consensus.Block (
7980
CodecConfig,

‎cardano-db-tool/app/cardano-db-tool.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,8 +6,6 @@ import Cardano.DbTool
66
import Cardano.Slotting.Slot (SlotNo (..))
77
import Control.Applicative (optional)
88
import Control.Monad (unless, void, when)
9-
import Control.Monad.Trans.Except.Exit (orDie)
10-
import Control.Monad.Trans.Except.Extra (newExceptT)
119
import Data.Text (Text)
1210
import qualified Data.Text as Text
1311
import qualified Data.Text.IO as Text
@@ -54,7 +52,7 @@ runCommand cmd =
5452
CmdReport report -> runReport report
5553
CmdRollback slotNo -> runRollback slotNo
5654
CmdRunMigrations mdir forceIndexes mockFix mldir -> do
57-
pgConfig <- runOrThrowIO (readPGPass PGPassDefaultEnv)
55+
pgConfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv)
5856
unofficial <- snd <$> runMigrations pgConfig False mdir mldir Initial
5957
unless (null unofficial) $
6058
putStrLn $

‎cardano-db-tool/cardano-db-tool.cabal

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -107,4 +107,3 @@ executable cardano-db-tool
107107
, cardano-slotting
108108
, optparse-applicative
109109
, text
110-
, transformers-except

‎cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ import Cardano.DbSync.Tracing.ToObjectOrphans ()
1313
import Cardano.DbTool.Validate.Balance (ledgerAddrBalance)
1414
import Cardano.DbTool.Validate.Util
1515
import Control.Monad (when)
16-
import Control.Monad.Trans.Except.Exit (orDie)
16+
import Control.Monad.Trans.Except (runExceptT)
1717
import Control.Tracer (nullTracer)
1818
import Data.Text (Text)
1919
import qualified Data.Text as Text
@@ -33,7 +33,7 @@ validateLedger :: LedgerValidationParams -> IO ()
3333
validateLedger params =
3434
withIOManager $ \_ -> do
3535
enc <- readSyncNodeConfig (vpConfigFile params)
36-
genCfg <- orDie renderSyncNodeError $ readCardanoGenesisConfig enc
36+
genCfg <- runOrThrowIO $ runExceptT $ readCardanoGenesisConfig enc
3737
ledgerFiles <- listLedgerStateFilesOrdered (vpLedgerStateDir params)
3838
slotNo <- SlotNo <$> DB.runDbNoLoggingEnv DB.queryLatestSlotNo
3939
validate params genCfg slotNo ledgerFiles

0 commit comments

Comments
 (0)