db-analyser: clean up

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -76,7 +76,6 @@ executable db-analyser
  , cardano-binary
  , cardano-crypto-wrapper
  , cardano-ledger
- , cardano-slotting
  , containers
  , contra-tracer
  , directory

ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs

@@ -1,18 +1,22 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Analysis (
  AnalysisName (..)
  , runAnalysis
+ , AnalysisEnv (..)
  ) where
 
 import Control.Monad.Except
-import Data.IORef
 import Data.List (intercalate)
 import qualified Data.Map.Strict as Map
+import Data.Word (Word16)
 
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
+import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Util.ResourceRegistry
 
 import Ouroboros.Consensus.Storage.ChainDB (ChainDB)
@@ -38,89 +42,87 @@ data AnalysisName =
  | OnlyValidation
  deriving Show
 
-type Analysis blk = TopLevelConfig blk
- -> Either (ImmutableDB IO blk) (ChainDB IO blk)
- -> ResourceRegistry IO
- -> IO ()
-
-emptyAnalysis :: Analysis blk
-emptyAnalysis _ _ _ = return ()
-
 runAnalysis :: HasAnalysis blk => AnalysisName -> Analysis blk
 runAnalysis ShowSlotBlockNo = showSlotBlockNo
 runAnalysis CountTxOutputs = countTxOutputs
-runAnalysis ShowBlockHeaderSize = showBlockHeaderSize
+runAnalysis ShowBlockHeaderSize = showHeaderSize
 runAnalysis ShowBlockTxsSize = showBlockTxsSize
 runAnalysis ShowEBBs = showEBBs
-runAnalysis OnlyValidation = emptyAnalysis
+runAnalysis OnlyValidation = \_ -> return ()
+
+type Analysis blk = AnalysisEnv blk -> IO ()
+
+data AnalysisEnv blk = AnalysisEnv {
+ cfg :: TopLevelConfig blk
+ , initLedger :: ExtLedgerState blk
+ , db :: Either (ImmutableDB IO blk) (ChainDB IO blk)
+ , registry :: ResourceRegistry IO
+ }
 
 {-------------------------------------------------------------------------------
  Analysis: show block and slot number for all blocks
 -------------------------------------------------------------------------------}
 
-showSlotBlockNo :: forall blk. HasHeader blk => Analysis blk
-showSlotBlockNo _cfg db rr = processAll db rr go
+showSlotBlockNo :: forall blk. HasAnalysis blk => Analysis blk
+showSlotBlockNo AnalysisEnv { db, registry } =
+ processAll_ db registry GetHeader process
  where
- go :: blk -> IO ()
- go blk = putStrLn $ intercalate "\t" [
- show (blockNo blk)
- , show (blockSlot blk)
+ process :: Header blk -> IO ()
+ process hdr = putStrLn $ intercalate "\t" [
+ show (blockNo hdr)
+ , show (blockSlot hdr)
  ]
 
 {-------------------------------------------------------------------------------
  Analysis: show total number of tx outputs per block
 -------------------------------------------------------------------------------}
 
 countTxOutputs :: forall blk. HasAnalysis blk => Analysis blk
-countTxOutputs _cfg db rr = do
- cumulative <- newIORef 0
- processAll db rr (go cumulative)
+countTxOutputs AnalysisEnv { db, registry } = do
+ void $ processAll db registry GetBlock 0 process
  where
- go :: IORef Int -> blk -> IO ()
- go cumulative blk = do
- countCum <- atomicModifyIORef cumulative $ \c ->
- let c' = c + count in (c', c')
+ process :: Int -> blk -> IO Int
+ process cumulative blk = do
+ let cumulative' = cumulative + count
  putStrLn $ intercalate "\t" [
  show slotNo
  , show count
- , show countCum
+ , show cumulative'
  ]
+ return cumulative'
  where
  count = HasAnalysis.countTxOutputs blk
  slotNo = blockSlot blk
 
 {-------------------------------------------------------------------------------
- Analysis: show the block header size in bytes for all blocks
+ Analysis: show the header size in bytes for all blocks
 -------------------------------------------------------------------------------}
 
-showBlockHeaderSize :: forall blk. HasAnalysis blk => Analysis blk
-showBlockHeaderSize _cfg db rr = do
- maxBlockHeaderSizeRef <- newIORef 0
- processAll db rr (go maxBlockHeaderSizeRef)
- maxBlockHeaderSize <- readIORef maxBlockHeaderSizeRef
- putStrLn ("Maximum encountered block header size = " <> show maxBlockHeaderSize)
+showHeaderSize :: forall blk. HasAnalysis blk => Analysis blk
+showHeaderSize AnalysisEnv { db, registry } = do
+ maxHeaderSize <-
+ processAll db registry ((,) <$> GetSlot <*> GetHeaderSize) 0 process
+ putStrLn ("Maximum encountered header size = " <> show maxHeaderSize)
  where
- go :: IORef SizeInBytes -> blk -> IO ()
- go maxBlockHeaderSizeRef blk = do
- void $ modifyIORef' maxBlockHeaderSizeRef (max blockHdrSz)
+ process :: Word16 -> (SlotNo, Word16) -> IO Word16
+ process maxHeaderSize (slotNo, headerSize) = do
  putStrLn $ intercalate "\t" [
  show slotNo
- , "Block header size = " <> show blockHdrSz
+ , "Header size = " <> show headerSize
  ]
- where
- slotNo = blockSlot blk
- blockHdrSz = HasAnalysis.blockHeaderSize blk
+ return $ maxHeaderSize `max` headerSize
 
 {-------------------------------------------------------------------------------
  Analysis: show the total transaction sizes in bytes per block
 -------------------------------------------------------------------------------}
 
 showBlockTxsSize :: forall blk. HasAnalysis blk => Analysis blk
-showBlockTxsSize _cfg db rr = processAll db rr process
+showBlockTxsSize AnalysisEnv { db, registry } =
+ processAll_ db registry GetBlock process
  where
  process :: blk -> IO ()
  process blk = putStrLn $ intercalate "\t" [
- show slotNo
+ show (blockSlot blk)
  , "Num txs in block = " <> show numBlockTxs
  , "Total size of txs in block = " <> show blockTxsSize
  ]
@@ -134,19 +136,17 @@ showBlockTxsSize _cfg db rr = processAll db rr process
  blockTxsSize :: SizeInBytes
  blockTxsSize = sum txSizes
 
- slotNo = blockSlot blk
-
 {-------------------------------------------------------------------------------
  Analysis: show EBBs and their predecessors
 -------------------------------------------------------------------------------}
 
 showEBBs :: forall blk. HasAnalysis blk => Analysis blk
-showEBBs _cfg db rr = do
+showEBBs AnalysisEnv { db, registry } = do
  putStrLn "EBB\tPrev\tKnown"
- processAll db rr processIfEBB
+ processAll_ db registry GetBlock process
  where
- processIfEBB :: blk -> IO ()
- processIfEBB blk =
+ process :: blk -> IO ()
+ process blk =
  case blockIsEBB blk of
  Just _epoch ->
  putStrLn $ intercalate "\t" [
@@ -166,42 +166,60 @@ showEBBs _cfg db rr = do
 -------------------------------------------------------------------------------}
 
 processAll ::
- forall blk. HasHeader blk
+ forall blk b st. HasHeader blk
  => Either (ImmutableDB IO blk) (ChainDB IO blk)
  -> ResourceRegistry IO
- -> (blk -> IO ())
- -> IO ()
+ -> BlockComponent blk b
+ -> st
+ -> (st -> b -> IO st)
+ -> IO st
 processAll = either processAllImmutableDB processAllChainDB
 
+processAll_ ::
+ forall blk b. HasHeader blk
+ => Either (ImmutableDB IO blk) (ChainDB IO blk)
+ -> ResourceRegistry IO
+ -> BlockComponent blk b
+ -> (b -> IO ())
+ -> IO ()
+processAll_ db rr blockComponent callback =
+ processAll db rr blockComponent () (const callback)
+
 processAllChainDB ::
- forall blk. HasHeader blk
+ forall st blk b. HasHeader blk
  => ChainDB IO blk
  -> ResourceRegistry IO
- -> (blk -> IO ())
- -> IO ()
-processAllChainDB chainDB rr callback =
- ChainDB.streamAll chainDB rr GetBlock >>= go
+ -> BlockComponent blk b
+ -> st
+ -> (st -> b -> IO st)
+ -> IO st
+processAllChainDB chainDB rr blockComponent initState callback = do
+ itr <- ChainDB.streamAll chainDB rr blockComponent
+ go itr initState
  where
- go :: ChainDB.Iterator IO blk blk -> IO ()
- go itr = do
-  itrResult <- ChainDB.iteratorNext itr
-  case itrResult of
-  ChainDB.IteratorExhausted -> return ()
-  ChainDB.IteratorResult blk -> callback blk >> go itr
-  ChainDB.IteratorBlockGCed pt -> error $ "block GC'ed " ++ show pt
+ go :: ChainDB.Iterator IO blk b -> st -> IO st
+ go itr !st = do
+ itrResult <- ChainDB.iteratorNext itr
+ case itrResult of
+ ChainDB.IteratorExhausted -> return st
+ ChainDB.IteratorResult b  -> callback st b >>= go itr
+ ChainDB.IteratorBlockGCed pt -> error $ "block GC'ed " <> show pt
 
 processAllImmutableDB ::
- forall blk. HasHeader blk
+ forall st blk b. HasHeader blk
  => ImmutableDB IO blk
  -> ResourceRegistry IO
- -> (blk -> IO ())
- -> IO ()
-processAllImmutableDB immutableDB rr callback = do
- ImmutableDB.streamAll immutableDB rr GetBlock >>= go
+ -> BlockComponent blk b
+ -> st
+ -> (st -> b -> IO st)
+ -> IO st
+processAllImmutableDB immutableDB rr blockComponent initState callback = do
+ itr <- ImmutableDB.streamAll immutableDB rr blockComponent
+ go itr initState
  where
- go :: ImmutableDB.Iterator IO blk blk -> IO ()
- go itr = do
+ go :: ImmutableDB.Iterator IO blk b -> st -> IO st
+ go itr !st = do
  itrResult <- ImmutableDB.iteratorNext itr
  case itrResult of
- ImmutableDB.IteratorExhausted  -> return ()
- ImmutableDB.IteratorResult blk -> callback blk >> go itr
+ ImmutableDB.IteratorExhausted -> return st
+ ImmutableDB.IteratorResult b -> callback st b >>= go itr

ouroboros-consensus-cardano/tools/db-analyser/Block/Byron.hs

@@ -13,13 +13,12 @@ module Block.Byron (
 
 import Control.Monad.Except
 import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import Data.Foldable (asum)
-import GHC.Natural (Natural)
 import Options.Applicative
 
 import Cardano.Binary (Raw, unAnnotated)
+import Cardano.Crypto (RequiresNetworkMagic (..))
 import qualified Cardano.Crypto as Crypto
 
 import qualified Cardano.Chain.Block as Chain
@@ -41,7 +40,7 @@ instance HasAnalysis ByronBlock where
  data Args ByronBlock =
  ByronBlockArgs {
  configFileByron :: FilePath
- , requiresNetworkMagic :: Bool
+ , requiresNetworkMagic :: RequiresNetworkMagic
  , genesisHash :: Maybe (Crypto.Hash Raw)
  , threshold :: Maybe PBftSignatureThreshold
  }
@@ -50,8 +49,6 @@ instance HasAnalysis ByronBlock where
  config <- openGenesisByron configFileByron genesisHash requiresNetworkMagic
  return $ mkByronProtocolInfo config threshold
  countTxOutputs = aBlockOrBoundary (const 0) countTxOutputsByron
- blockHeaderSize = fromIntegral .
- aBlockOrBoundary blockBoundaryHeaderSize blockHeaderSizeByron
  blockTxSizes = aBlockOrBoundary (const []) blockTxSizesByron
  knownEBBs = const Byron.knownEBBs
 
@@ -64,9 +61,9 @@ parseByronArgs = ByronBlockArgs
  , help "Path to config file"
  , metavar "PATH"
  ])
- <*> switch (mconcat [
- long "testnet"
- , help "The DB contains blocks from testnet rather than mainnet"
+ <*> flag RequiresNoMagic RequiresMagic (mconcat [
+ long "requires-magic"
+ , help "The DB contains blocks from a testnet, requiring network magic, rather than mainnet"
  ])
  <*> parseMaybe (option auto (mconcat [
  long "genesisHash"
@@ -107,13 +104,6 @@ countTxOutputsByron Chain.ABlock{..} = countTxPayload bodyTxPayload
  countTx :: Chain.Tx -> Int
  countTx = length . Chain.txOutputs
 
-blockBoundaryHeaderSize :: Chain.ABoundaryBlock ByteString -> Natural
-blockBoundaryHeaderSize =
- fromIntegral . BS.length . Chain.boundaryHeaderAnnotation . Chain.boundaryHeader
-
-blockHeaderSizeByron :: Chain.ABlock ByteString -> Natural
-blockHeaderSizeByron = Chain.headerLength . Chain.blockHeader
-
 blockTxSizesByron :: Chain.ABlock ByteString -> [SizeInBytes]
 blockTxSizesByron block =
  map (fromIntegral . BL.length . BL.fromStrict . Chain.aTaAnnotation) blockTxAuxs
@@ -122,17 +112,19 @@ blockTxSizesByron block =
  Chain.ABody{ bodyTxPayload } = blockBody
  Chain.ATxPayload{ aUnTxPayload = blockTxAuxs } = bodyTxPayload
 
-openGenesisByron :: FilePath -> Maybe (Crypto.Hash Raw) -> Bool -> IO Genesis.Config
-openGenesisByron configFile mHash onMainNet = do
+openGenesisByron ::
+ FilePath
+ -> Maybe (Crypto.Hash Raw)
+ -> RequiresNetworkMagic
+ -> IO Genesis.Config
+openGenesisByron configFile mHash requiresNetworkMagic = do
  genesisHash <- case mHash of
  Nothing -> either (error . show) return =<< runExceptT
  (Genesis.unGenesisHash . snd <$> Genesis.readGenesisData configFile)
  Just hash -> return hash
  genesisConfig <- either (error . show) return =<< runExceptT
  (Genesis.mkConfigFromFile
- (if onMainNet -- transactions on testnet include magic number
- then Crypto.RequiresNoMagic
- else Crypto.RequiresMagic)
+ requiresNetworkMagic
  configFile
  genesisHash)
  return genesisConfig

ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs

@@ -60,9 +60,6 @@ instance HasAnalysis (CardanoBlock StandardCrypto) where
  countTxOutputs blk = case blk of
  Cardano.BlockByron b -> countTxOutputs b
  Cardano.BlockShelley sh -> countTxOutputs sh
- blockHeaderSize blk = case blk of
- Cardano.BlockByron b -> blockHeaderSize b
- Cardano.BlockShelley sh -> blockHeaderSize sh
  blockTxSizes blk = case blk of
  Cardano.BlockByron b -> blockTxSizes b
  Cardano.BlockShelley sh -> blockTxSizes sh

ouroboros-consensus-cardano/tools/db-analyser/Block/Shelley.hs

@@ -42,8 +42,6 @@ instance HasAnalysis (ShelleyBlock StandardShelley) where
  return $ mkShelleyProtocolInfo config initialNonce
  countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
  SL.Block _ (SL.TxSeq txs) -> sum $ fmap countOutputs txs
- blockHeaderSize =
- fromIntegral . SL.bHeaderSize . SL.bheader . Shelley.shelleyBlockRaw
  blockTxSizes blk = case Shelley.shelleyBlockRaw blk of
  SL.Block _ (SL.TxSeq txs) ->
  toList $ fmap (fromIntegral . BL.length . SL.txFullBytes) txs

ouroboros-consensus-cardano/tools/db-analyser/HasAnalysis.hs

@@ -19,6 +19,5 @@ class GetPrevHash blk => HasAnalysis blk where
  argsParser :: proxy blk -> Parser (Args blk)
  mkProtocolInfo :: Args blk -> IO (ProtocolInfo IO blk)
  countTxOutputs :: blk -> Int
- blockHeaderSize :: blk -> SizeInBytes
  blockTxSizes :: blk -> [SizeInBytes]
  knownEBBs :: proxy blk -> Map (HeaderHash blk) (ChainHash blk)