Fix rebase on top of master

cabal.project

@@ -138,3 +138,15 @@ constraints:
 
 allow-newer:
     Unique:hashable
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/haskell-lmdb
+  tag: 5aef2ccc8b7e5e91aa609dc531df392c46eaae09
+  --sha256: 09sxgxylf9m78qmf1sh82ydvq3ihkgfh829yy9cd526kp75wiy86
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/lmdb-simple
+  tag: 5b2c622c1cf43deca081139b2d1d1eb9fc991064
+  --sha256: 0n96rzj4901y0q2l1fb6ffjp1kvgqchliig9id6jaq05xn4v386s

ouroboros-consensus-byron-test/test/Main.hs

@@ -4,8 +4,8 @@ import           Test.Tasty
 
 import qualified Test.Consensus.Byron.Golden (tests)
 import qualified Test.Consensus.Byron.Serialisation (tests)
---import qualified Test.ThreadNet.Byron (tests)
---import qualified Test.ThreadNet.DualByron (tests)
+import qualified Test.ThreadNet.Byron (tests)
+import qualified Test.ThreadNet.DualByron (tests)
 import           Test.Util.TestEnv (defaultMainWithTestEnv,
                      defaultTestEnvConfig)
 

ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Translation.hs

@@ -34,7 +34,6 @@ import           Cardano.Ledger.Alonzo.Scripts (CostModels (..), ExUnits (..),
 import           Cardano.Ledger.BaseTypes (Network (Testnet), TxIx (..))
 import           Cardano.Ledger.Coin (Coin (..))
 import qualified Cardano.Ledger.Core as Core
-import qualified Cardano.Ledger.Era as Core
 import           Cardano.Ledger.Shelley.API
                      (NewEpochState (stashedAVVMAddresses), ShelleyGenesis (..),
                      ShelleyGenesisStaking (..), TxIn (..),

ouroboros-consensus-cardano-tools/app/DBAnalyser/Parsers.hs

@@ -41,6 +41,30 @@ parseCmdLine = DBAnalyserConfig
     <*> blockTypeParser
     <*> parseAnalysis
     <*> parseLimit
+    <*> parseSelector
+
+parseSelector :: Parser BackingStore
+parseSelector = maybe MEM id <$> parseMaybe (asum [
+      MEM <$ parseMEM
+    , LMDB <$ parseLMDB <*> parseMapSize
+    ])
+  where
+    parseMEM :: Parser ()
+    parseMEM = flag' () $ mconcat [
+        long "inmem-backingstore"
+      , help "Choose the in-memory backing store for the LedgerDB."
+      ]
+    parseLMDB :: Parser ()
+    parseLMDB = flag' () $ mconcat [
+        long "lmdb-backingstore"
+      , help "Choose the LMDB backing store for the LedgerDB."
+      ]
+    parseMapSize :: Parser (Maybe Int)
+    parseMapSize = optional $ read <$> strOption (mconcat [
+        long "mapsize"
+      , metavar "NR_BYTES"
+      , help "The maximum database size defined in nr. of bytes NR_BYTES. NR_BYTES must be a multiple of the OS page size."
+      ])
 
 parseSelectDB :: Parser SelectDB
 parseSelectDB = asum [
@@ -129,14 +153,14 @@ checkNoThunksParser = CheckNoThunksEvery <$> option auto
   <> metavar "BLOCK_COUNT"
   <> help "Check the ledger state for thunks every n blocks" )
 
-parseLimit :: Parser Limit
+parseLimit :: Parser (Maybe Int)
 parseLimit = asum [
-    Limit <$> option auto (mconcat [
+    read <$> strOption (mconcat [
         long "num-blocks-to-process"
       , help "Maximum number of blocks we want to process"
       , metavar "INT"
       ])
-  , pure Unlimited
+  , pure Nothing
   ]
 
 blockTypeParser :: Parser BlockType

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -8,7 +8,6 @@ module Cardano.Tools.DBAnalyser.Analysis (
     AnalysisEnv (..)
   , AnalysisName (..)
   , AnalysisResult (..)
-  , Limit (..)
   , runAnalysis
   ) where
 
@@ -98,7 +97,7 @@ runAnalysis analysisName env@AnalysisEnv{ tracer } = do
   pure result
   where
     go ShowSlotBlockNo             = showSlotBlockNo env
-    go CountTxOutputs              = Analysis.countTxOutputs env
+    go CountTxOutputs              = countTxOutputs env
     go ShowBlockHeaderSize         = showHeaderSize env
     go ShowBlockTxsSize            = showBlockTxsSize env
     go ShowEBBs                    = showEBBs env
@@ -242,7 +241,7 @@ showSlotBlockNo env = do
 
 countTxOutputs :: forall blk. HasAnalysis blk => Analysis blk
 countTxOutputs env = do
-  doProcess env 0 process GetBlock
+  void $ doProcess env 0 process GetBlock
   pure Nothing
   where
     process :: blk -> Int ->  IO Int
@@ -461,7 +460,7 @@ checkNoThunksEvery ::
   -> Analysis blk
 checkNoThunksEvery
   nBlocks
-  AnalysisEnv {db, initLedger, cfg, ledgerDbFS, limit, backing} = void $ do
+  AnalysisEnv {db, initLedger, cfg, ledgerDbFS, limit, backing} = do
     putStrLn $
       "Checking for thunks in each block where blockNo === 0 (mod " <> show nBlocks <> ")."
     doCheck <- onlyCheckNumBlocks limit
@@ -472,15 +471,15 @@ checkNoThunksEvery
                                                                 Left s -> Left (initLedger', s)
                                                                 Right v -> Right v
 
-    runExceptT (consumeStream (mkStream doCheck GetBlock db) (castPoint . getTip $ initLedger') (ldb, 0, 0) (push configLedgerDb f bs))
+    void $ runExceptT (consumeStream (mkStream doCheck GetBlock db) (castPoint . getTip $ initLedger') (ldb, 0, 0) (push configLedgerDb f bs))
     pure Nothing
   where
     configLedgerDb = LedgerDbCfg {
         ledgerDbCfgSecParam = configSecurityParam cfg
       , ledgerDbCfg         = ExtLedgerCfg cfg
       }
 
-    f blk _ newLedger = when (unBlockNo (blockNo blk) `mod` nBlocks == 0 ) $ IOLike.evaluate (ledgerState newLedger) >>= checkNoThunks (blockNo blk)
+    f blk _ newLedger = when (unBlockNo (blockNo blk) `mod` nBlocks == 0 ) $ IOLike.evaluate newLedger >>= checkNoThunks (blockNo blk)
 
     checkNoThunks :: BlockNo -> ExtLedgerState blk EmptyMK -> IO ()
     checkNoThunks bn ls =
@@ -500,15 +499,15 @@ traceLedgerProcessing ::
   HasAnalysis blk =>
   Analysis blk
 traceLedgerProcessing
-  AnalysisEnv {db, initLedger, cfg, limit, backing, ledgerDbFS} = void $ do
+  AnalysisEnv {db, initLedger, cfg, limit, backing, ledgerDbFS} = do
     doCheck <- onlyCheckNumBlocks limit
 
     initLedger' <- initialiseLedger ledgerDbFS cfg initLedger
     (ldb, bs) <- ledgerDbAndBackingStore backing ledgerDbFS $ case initLedger of
                                                                 Left s -> Left (initLedger', s)
                                                                 Right v -> Right v
 
-    runExceptT (consumeStream (mkStream doCheck GetBlock db) (castPoint . getTip $ initLedger') (ldb, 0, 0) (push configLedgerDb f bs))
+    void $ runExceptT (consumeStream (mkStream doCheck GetBlock db) (castPoint . getTip $ initLedger') (ldb, 0, 0) (push configLedgerDb f bs))
     pure Nothing
   where
     configLedgerDb = LedgerDbCfg {

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Shelley.hs

@@ -49,7 +49,7 @@ import           Cardano.Tools.DBAnalyser.HasAnalysis
 -- | Usable for each Shelley-based era
 instance ( ShelleyCompatible proto era
          , LedgerSupportsProtocol (ShelleyBlock proto era)
-         , HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era))
+--         , HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era))
          ) => HasAnalysis (ShelleyBlock proto era) where
 
   countTxOutputs blk = case Shelley.shelleyBlockRaw blk of

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/HasAnalysis.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies     #-}
-module HasAnalysis (
+module Cardano.Tools.DBAnalyser.HasAnalysis (
     HasAnalysis (..)
   , HasProtocolInfo (..)
   , SizeInBytes

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Run.hs

@@ -5,9 +5,6 @@
 
 module Cardano.Tools.DBAnalyser.Run (analyse) where
 
-import           Codec.CBOR.Decoding (Decoder)
-import           Codec.Serialise (Serialise (decode))
-import           Control.Monad.Except (runExceptT)
 import qualified Debug.Trace as Debug
 import           System.IO
 
@@ -16,23 +13,20 @@ import           Control.Tracer (Tracer (..), nullTracer)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
-import           Ouroboros.Consensus.Ledger.Extended
-import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool
-                     (HasTxs)
 import qualified Ouroboros.Consensus.Node as Node
 import qualified Ouroboros.Consensus.Node.InitStorage as Node
 import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
-import           Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..))
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.Orphans ()
 import           Ouroboros.Consensus.Util.ResourceRegistry
 
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.Args (fromChainDbArgs)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
+import           Ouroboros.Consensus.Storage.LedgerDB.HD.LMDB
 import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                      (SnapshotInterval (..), defaultDiskPolicy)
-import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (readSnapshot)
+import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (BackingStoreSelector(..))
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 
 import           Cardano.Tools.DBAnalyser.Analysis
@@ -44,18 +38,27 @@ import           Cardano.Tools.DBAnalyser.Types
   Analyse
 -------------------------------------------------------------------------------}
 
+defaultLMDBLimits :: LMDBLimits
+defaultLMDBLimits = LMDBLimits
+  { -- 16 Gib
+    lmdbMapSize = 16 * 1024 * 1024 * 1024
+    -- 4 internal databases: 1 for the settings, 1 for the state, 2 for the
+    -- ledger tables.
+  , lmdbMaxDatabases = 4
+  , lmdbMaxReaders = 16
+  }
+
 analyse ::
      forall blk .
      ( Node.RunNode blk
      , Show (Header blk)
      , HasAnalysis blk
      , HasProtocolInfo blk
-     , LedgerSupportsMempool.HasTxs blk
      )
   => DBAnalyserConfig
   -> Args blk
   -> IO (Maybe AnalysisResult)
-analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbose} args =
+analyse DBAnalyserConfig{analysis, cfgLimit, dbDir, selectDB, validation, verbose, bsSelector} args =
     withRegistry $ \registry -> do
 
       chainDBTracer  <- mkTracer verbose
@@ -68,7 +71,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
           args' =
             Node.mkChainDbArgs
               registry InFuture.dontCheck cfg genesisLedger chunkInfo $
-            ChainDB.defaultArgs (Node.stdMkChainDbHasFS dbDir) diskPolicy
+            ChainDB.defaultArgs (Node.stdMkChainDbHasFS dbDir) diskPolicy InMemoryBackingStore
           chainDbArgs = args' {
               ChainDB.cdbImmutableDbValidation = immValidationPolicy
             , ChainDB.cdbVolatileDbValidation  = volValidationPolicy
@@ -79,10 +82,17 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
 
       case selectDB of
         SelectImmutableDB initializeFrom -> do
-          initLedgerErr <- runExceptT $ case initializeFrom of
-            Nothing       -> pure genesisLedger
-            Just snapshot -> readSnapshot ledgerDbFS (decodeExtLedgerState' cfg) decode snapshot
-          initLedger <- either (error . show) pure initLedgerErr
+          let initLedger = case initializeFrom of
+                                Nothing       -> Right genesisLedger
+                                Just snapshot -> Left snapshot
+
+          let bs = case bsSelector of
+                MEM          -> InMemoryBackingStore
+                LMDB mapsize ->
+                  maybe
+                    (LMDBBackingStore defaultLMDBLimits)
+                    (\n -> LMDBBackingStore (defaultLMDBLimits { lmdbMapSize = n }))
+                    mapsize
           -- This marker divides the "loading" phase of the program, where the
           -- system is principally occupied with reading snapshot data from
           -- disk, from the "processing" phase, where we are streaming blocks
@@ -93,10 +103,10 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
                 cfg
               , initLedger
               , db = Left immutableDB
-              , registry
               , ledgerDbFS = ledgerDbFS
-              , limit = confLimit
+              , limit = cfgLimit
               , tracer = analysisTracer
+              , backing = bs
               }
             tipPoint <- atomically $ ImmutableDB.getTipPoint immutableDB
             putStrLn $ "ImmutableDB tip: " ++ show tipPoint
@@ -105,12 +115,18 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
           ChainDB.withDB chainDbArgs $ \chainDB -> do
             result <- runAnalysis analysis $ AnalysisEnv {
                 cfg
-              , initLedger = genesisLedger
+              , initLedger = Right genesisLedger
               , db = Right chainDB
-              , registry
               , ledgerDbFS = ledgerDbFS
-              , limit = confLimit
+              , limit = cfgLimit
               , tracer = analysisTracer
+              , backing = case bsSelector of
+                            MEM          -> InMemoryBackingStore
+                            LMDB mapsize ->
+                              maybe
+                                (LMDBBackingStore defaultLMDBLimits)
+                                (\n -> LMDBBackingStore (defaultLMDBLimits { lmdbMapSize = n }))
+                                mapsize
               }
             tipPoint <- atomically $ ChainDB.getTipPoint chainDB
             putStrLn $ "ChainDB tip: " ++ show tipPoint
@@ -136,11 +152,3 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
       (_, Just MinimumBlockValidation) -> VolatileDB.NoValidation
       (OnlyValidation, _ )             -> VolatileDB.ValidateAll
       _                                -> VolatileDB.NoValidation
-
-    decodeExtLedgerState' :: forall s . TopLevelConfig blk -> Decoder s (ExtLedgerState blk)
-    decodeExtLedgerState' cfg =
-      let ccfg = configCodec cfg
-      in decodeExtLedgerState
-           (decodeDisk ccfg)
-           (decodeDisk ccfg)
-           (decodeDisk ccfg)

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Types.hs

@@ -7,7 +7,7 @@ module Cardano.Tools.DBAnalyser.Types (
 import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (DiskSnapshot)
 
 import           Cardano.Tools.DBAnalyser.Analysis as AnalysisTypes
-                     (AnalysisName (..), AnalysisResult (..), Limit (..))
+                     (AnalysisName (..), AnalysisResult (..))
 import           Cardano.Tools.DBAnalyser.Block.Byron (ByronBlockArgs)
 import           Cardano.Tools.DBAnalyser.Block.Cardano (CardanoBlockArgs)
 import           Cardano.Tools.DBAnalyser.Block.Shelley (ShelleyBlockArgs)
@@ -17,14 +17,18 @@ data SelectDB =
     SelectChainDB
   | SelectImmutableDB (Maybe DiskSnapshot)
 
+data BackingStore = LMDB (Maybe Int) | MEM
+  deriving Eq
+
 data DBAnalyserConfig = DBAnalyserConfig {
     dbDir      :: FilePath
   , verbose    :: Bool
   , selectDB   :: SelectDB
   , validation :: Maybe ValidateBlocks
   , blockType  :: BlockType
   , analysis   :: AnalysisName
-  , confLimit  :: Limit
+  , cfgLimit   :: Maybe Int
+  , bsSelector :: BackingStore
   }
 
 data ValidateBlocks = ValidateAllBlocks | MinimumBlockValidation

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBSynthesizer/Forging.hs

@@ -38,6 +38,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunis
 import           Ouroboros.Consensus.Util.IOLike (atomically)
 import           Ouroboros.Network.AnchoredFragment as AF (Anchor (..),
                      AnchoredFragment, AnchoredSeq (..), headPoint)
+import Ouroboros.Consensus.Ticked
 
 import           Cardano.Tools.DBSynthesizer.Types (ForgeLimit (..),
                      ForgeResult (..))
@@ -119,7 +120,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg = do
         unticked <- do
           mExtLedger <- lift $ atomically $ ChainDB.getPastLedger chainDB bcPrevPoint
           case mExtLedger of
-            Just l  -> return l
+            Just (l, _)  -> return l
             Nothing -> exitEarly' "no ledger state"
 
         ledgerView <-
@@ -151,12 +152,12 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg = do
           _   -> exitEarly' "NoLeader"
 
         -- Tick the ledger state for the 'SlotNo' we're producing a block for
-        let tickedLedgerState :: Ticked (LedgerState blk)
+        let tickedLedgerState :: TickedLedgerState blk EmptyMK
             tickedLedgerState =
               applyChainTick
                 (configLedger cfg)
                 currentSlot
-                (ledgerState unticked)
+                (ledgerState unticked) `withLedgerTablesTicked` polyEmptyLedgerTables
 
         -- Block won't contain any transactions
         let txs = []

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBSynthesizer/Run.hs

@@ -33,6 +33,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB (cdbTracer,
                      withDB)
 import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                      (SnapshotInterval (..), defaultDiskPolicy)
+import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk
 import           Ouroboros.Consensus.Util.IOLike (atomically)
 import           Ouroboros.Consensus.Util.ResourceRegistry
 import           Ouroboros.Network.Block
@@ -123,8 +124,7 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (Some
             diskPolicy  = defaultDiskPolicy k DefaultSnapshotInterval
             dbArgs      = Node.mkChainDbArgs
                 registry InFuture.dontCheck pInfoConfig pInfoInitLedger chunkInfo $
-                    ChainDB.defaultArgs (Node.stdMkChainDbHasFS confDbDir) diskPolicy
-
+                    ChainDB.defaultArgs (Node.stdMkChainDbHasFS confDbDir) diskPolicy InMemoryBackingStore
         forgers <- pInfoBlockForging
         let fCount = length forgers
         putStrLn $ "--> forger count: " ++ show fCount